RolloverSpec.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

module Test.RolloverSpec where

import Control.Exception (finally)
import Data.Aeson.KeyMap qualified as KM
import Data.Map.Strict qualified as M
import Data.Text qualified as T
import Database.Bloodhound.Common.Client qualified as Client
import TestsUtils.Common
import TestsUtils.Import

-- Test fixture: the alias @bh-rollover@ points at the write index
-- @bh-rollover-000001@. After 'rolloverIndex' the alias is repointed
-- at @bh-rollover-000002@ and the new index is created.
rolloverAliasName :: IndexAliasName
rolloverAliasName = IndexAliasName [qqIndexName|bh-rollover|]

firstIndexName :: IndexName
firstIndexName = [qqIndexName|bh-rollover-000001|]

secondIndexName :: IndexName
secondIndexName = [qqIndexName|bh-rollover-000002|]

-- | Build the @cioAliases@ block that marks @bh-rollover@ as the write
-- index for @bh-rollover-000001@. The rollover API refuses to operate
-- on an alias that does not have a designated write index.
writeIndexAlias :: KM.KeyMap Value
writeIndexAlias =
  KM.singleton "bh-rollover" (toJSON defaultIndexAliasCreate {aliasCreateIsWriteIndex = Just True})

-- | Tear down any indices + alias left over from a previous run. Both
-- possible target indices are deleted because rollover may have
-- advanced the suffix in an earlier run.
cleanupRollover :: BH IO ()
cleanupRollover = do
  _ <- tryEsError $ performBHRequest $ deleteIndex firstIndexName
  _ <- tryEsError $ performBHRequest $ deleteIndex secondIndexName
  pure ()

-- | Create @bh-rollover-000001@ with the alias @bh-rollover@ already
-- attached as the write index (see 'writeIndexAlias'). The rollover
-- API refuses to operate on an alias that does not have a designated
-- write index.
seedRolloverAlias :: BH IO ()
seedRolloverAlias = do
  _ <- cleanupRollover
  let settings = IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits
  let opts =
        defaultCreateIndexOptions
          { cioSettings = Just settings,
            cioAliases = Just writeIndexAlias
          }
  _ <- performBHRequest $ createIndexOptions opts firstIndexName
  pure ()

-- | 'True' when the conditions map contains a key mentioning the given
-- substring with the given boolean value. The server renders each
-- threshold as a display string (e.g. @"[max_docs: 1]"@) rather than
-- echoing the request shape.
conditionsHas :: T.Text -> Bool -> Maybe (M.Map T.Text Bool) -> Bool
conditionsHas substr val =
  maybe
    False
    ( any
        ( \(k, v) ->
            T.isInfixOf substr k && v == val
        )
        . M.toList
    )

-- Test body for the conditions-met case. Exported so the spec can wrap
-- it in 'finally' for exception-safe cleanup.
conditionsMetAction :: BH IO ()
conditionsMetAction = do
  _ <- seedRolloverAlias
  _ <-
    performBHRequest $
      indexDocument
        firstIndexName
        defaultIndexDocumentSettings
        exampleTweet
        (DocId "1")
  _ <- performBHRequest $ refreshIndex firstIndexName
  resp <-
    Client.rolloverIndex
      rolloverAliasName
      (Just (defaultRolloverConditions {rolloverConditionsMaxDocs = Just 1}))
  liftIO $ do
    rolloverResponseAcknowledged resp `shouldBe` True
    rolloverResponseShardsAcknowledged resp `shouldBe` True
    rolloverResponseRolledOver resp `shouldBe` True
    rolloverResponseDryRun resp `shouldBe` False
    rolloverResponseOldIndex resp `shouldBe` Just firstIndexName
    rolloverResponseNewIndex resp `shouldBe` Just secondIndexName
    conditionsHas "max_docs" True (rolloverResponseConditions resp) `shouldBe` True

-- Test body for the unconditional-rollover case.
unconditionalAction :: BH IO ()
unconditionalAction = do
  _ <- seedRolloverAlias
  resp <- Client.rolloverIndex rolloverAliasName Nothing
  liftIO $ do
    rolloverResponseAcknowledged resp `shouldBe` True
    rolloverResponseRolledOver resp `shouldBe` True
    rolloverResponseOldIndex resp `shouldBe` Just firstIndexName
    rolloverResponseNewIndex resp `shouldBe` Just secondIndexName
    -- With no conditions supplied, no threshold should be marked met.
    let noMetThresholds = maybe True (all not . M.elems) (rolloverResponseConditions resp)
    noMetThresholds `shouldBe` True

-- Test body for the conditions-not-met case.
conditionsNotMetAction :: BH IO ()
conditionsNotMetAction = do
  _ <- seedRolloverAlias
  resp <-
    Client.rolloverIndex
      rolloverAliasName
      (Just (defaultRolloverConditions {rolloverConditionsMaxDocs = Just 100}))
  liftIO $ do
    rolloverResponseAcknowledged resp `shouldBe` False
    rolloverResponseRolledOver resp `shouldBe` False
    rolloverResponseOldIndex resp `shouldBe` Just firstIndexName
    rolloverResponseNewIndex resp `shouldBe` Just secondIndexName
    conditionsHas "max_docs" False (rolloverResponseConditions resp) `shouldBe` True

spec :: Spec
spec = do
  describe "rolloverIndex API" $ do
    -- Successful rollover: max_docs=1 is satisfied by indexing exactly
    -- one document before the call. ES swaps the alias to the new index
    -- and reports both old_index and new_index. The server echoes the
    -- condition back as a @Map Text Bool@ keyed by a human-readable
    -- description like @"[max_docs: 1]"@.
    --
    -- 'finally' ensures the indices are torn down even if an assertion
    -- throws, so a failed run does not leak @bh-rollover-000001@ /
    -- @bh-rollover-000002@ onto the server.
    it "rolls the alias over to the next index when conditions are met" $
      withTestEnv conditionsMetAction `finally` withTestEnv cleanupRollover

    -- Rollover without any conditions: the server creates the new index
    -- unconditionally and repoints the alias. This is the @Nothing@
    -- branch of the public API.
    it "rolls over unconditionally when conditions are Nothing" $
      withTestEnv unconditionalAction `finally` withTestEnv cleanupRollover

    -- Rollover conditions not satisfied: max_docs is set higher than
    -- the actual document count. The server reports @acknowledged=false@
    -- (no rollover performed) and @rolled_over=false@, and @conditions@
    -- shows the unmet threshold. The server still populates
    -- @old_index@ / @new_index@ with the candidate names.
    it "reports rolled_over=False when conditions are not met" $
      withTestEnv conditionsNotMetAction `finally` withTestEnv cleanupRollover

    -- The conditions block is omitted from the body when 'Nothing' is
    -- passed; the body is the empty bytestring (not absent) so the
    -- server treats the call as an unconditional rollover.
    it "sends an empty body when conditions are Nothing" $ do
      let req = rolloverIndex rolloverAliasName Nothing
      bhRequestBody req `shouldBe` Just ""

    it "includes a conditions object when conditions are Just" $ do
      let conditions = defaultRolloverConditions {rolloverConditionsMaxDocs = Just 5}
      let req = rolloverIndex rolloverAliasName (Just conditions)
      let expected = object ["conditions" .= object ["max_docs" .= (5 :: Int)]]
      (decode =<< bhRequestBody req) `shouldBe` Just expected