packages feed

bloodhound-1.0.0.0: tests/Test/TermVectorsSpec.hs

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