ValidateSpec.hs

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