bloodhound-1.0.0.0: tests/Test/JSONSpec.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Test.JSONSpec (spec) where
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
propJSON ::
forall a.
( Arbitrary a,
ToJSON a,
FromJSON a,
Show a,
Eq a,
Typeable a
) =>
Proxy a ->
Spec
propJSON _ = prop testName $ \(a :: a) ->
let jsonStr = "via " <> BL8.unpack (encode a)
in counterexample
jsonStr
( parseEither parseJSON (toJSON a)
=== Right a
)
where
testName = show ty <> " FromJSON/ToJSON roundtrips"
ty = typeOf (undefined :: a)
propApproxJSON ::
forall a.
( Arbitrary a,
ToJSON a,
FromJSON a,
Show a,
ApproxEq a,
Typeable a
) =>
Proxy a ->
Spec
propApproxJSON _ = prop testName $ \(a :: a) ->
let jsonStr = "via " <> BL8.unpack (encode a)
in counterexample
jsonStr
( parseEither parseJSON (toJSON a)
==~ Right a
)
where
testName = show ty <> " FromJSON/ToJSON roundtrips"
ty = typeOf (undefined :: a)
spec :: Spec
spec = do
describe "ToJSON RegexpFlags" $ do
it "generates the correct JSON for AllRegexpFlags" $
toJSON AllRegexpFlags `shouldBe` String "ALL"
it "generates the correct JSON for NoRegexpFlags" $
toJSON NoRegexpFlags `shouldBe` String "NONE"
it "generates the correct JSON for SomeRegexpFlags" $
let flags =
AnyString
:| [ Automaton,
Complement,
Empty,
Intersection,
Interval
]
in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
let String str = toJSON flags
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\"}"
mbJson `shouldBe` Just (EsError (Just 209) "Error message")
it "should parse ElasticSearch 7 responses (error.reason)" $ do
let mbJson = decode "{\"error\": {\"reason\": \"Error message\"}}"
mbJson `shouldBe` Just (EsError Nothing "Error message")
it "should parse OpenSearch 1.3 responses" $ do
-- This is a real error response for a version conflict
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)
propJSON (Proxy :: Proxy IndexAliasRouting)
propJSON (Proxy :: Proxy RoutingValue)
propJSON (Proxy :: Proxy ShardCount)
propJSON (Proxy :: Proxy ReplicaCount)
propJSON (Proxy :: Proxy TemplateName)
propJSON (Proxy :: Proxy IndexPattern)
propJSON (Proxy :: Proxy QueryString)
propJSON (Proxy :: Proxy FieldName)
propJSON (Proxy :: Proxy Script)
propJSON (Proxy :: Proxy ScriptLanguage)
propJSON (Proxy :: Proxy ScriptParams)
propJSON (Proxy :: Proxy CacheName)
propJSON (Proxy :: Proxy CacheKey)
propJSON (Proxy :: Proxy Existence)
propJSON (Proxy :: Proxy CutoffFrequency)
propJSON (Proxy :: Proxy Analyzer)
propJSON (Proxy :: Proxy MaxExpansions)
propJSON (Proxy :: Proxy Lenient)
propJSON (Proxy :: Proxy Tiebreaker)
propJSON (Proxy :: Proxy Boost)
propJSON (Proxy :: Proxy BoostTerms)
propJSON (Proxy :: Proxy MinimumMatch)
propJSON (Proxy :: Proxy DisableCoord)
propJSON (Proxy :: Proxy IgnoreTermFrequency)
propJSON (Proxy :: Proxy MinimumTermFrequency)
propJSON (Proxy :: Proxy MaxQueryTerms)
propJSON (Proxy :: Proxy Fuzziness)
propJSON (Proxy :: Proxy PrefixLength)
propJSON (Proxy :: Proxy RelationName)
propJSON (Proxy :: Proxy PercentMatch)
propJSON (Proxy :: Proxy StopWord)
propJSON (Proxy :: Proxy QueryPath)
propJSON (Proxy :: Proxy AllowLeadingWildcard)
propJSON (Proxy :: Proxy EnablePositionIncrements)
propJSON (Proxy :: Proxy AnalyzeWildcard)
propJSON (Proxy :: Proxy MaxWordLength)
propJSON (Proxy :: Proxy MinWordLength)
propJSON (Proxy :: Proxy PhraseSlop)
propJSON (Proxy :: Proxy MinDocFrequency)
propJSON (Proxy :: Proxy MaxDocFrequency)
propJSON (Proxy :: Proxy Filter)
propJSON (Proxy :: Proxy Query)
propJSON (Proxy :: Proxy SimpleQueryStringQuery)
propJSON (Proxy :: Proxy FieldOrFields)
propJSON (Proxy :: Proxy SimpleQueryFlag)
propJSON (Proxy :: Proxy RegexpQuery)
propJSON (Proxy :: Proxy QueryStringQuery)
propJSON (Proxy :: Proxy RangeQuery)
propJSON (Proxy :: Proxy PrefixQuery)
propJSON (Proxy :: Proxy NestedQuery)
propJSON (Proxy :: Proxy MoreLikeThisQuery)
propJSON (Proxy :: Proxy IndicesQuery)
propJSON (Proxy :: Proxy IgnoreUnmapped)
propJSON (Proxy :: Proxy MinChildren)
propJSON (Proxy :: Proxy MaxChildren)
propJSON (Proxy :: Proxy AggregateParentScore)
propJSON (Proxy :: Proxy HasParentQuery)
propJSON (Proxy :: Proxy HasChildQuery)
propJSON (Proxy :: Proxy FuzzyQuery)
propJSON (Proxy :: Proxy FunctionScoreQuery)
propJSON (Proxy :: Proxy BoostMode)
propJSON (Proxy :: Proxy ScoreMode)
propJSON (Proxy :: Proxy ComponentFunctionScoreFunction)
propJSON (Proxy :: Proxy FieldValueFactor)
propJSON (Proxy :: Proxy FactorModifier)
propJSON (Proxy :: Proxy DisMaxQuery)
propJSON (Proxy :: Proxy CommonTermsQuery)
propJSON (Proxy :: Proxy CommonMinimumMatch)
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 RangeRelation)
propJSON (Proxy :: Proxy AliasRouting)
propJSON (Proxy :: Proxy IndexAliasCreate)
propJSON (Proxy :: Proxy SearchAliasRouting)
propJSON (Proxy :: Proxy ScoreType)
propJSON (Proxy :: Proxy Distance)
propJSON (Proxy :: Proxy DistanceUnit)
propJSON (Proxy :: Proxy DistanceType)
propJSON (Proxy :: Proxy OptimizeBbox)
propJSON (Proxy :: Proxy GeoBoundingBoxConstraint)
propJSON (Proxy :: Proxy GeoFilterType)
propJSON (Proxy :: Proxy GeoBoundingBox)
propJSON (Proxy :: Proxy LatLon)
propJSON (Proxy :: Proxy RangeExecution)
prop "RegexpFlags FromJSON/ToJSON roundtrips, removing dups " $ \rfs ->
let expected = case rfs of
SomeRegexpFlags fs -> SomeRegexpFlags (NE.fromList (L.nub (NE.toList fs)))
x -> x
in parseEither parseJSON (toJSON rfs) === Right expected
propJSON (Proxy :: Proxy BoolMatch)
propJSON (Proxy :: Proxy Term)
propJSON (Proxy :: Proxy MultiMatchQuery)
-- propJSON (Proxy :: Proxy IndexSettings)
propJSON (Proxy :: Proxy CompoundFormat)
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')
propApproxJSON (Proxy :: Proxy ReplicaCount)
propApproxJSON (Proxy :: Proxy ReplicaBounds)
propApproxJSON (Proxy :: Proxy Bytes)
propApproxJSON (Proxy :: Proxy AllocationPolicy)
propApproxJSON (Proxy :: Proxy InitialShardCount)
propApproxJSON (Proxy :: Proxy FSType)
propApproxJSON (Proxy :: Proxy EsDuration)
propApproxJSON (Proxy :: Proxy DiskWatermark)
propApproxJSON (Proxy :: Proxy Compression)