PendingTasksSpec.hs

{-# LANGUAGE OverloadedStrings #-}

module Test.PendingTasksSpec where

import Data.Aeson.KeyMap qualified as KM
import Database.Bloodhound.Common.Client qualified as Client
import Database.Bloodhound.Common.Types
import TestsUtils.Common
import TestsUtils.Import

spec :: Spec
spec = do
  describe "cluster pending tasks API" $ do
    -- The pending queue is almost always empty on a quiet test cluster,
    -- so the live assertion only validates that the response decodes
    -- (proving the @{"tasks": [...]}@ envelope is handled correctly).
    it "getPendingTasks decodes the live response without error" $
      withTestEnv $ do
        tasks <- Client.getPendingTasks
        liftIO $ tasks `shouldSatisfy` (all pendingTaskPriorityMatches)

  -- ------------------------------------------------------------------ --
  -- Pure FromJSON/ToJSON round-trip (no ES required)                   --
  -- ------------------------------------------------------------------ --
  describe "PendingTask JSON codec" $ do
    let sampleTask :: Value
        sampleTask =
          object
            [ "insert_order" .= (42 :: Int),
              "priority" .= ("URGENT" :: Text),
              "source" .= ("create-index [foo-12], message [...]" :: Text),
              "executing" .= (False :: Bool),
              "time_in_queue_millis" .= (1500 :: Int),
              "time_in_queue" .= ("1.5s" :: Text)
            ]

    it "decodes a fully-populated task" $
      case fromJSON @PendingTask sampleTask of
        Success pt -> do
          pendingTaskInsertOrder pt `shouldBe` 42
          pendingTaskPriority pt `shouldBe` PendingTaskUrgent
          pendingTaskSource pt `shouldBe` "create-index [foo-12], message [...]"
          pendingTaskExecuting pt `shouldBe` False
          pendingTaskTimeInQueueMillis pt `shouldBe` 1500
          pendingTaskTimeInQueue pt `shouldBe` "1.5s"
        Error err -> expectationFailure ("decode failed: " <> err)

    it "round-trips without dropping typed fields" $
      case fromJSON @PendingTask sampleTask of
        Success pt ->
          case toJSON pt of
            Object reencoded ->
              case fromJSON @PendingTask (Object reencoded) of
                Success again -> again `shouldBe` pt
                Error err -> expectationFailure ("re-decode failed: " <> err)
            other -> expectationFailure ("re-encode produced non-object: " <> show other)
        Error err -> expectationFailure ("initial decode failed: " <> err)

    it "preserves extra (untyped) fields through the round-trip" $
      let withExtra =
            object
              [ "insert_order" .= (1 :: Int),
                "priority" .= ("HIGH" :: Text),
                "source" .= ("shard-start [...]" :: Text),
                "executing" .= (True :: Bool),
                "time_in_queue_millis" .= (10 :: Int),
                "time_in_queue" .= ("10ms" :: Text),
                "future_field" .= ("forward-compatible value" :: Text)
              ]
       in case fromJSON @PendingTask withExtra of
            Success pt ->
              case toJSON pt of
                Object reencoded ->
                  case fromJSON @PendingTask (Object reencoded) of
                    Success again -> do
                      again `shouldBe` pt
                      case pendingTaskOther again of
                        Object o -> KM.lookup "future_field" o `shouldBe` Just (String "forward-compatible value")
                        _ -> expectationFailure "future_field dropped from *Other round-trip"
                    Error err -> expectationFailure ("re-decode failed: " <> err)
                other -> expectationFailure ("re-encode produced non-object: " <> show other)
            Error err -> expectationFailure ("initial decode failed: " <> err)

    it "decodes every documented priority value" $
      mapM_
        ( \(wire, expected) ->
            case fromJSON @PendingTaskPriority (String wire) of
              Success got -> got `shouldBe` expected
              Error err -> expectationFailure ("priority " <> show wire <> " failed: " <> err)
        )
        [ ("IMMEDIATE", PendingTaskImmediate),
          ("URGENT", PendingTaskUrgent),
          ("HIGH", PendingTaskHigh),
          ("NORMAL", PendingTaskNormal),
          ("LOW", PendingTaskLow)
        ]

    it "rejects an unknown priority value" $
      case fromJSON @PendingTaskPriority (String "NONSENSICAL") of
        Success _ -> expectationFailure "expected unknown priority to fail decoding"
        Error _ -> pure ()

    it "decodes a minimal payload using sensible defaults for missing fields" $
      let minimal = object ["source" .= ("only-source" :: Text)]
       in case fromJSON @PendingTask minimal of
            Success pt -> do
              pendingTaskSource pt `shouldBe` "only-source"
              pendingTaskInsertOrder pt `shouldBe` 0
              pendingTaskPriority pt `shouldBe` PendingTaskNormal
              pendingTaskExecuting pt `shouldBe` False
            Error err -> expectationFailure ("decode failed: " <> err)

-- | Every pending task carries one of the documented 'PendingTaskPriority'
-- values — used by the live test to confirm the decoded priority is in
-- the expected set.
pendingTaskPriorityMatches :: PendingTask -> Bool
pendingTaskPriorityMatches pt =
  pendingTaskPriority pt
    `elem` [ PendingTaskImmediate,
             PendingTaskUrgent,
             PendingTaskHigh,
             PendingTaskNormal,
             PendingTaskLow
           ]