ReindexResponseSpec.hs

{-# 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