bloodhound-1.0.0.0: tests/Test/ClusterAllocationExplainSpec.hs
{-# 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 ()