SuggestSpec.hs

{-# LANGUAGE OverloadedStrings #-}

module Test.SuggestSpec (spec) where

import Data.Aeson (decode, encode)
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Map.Strict qualified as Map
import TestsUtils.Common
import TestsUtils.Import

spec :: Spec
spec = do
  describe "Suggest" $
    it "returns a search suggestion using the phrase suggester" $
      withTestEnv $ do
        _ <- insertData
        let query = QueryMatchNoneQuery
            phraseSuggester = mkPhraseSuggester (FieldName "message")
            namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)
            search' = mkSearch (Just query) Nothing
            search = search' {suggestBody = Just namedSuggester}
            expectedText = Just "use haskell"
        sr <- performBHRequest $ searchByIndex @Tweet testIndex search
        liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText

  -- ----------------------------------------------------------------------
  -- Unit tests for the term / completion / context suggester additions
  -- (bloodhound-04f.10). These pin the wire shape of each new
  -- 'SuggestType' constructor and verify the documented round-trip
  -- behaviour, including the 'SuggestTypeCustom' escape hatch and the
  -- intent-only nature of 'SuggestTypeContextSuggester'.
  describe "SuggestType term/completion/context wire shape" $ do
    it "renders a term suggester under the \"term\" tag" $ do
      let body = encode (SuggestTypeTermSuggester (mkTermSuggester (FieldName "message")))
      -- @suggest_mode@ is non-'Maybe' (defaults to @missing@) so it is
      -- always emitted, mirroring 'DirectGenerators' on encode.
      body `shouldBe` "{\"term\":{\"field\":\"message\",\"suggest_mode\":\"missing\"}}"

    it "renders a completion suggester under the \"completion\" tag" $ do
      let body = encode (SuggestTypeCompletionSuggester (mkCompletionSuggester (FieldName "suggest")))
      body `shouldBe` "{\"completion\":{\"field\":\"suggest\"}}"

    it "renders a context suggester under the \"completion\" tag (wire-identical to completion)" $ do
      -- The context suggester is not a separate wire endpoint: it
      -- serialises as @completion@ so the server accepts the request.
      -- The constructor exists only to signal caller intent.
      let cs = mkContextSuggester (mkCompletionSuggester (FieldName "suggest"))
      encode (SuggestTypeContextSuggester cs)
        `shouldBe` "{\"completion\":{\"field\":\"suggest\"}}"

    it "renders the custom escape hatch under its caller-supplied tag" $ do
      let payload = object ["prefix" .= String "ni"]
      encode (SuggestTypeCustom "mySuggester" payload)
        `shouldBe` "{\"mySuggester\":{\"prefix\":\"ni\"}}"

    it "wraps a typed suggester in a named Suggest envelope" $ do
      let named = Suggest "tring" "my-suggest" (SuggestTypeTermSuggester (mkTermSuggester (FieldName "message")))
      encode named
        `shouldBe` "{\"my-suggest\":{\"term\":{\"field\":\"message\",\"suggest_mode\":\"missing\"}},\"text\":\"tring\"}"

  describe "SuggestType term/completion/context decoding" $ do
    it "decodes a {\"term\": ...} body as SuggestTypeTermSuggester" $ do
      let Just (st :: SuggestType) = decode "{\"term\":{\"field\":\"message\"}}"
      case st of
        SuggestTypeTermSuggester ts ->
          unFieldName (termSuggesterField ts) `shouldBe` "message"
        other ->
          expectationFailure $ "expected SuggestTypeTermSuggester, got " <> show other

    it "decodes a {\"completion\": ...} body as SuggestTypeCompletionSuggester" $ do
      let Just (st :: SuggestType) = decode "{\"completion\":{\"field\":\"suggest\"}}"
      case st of
        SuggestTypeCompletionSuggester cs ->
          unFieldName (completionSuggesterField cs) `shouldBe` "suggest"
        other ->
          expectationFailure $ "expected SuggestTypeCompletionSuggester, got " <> show other

    it "decodes an unknown tag as SuggestTypeCustom (lossless round-trip)" $ do
      let raw = "{\"futureSuggester\":{\"foo\":1}}" :: LBS.ByteString
          Just (st :: SuggestType) = decode raw
      case st of
        SuggestTypeCustom tag payload -> do
          tag `shouldBe` "futureSuggester"
          -- The Value payload is preserved verbatim, so encode . decode
          -- is the identity for unknown tags.
          encode st `shouldBe` raw
        other ->
          expectationFailure $ "expected SuggestTypeCustom, got " <> show other

    it "treats a context suggester's wire form as a completion suggester on decode" $ do
      -- Encoding then decoding a 'SuggestTypeContextSuggester' yields a
      -- 'SuggestTypeCompletionSuggester': this is by design (the two
      -- are wire-identical; see 'SuggestType' docs) and is why the
      -- 'Arbitrary SuggestType' generator omits the context variant.
      let cs = mkContextSuggester (mkCompletionSuggester (FieldName "suggest"))
          encoded = encode (SuggestTypeContextSuggester cs)
          Just (decoded :: SuggestType) = decode encoded
      case decoded of
        SuggestTypeCompletionSuggester _ -> pure ()
        other ->
          expectationFailure $
            "expected the context suggester to decode as completion, got "
              <> show other

    it "rejects a multi-key or non-object body" $ do
      decode "{\"term\":{\"field\":\"x\"},\"phrase\":{}}" `shouldBe` (Nothing :: Maybe SuggestType)
      decode "[1,2,3]" `shouldBe` (Nothing :: Maybe SuggestType)

  describe "TermSuggester tuning knobs" $ do
    it "serialises sort and string_distance as their documented string forms" $ do
      let ts =
            (mkTermSuggester (FieldName "message"))
              { termSuggesterSort = Just TermSuggesterSortFrequency,
                termSuggesterStringDistance = Just TermSuggesterStringDistanceJaroWinkler
              }
      let Just (decodedTs :: TermSuggester) = decode (encode ts)
      termSuggesterSort decodedTs `shouldBe` Just TermSuggesterSortFrequency
      termSuggesterStringDistance decodedTs `shouldBe` Just TermSuggesterStringDistanceJaroWinkler

    it "defaults suggest_mode to missing when omitted on decode" $ do
      let Just (decodedTs :: TermSuggester) = decode "{\"field\":\"message\"}"
      termSuggesterSuggestMode decodedTs `shouldBe` DirectGeneratorSuggestModeMissing

  describe "CompletionSuggester contexts" $ do
    it "serialises a non-empty contexts map under \"contexts\"" $ do
      let cs =
            (mkCompletionSuggester (FieldName "suggest"))
              { completionSuggesterContexts =
                  Just $
                    Map.fromList
                      [ ("color", ContextQueryValueText "red" :| []),
                        ("place", ContextQueryValueBoosted "nyc" 2 :| [])
                      ]
              }
      let Just (decodedCs :: CompletionSuggester) = decode (encode cs)
      completionSuggesterContexts decodedCs
        `shouldBe` Just
          ( Map.fromList
              [ ("color", ContextQueryValueText "red" :| []),
                ("place", ContextQueryValueBoosted "nyc" 2 :| [])
              ]
          )

    it "renders Just Map.empty as \"contexts\": {} and round-trips back to Just Map.empty" $ do
      -- @Nothing@ and @Just mempty@ must be distinguishable on the wire
      -- (otherwise the Arbitrary-driven round-trip in JSONSpec would
      -- fail); @Just mempty@ therefore renders as an empty object.
      let cs = (mkCompletionSuggester (FieldName "suggest")) {completionSuggesterContexts = Just Map.empty}
      encode cs `shouldBe` "{\"contexts\":{},\"field\":\"suggest\"}"
      let Just (decodedCs :: CompletionSuggester) = decode (encode cs)
      completionSuggesterContexts decodedCs `shouldBe` Just Map.empty

    it "omits the contexts field entirely when it is Nothing" $ do
      let cs = mkCompletionSuggester (FieldName "suggest")
      encode cs `shouldBe` "{\"field\":\"suggest\"}"
      let Just (decodedCs :: CompletionSuggester) = decode (encode cs)
      completionSuggesterContexts decodedCs `shouldBe` Nothing

  describe "SuggestType round-trip" $ do
    -- The QuickCheck @propJSON (Proxy :: Proxy Suggest)@ property in
    -- JSONSpec covers the generated variants; these cases pin
    -- specific interesting shapes that are unlikely to be hit by the
    -- generator.
    it "round-trips a minimal term suggester" $ do
      let st = SuggestTypeTermSuggester (mkTermSuggester (FieldName "message"))
      (decode . encode) st `shouldBe` Just st

    it "round-trips a minimal completion suggester" $ do
      let st = SuggestTypeCompletionSuggester (mkCompletionSuggester (FieldName "suggest"))
      (decode . encode) st `shouldBe` Just st