{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-x-partial -Wno-incomplete-uni-patterns #-}

-- | Parameterized operations test suite, instantiated for each 'MonadArbiter' backend.
module Arbiter.Test.Operations
  ( operationsSpec
  ) where

import Arbiter.Core.Codec (Col (..), col, pval)
import Arbiter.Core.HighLevel (SetVisibilityResult (..))
import Arbiter.Core.HighLevel qualified as HL
import Arbiter.Core.Job.DLQ qualified as DLQ
import Arbiter.Core.Job.Schema qualified as Schema
import Arbiter.Core.Job.Types
import Arbiter.Core.JobResult (EncodeJobResult)
import Arbiter.Core.JobTree ((<~~))
import Arbiter.Core.JobTree qualified as JT
import Arbiter.Core.MonadArbiter (MonadArbiter, RegistryOf, ResultOf, getSchema)
import Arbiter.Core.MonadArbiter qualified as MA
import Arbiter.Core.Operations qualified as Ops
import Arbiter.Core.QueueRegistry (TableForPayload)
import Arbiter.Core.Sql.DLQ qualified as Tmpl
import Arbiter.Core.Sql.Groups qualified as GroupsTmpl
import Arbiter.Core.Sql.Tree qualified as TreeTmpl
import Control.Concurrent (threadDelay)
import Control.Monad (forM, forM_, void)
import Data.Aeson qualified as Aeson
import Data.Int (Int32, Int64)
import Data.List (find, nub, sort)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.Maybe (isJust, listToMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time (addUTCTime, getCurrentTime)
import Data.UUID.Types qualified as UUID
import GHC.TypeLits (KnownSymbol)
import Test.Hspec
import UnliftIO.Async (concurrently)

import Arbiter.Test.Setup (execQuery, execStatement, truncateToMicros)

-- | Build a test suite for the given 'MonadArbiter' runner.
operationsSpec
  :: forall payload m env
   . ( EncodeJobResult (ResultOf m payload)
     , Eq payload
     , JobPayload payload
     , KnownSymbol (TableForPayload payload (RegistryOf m))
     , MonadArbiter m
     , Show payload
     )
  => (Text -> payload)
  -- ^ Constructor for a simple test message payload
  -> (Text -> ResultOf m payload)
  -- ^ Constructor for the queue's declared handler result
  -> (forall a. env -> m a -> IO a)
  -- ^ Runner for monad actions
  -> SpecWith env
operationsSpec :: forall payload (m :: * -> *) env.
(EncodeJobResult (ResultOf m payload), Eq payload,
 JobPayload payload,
 KnownSymbol (TableForPayload payload (RegistryOf m)),
 MonadArbiter m, Show payload) =>
(Text -> payload)
-> (Text -> ResultOf m payload)
-> (forall a. env -> m a -> IO a)
-> SpecWith env
operationsSpec Text -> payload
mkMessage Text -> ResultOf m payload
mkResult forall a. env -> m a -> IO a
runM = do
  -- Test helpers
  let claimJobs :: env -> Int -> IO [JobRead payload]
claimJobs env
env Int
count = env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
count NominalDiffTime
60) :: IO [JobRead payload]
      claimJobsAs :: env -> Int -> UUID -> IO [JobRead payload]
claimJobsAs env
env Int
count UUID
worker = env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> UUID -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> UUID -> m [JobRead payload]
HL.claimNextVisibleJobsAs Int
count NominalDiffTime
60 UUID
worker) :: IO [JobRead payload]
      getJob :: env -> Int64 -> IO (Maybe (JobRead payload))
getJob env
env Int64
jobId = env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.getJobById @payload Int64
jobId)
      assertSuspended :: env -> Int64 -> IO ()
assertSuspended env
env Int64
jobId = do
        Just job <- env -> Int64 -> IO (Maybe (JobRead payload))
getJob env
env Int64
jobId
        suspended job `shouldBe` True
      assertNotSuspended :: env -> Int64 -> IO ()
assertNotSuspended env
env Int64
jobId = do
        Just job <- env -> Int64 -> IO (Maybe (JobRead payload))
getJob env
env Int64
jobId
        suspended job `shouldBe` False
      assertGone :: env -> Int64 -> IO ()
assertGone env
env Int64
jobId = do
        fetched <- env -> Int64 -> IO (Maybe (JobRead payload))
getJob env
env Int64
jobId
        fetched `shouldBe` Nothing
      dlqAll :: env -> IO [DLQJob payload]
dlqAll env
env = env -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
      deleteCancelledAs :: env -> UUID -> [Int64] -> IO [Int64]
deleteCancelledAs env
env UUID
owner [Int64]
jobIds =
        env -> m [Int64] -> IO [Int64]
forall a. env -> m a -> IO a
runM env
env (m [Int64] -> IO [Int64]) -> m [Int64] -> IO [Int64]
forall a b. (a -> b) -> a -> b
$ do
          schemaName <- m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema
          Ops.deleteCancelledJobs schemaName (HL.queueTable @payload @m) (Just owner) jobIds
      groupsTable :: m Text
groupsTable = do
        schemaName <- m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema
        pure (Schema.jobQueueGroupsTable schemaName (HL.queueTable @payload @m))
      deleteRowDirectly :: env -> Int64 -> IO ()
deleteRowDirectly env
env Int64
jobId =
        env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          schemaName <- m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema
          let tbl = Text -> Text -> Text
Schema.jobQueueTable Text
schemaName (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m)
          void $ execStatement ("DELETE FROM " <> tbl <> " WHERE id = ?") [pval CInt8 jobId]
      lockedFromRoot :: env -> [Int64] -> IO Int64
lockedFromRoot env
env [Int64]
jobIds =
        env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (m Int64 -> IO Int64) -> m Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ do
          schemaName <- m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema
          sum <$> MA.executeQuery (TreeTmpl.lockJobTreesFromRootSQL schemaName (HL.queueTable @payload @m) jobIds)
      driftGroupCount :: env -> Text -> Int32 -> IO ()
driftGroupCount env
env Text
key Int32
count =
        env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          tbl <- m Text
groupsTable
          void $
            execStatement
              ("UPDATE " <> tbl <> " SET job_count = ? WHERE group_key = ?")
              [pval CInt4 count, pval CText key]
      groupCount :: env -> Text -> IO (Maybe Int32)
groupCount env
env Text
key =
        env -> m (Maybe Int32) -> IO (Maybe Int32)
forall a. env -> m a -> IO a
runM env
env (m (Maybe Int32) -> IO (Maybe Int32))
-> m (Maybe Int32) -> IO (Maybe Int32)
forall a b. (a -> b) -> a -> b
$ do
          tbl <- m Text
groupsTable
          rows <- execQuery ("SELECT job_count FROM " <> tbl <> " WHERE group_key = ?") [pval CText key] (col "job_count" CInt4)
          pure (listToMaybe rows :: Maybe Int32)

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"job kind" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"stores the label its payload derives" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"kind-store") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"labelled")
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      jobKind (payloadKeys inserted) `shouldBe` kindOf (mkMessage "labelled" :: payload)
      jobKind (payloadKeys inserted) `shouldNotBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"narrows a listing to one label" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"kind-filter") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"filtered")
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      Just kind <- Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (payload -> Maybe Text
forall payload. HasKind payload => payload -> Maybe Text
kindOf (Text -> payload
mkMessage Text
"filtered" :: payload))
      matched <- runM env (HL.listJobsFiltered [Ops.FilterKind kind] 10 0) :: IO [JobRead payload]
      map payload matched `shouldBe` [mkMessage "filtered"]
      missed <- runM env (HL.listJobsFiltered [Ops.FilterKind "NoSuchKind"] 10 0) :: IO [JobRead payload]
      missed `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"counts queue depth by label" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let counted :: payload
counted = Text -> payload
mkMessage Text
"counted" :: payload
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"kind-count") (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob payload
counted)))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"kind-count") (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob payload
counted)))
      Just kind <- Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (payload -> Maybe Text
forall payload. HasKind payload => payload -> Maybe Text
kindOf payload
counted)
      stats <- runM env (HL.getQueueStats @payload)
      Map.lookup kind (Ops.kindCounts stats) `shouldBe` Just 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"carries the label into the dead-letter queue" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"kind-dlq") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"dead")
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- env -> Int -> IO [JobRead payload]
claimJobs env
env Int
1
      void $ runM env (HL.moveToDLQ "boom" (head claimed))
      Just kind <- pure (kindOf (mkMessage "dead" :: payload))
      dead <- runM env (HL.listDLQFiltered [Ops.FilterKind kind] 10 0) :: IO [DLQ.DLQJob payload]
      map (jobKind . payloadKeys . DLQ.jobSnapshot) dead `shouldBe` [Just kind]

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"claimNextVisibleJobs" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"claims jobs in priority order" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert jobs with different priorities
      let highPriority :: JobWrite payload
highPriority =
            Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
0 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"claim-priority-test" (Text -> payload
mkMessage Text
"High")
          lowPriority :: JobWrite payload
lowPriority =
            Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
10 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"claim-priority-test" (Text -> payload
mkMessage Text
"Low")

      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
lowPriority)
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
highPriority)

      -- Claim one job
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 1
      payload (head claimed) `shouldBe` mkMessage "High"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"claims the ready top-priority job ahead of a scheduled sibling in the same group" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      now <- IO UTCTime
getCurrentTime
      -- A low-priority job scheduled to run in the future. It is inserted first
      -- and has the lower id.
      let future = UTCTime -> UTCTime
truncateToMicros (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now)
          deprioritizedScheduled =
            Maybe UTCTime -> JobWrite payload -> JobWrite payload
forall payload.
Maybe UTCTime -> JobWrite payload -> JobWrite payload
setNotVisibleUntil (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
future) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
10 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"claim-priority-scheduled" (Text -> payload
mkMessage Text
"Scheduled")
          topPriority =
            Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
0 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"claim-priority-scheduled" (Text -> payload
mkMessage Text
"Top")

      void $ runM env (HL.insertJob deprioritizedScheduled)
      void $ runM env (HL.insertJob topPriority)

      -- The not-yet-due scheduled job does not block the group. The ready
      -- top-priority job is claimed.
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]

      length claimed `shouldBe` 1
      payload (head claimed) `shouldBe` mkMessage "Top"
      priority (head claimed) `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"claims jobs from different groups" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"group1") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"G1")
          job2 :: JobWrite payload
job2 = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"group2") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"G2")

      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job2)

      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
2 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 2
      map groupKey claimed `shouldMatchList` [Just "group1", Just "group2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"respects per-group ordering" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert two jobs in the same group
      let job1 :: JobWrite payload
job1 = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"claim-hol-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"First")
          job2 :: JobWrite payload
job2 = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"claim-hol-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Second")

      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job2)

      -- Claim only 1 job.
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 1
      payload (head claimed) `shouldBe` mkMessage "First"

      -- The second job stays in the queue and is not claimable until the first is acked.
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ungrouped jobs can be claimed in parallel" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert two ungrouped jobs
      let job1 :: JobWrite payload
job1 = payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Ungrouped1")
          job2 :: JobWrite payload
job2 = payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Ungrouped2")

      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job2)

      -- Both are claimable at once
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
2 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 2
      map groupKey claimed `shouldMatchList` [Nothing, Nothing]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ungrouped and grouped jobs compete fairly by insertion order" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert interleaved: ungrouped get lower IDs than grouped
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"U1")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"fairness-single-a" (Text -> payload
mkMessage Text
"G1")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"U2")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"fairness-single-b" (Text -> payload
mkMessage Text
"G2")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"U3")))

      -- Claim 3 out of 5. The 3 lowest ids come out.
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
3 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 3
      let ungroupedCount = [JobRead payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JobRead payload] -> Int) -> [JobRead payload] -> Int
forall a b. (a -> b) -> a -> b
$ (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey JobRead payload
job Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing) [JobRead payload]
claimed
      let groupedCount = [JobRead payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([JobRead payload] -> Int) -> [JobRead payload] -> Int
forall a b. (a -> b) -> a -> b
$ (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey JobRead payload
job Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
forall a. Maybe a
Nothing) [JobRead payload]
claimed
      -- U1 (id=1), G1 (id=2), U2 (id=3) claimed. G2 (id=4) and U3 (id=5) left
      ungroupedCount `shouldBe` 2
      groupedCount `shouldBe` 1
      map payload claimed `shouldBe` [mkMessage "U1", mkMessage "G1", mkMessage "U2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"increments attempts on claim" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"claim-attempts-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Test")

      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      attempts inserted `shouldBe` 0

      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      attempts (head claimed) `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"claimed jobs are not re-claimable" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"claim-visibility-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Test")

      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)

      -- Claim the job
      claimed1 <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]
      length claimed1 `shouldBe` 1

      -- A second claim gets nothing.
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ackJob" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"removes a job from the queue" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ack-remove-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Test")

      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 1

      -- Acknowledge the job
      void $ runM env (HL.ackJob (head claimed))

      -- A second claim gets nothing.
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"allows next job in group to be claimed after ack" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ack-next-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"First")
          job2 :: JobWrite payload
job2 = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"ack-next-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Second")

      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job2)

      -- Claim first job
      claimed1 <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]
      length claimed1 `shouldBe` 1
      payload (head claimed1) `shouldBe` mkMessage "First"

      -- Ack it
      void $ runM env (HL.ackJob (head claimed1))

      -- The second job is claimable now
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 1
      payload (head claimed2) `shouldBe` mkMessage "Second"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not complete a force-cancel-flagged job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- A handler that acks after force-cancel has flagged its job does not complete it.
      let job :: JobWrite payload
job = payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"cancel-then-ack")
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobsAs 1 60 UUID.nil) :: IO [JobRead payload]
      length claimed `shouldBe` 1

      flagged <- runM env (HL.forceCancelJob @payload (primaryKey inserted))
      flagged `shouldBe` 1

      acked <- runM env (HL.ackJob (head claimed))
      acked `shouldBe` 0

      -- The flagged row survives, left for the cancel path to reap.
      getJob env (primaryKey inserted) >>= (`shouldSatisfy` isJust)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"leaves a force-cancel-flagged job for the worker holding its lease" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Deleting it elsewhere takes the flag away before its holder can read it.
      let owner :: UUID
owner = UUID
UUID.nil
          other :: UUID
other = Word32 -> Word32 -> Word32 -> Word32 -> UUID
UUID.fromWords Word32
1 Word32
1 Word32
1 Word32
1
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"cancel-lease-owner")))
      let jobId = JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
inserted
      claimed <- runM env (HL.claimNextVisibleJobsAs 1 60 owner) :: IO [JobRead payload]
      length claimed `shouldBe` 1

      flagged <- runM env (HL.forceCancelJob @payload jobId)
      flagged `shouldBe` 1

      deleteCancelledAs env other [jobId] >>= (`shouldBe` [])
      getJob env jobId >>= (`shouldSatisfy` isJust)

      deleteCancelledAs env owner [jobId] >>= (`shouldBe` [jobId])
      assertGone env jobId

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"nackJob" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refunds one attempt however often the same claim nacks" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"nack-repeat")))
      firstClaim <- claimJobsAs env 1 UUID.nil
      void $ runM env (HL.setVisibilityTimeout 0 (head firstClaim))
      held <- claimJobsAs env 1 UUID.nil
      map attempts held `shouldBe` [2]

      runM env (HL.nackJob (head held)) `shouldReturn` 1
      runM env (HL.nackJob (head held)) `shouldReturn` 0

      Just reread <- getJob env (primaryKey inserted)
      attempts reread `shouldBe` 1
      claimedBy reread `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a nacked job is not counted in flight" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"nack-status")))
      firstClaim <- claimJobsAs env 1 UUID.nil
      void $ runM env (HL.setVisibilityTimeout 0 (head firstClaim))
      held <- claimJobsAs env 1 UUID.nil
      map attempts held `shouldBe` [2]
      runM env (HL.nackJob (head held)) `shouldReturn` 1

      stats <- runM env (HL.getQueueStats @payload)
      HL.inFlightJobs stats `shouldBe` 0
      HL.backoffJobs stats `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"settles two batches over the same parents concurrently without deadlocking" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- A bulk ack and a bulk DLQ move each hold one parent and want the other.
      -- Both take the union of parent locks up front.
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
8 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
round' -> do
        let name :: Text -> payload
name Text
side = Text -> payload
mkMessage (Text
"lockorder-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
round') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
side)
            tree :: Text -> JobTree payload
tree Text
side =
              JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
name (Text
side Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-parent")))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
name (Text
side Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-ack"))) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
name (Text
side Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-dlq")))])
        Right _ <- env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree (Text -> JobTree payload
tree Text
"a"))
        Right _ <- runM env (HL.insertJobTree (tree "b"))
        children <- claimJobs env 4
        length children `shouldBe` 4
        let pick Text
suffix = (JobRead payload -> Bool)
-> [JobRead payload] -> Maybe (JobRead payload)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
name Text
suffix) (payload -> Bool)
-> (JobRead payload -> payload) -> JobRead payload -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload) [JobRead payload]
children
            Just ackA = pick "a-ack"
            Just ackB = pick "b-ack"
            Just dlqA = pick "a-dlq"
            Just dlqB = pick "b-dlq"
        -- Opposite child order on each side.
        (acked, moved) <-
          concurrently
            (runM env (HL.ackJobsBatch [ackB, ackA]))
            (runM env (HL.moveToDLQBatch [(dlqA, "boom"), (dlqB, "boom")]))
        length acked `shouldBe` 2
        moved `shouldBe` 2
        -- Both parents woke. The two settles serialized on the parent lock.
        parents <- claimJobs env 2
        length parents `shouldBe` 2
        runM env (HL.ackJobsBatch parents) >>= ((`shouldBe` 2) . length)
        runM env (HL.listJobs @payload 100 0) >>= (`shouldBe` [])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"nacks a batch in one statement, leaving a reclaimed job alone" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just jobA <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"nack-batch-a")))
      Just jobB <- runM env (HL.insertJob (defaultJob (mkMessage "nack-batch-b")))
      held <- claimJobsAs env 2 UUID.nil
      map attempts held `shouldBe` [1, 1]

      Just heldB <- pure (find ((== primaryKey jobB) . primaryKey) held)
      void $ runM env (HL.setVisibilityTimeout 0 heldB)
      stolen <- claimJobsAs env 1 (UUID.fromWords 4 4 4 4)
      map primaryKey stolen `shouldBe` [primaryKey jobB]

      runM env (HL.nackJobsBatch held) >>= (`shouldBe` [primaryKey jobA])
      Just rereadA <- getJob env (primaryKey jobA)
      Just rereadB <- getJob env (primaryKey jobB)
      attempts rereadA `shouldBe` 0
      attempts rereadB `shouldBe` 2

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"refreshGroups" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"covers the keys past the ones a pass already walked" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let keys :: [Text]
keys = [Text
"grp-cursor-a", Text
"grp-cursor-b", Text
"grp-cursor-c"]
          groupsWindow :: Int -> Maybe Text -> IO [Text]
groupsWindow Int
limit Maybe Text
cursor =
            env -> m [Text] -> IO [Text]
forall a. env -> m a -> IO a
runM env
env (m [Text] -> IO [Text]) -> m [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ do
              schemaName <- m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema
              MA.executeQuery (GroupsTmpl.groupsWindowSQL schemaName (HL.queueTable @payload @m) limit cursor)
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
keys ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
key -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
key (Text -> payload
mkMessage Text
key)))

      Int -> Maybe Text -> IO [Text]
groupsWindow Int
2 Maybe Text
forall a. Maybe a
Nothing IO [Text] -> ([Text] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
2 [Text]
keys)
      Int -> Maybe Text -> IO [Text]
groupsWindow Int
2 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"grp-cursor-b") IO [Text] -> ([Text] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
2 [Text]
keys)
      Int -> Maybe Text -> IO [Text]
groupsWindow Int
2 (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"grp-cursor-c") IO [Text] -> ([Text] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reclaims an emptied group the cursor has already passed" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let emptied :: Text
emptied = Text
"grp-reclaim-a"
          laterKeys :: [Text]
laterKeys = [Text
"grp-reclaim-b", Text
"grp-reclaim-c"]
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Text
emptied Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
laterKeys) ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
key -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
key (Text -> payload
mkMessage Text
key)))
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]
      void $ runM env (HL.ackJob (head claimed))

      -- Acking the only job resets the summary in place.
      groupCount env emptied `shouldReturn` Just 0

      runM env $ do
        schemaName <- getSchema
        void
          ( Ops.refreshGroupsForQueue
              schemaName
              (HL.queueTable @payload @m)
              2
              (Just (Ops.GroupsCursor (Just "grp-reclaim-b") Nothing))
          )
      groupCount env emptied `shouldReturn` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"resumes the emptied scan past the keys a pass already drained" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let live :: [Text]
live = [Text
"grp-drain-m1", Text
"grp-drain-m2"]
          low :: Text
low = Text
"grp-drain-a"
          high :: Text
high = Text
"grp-drain-z"
          pass :: Maybe GroupsCursor -> IO (Maybe GroupsCursor)
pass Maybe GroupsCursor
cursor =
            env -> m (Maybe GroupsCursor) -> IO (Maybe GroupsCursor)
forall a. env -> m a -> IO a
runM env
env (m (Maybe GroupsCursor) -> IO (Maybe GroupsCursor))
-> m (Maybe GroupsCursor) -> IO (Maybe GroupsCursor)
forall a b. (a -> b) -> a -> b
$ do
              schemaName <- m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema
              Ops.passResume <$> Ops.refreshGroupsForQueue schemaName (HL.queueTable @payload @m) 1 cursor
          emptyOut :: Text -> IO ()
emptyOut Text
key = do
            Just job <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
key (Text -> payload
mkMessage Text
key)))
            deleteRowDirectly env (primaryKey job)
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
live ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
key -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
key (Text -> payload
mkMessage Text
key)))
      Text -> IO ()
emptyOut Text
low
      Text -> IO ()
emptyOut Text
high
      env -> Text -> IO (Maybe Int32)
groupCount env
env Text
low IO (Maybe Int32) -> Maybe Int32 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
0
      env -> Text -> IO (Maybe Int32)
groupCount env
env Text
high IO (Maybe Int32) -> Maybe Int32 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
0

      -- One emptied key per pass. The first drains the low one and stops there.
      afterFirst <- Maybe GroupsCursor -> IO (Maybe GroupsCursor)
pass Maybe GroupsCursor
forall a. Maybe a
Nothing
      (afterFirst >>= Ops.groupsEmptiedFrom) `shouldBe` Just low
      groupCount env low `shouldReturn` Nothing
      groupCount env high `shouldReturn` Just 0

      -- The low key empties again. The scan resumes above it.
      emptyOut low
      void (pass afterFirst)
      groupCount env high `shouldReturn` Nothing
      groupCount env low `shouldReturn` Just 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"repairs a tail group only once the cursor reaches it" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let keys :: [Text]
keys = [Text
"grp-pass-1", Text
"grp-pass-2", Text
"grp-pass-3", Text
"grp-pass-4", Text
"grp-pass-5"]
          tailKey :: Text
tailKey = [Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
keys
          pass :: Maybe GroupsCursor -> IO (Maybe GroupsCursor)
pass Maybe GroupsCursor
cursor =
            env -> m (Maybe GroupsCursor) -> IO (Maybe GroupsCursor)
forall a. env -> m a -> IO a
runM env
env (m (Maybe GroupsCursor) -> IO (Maybe GroupsCursor))
-> m (Maybe GroupsCursor) -> IO (Maybe GroupsCursor)
forall a b. (a -> b) -> a -> b
$ do
              schemaName <- m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema
              Ops.passResume <$> Ops.refreshGroupsForQueue schemaName (HL.queueTable @payload @m) 2 cursor
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
keys ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
key -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
key (Text -> payload
mkMessage Text
key)))
      env -> Text -> Int32 -> IO ()
driftGroupCount env
env Text
tailKey Int32
99
      env -> Text -> IO (Maybe Int32)
groupCount env
env Text
tailKey IO (Maybe Int32) -> Maybe Int32 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
99

      -- Two keys per pass. The drifted fifth is out of reach until the third.
      afterFirst <- Maybe GroupsCursor -> IO (Maybe GroupsCursor)
pass Maybe GroupsCursor
forall a. Maybe a
Nothing
      (afterFirst >>= Ops.groupsWindowFrom) `shouldBe` Just "grp-pass-2"
      groupCount env tailKey `shouldReturn` Just 99

      afterSecond <- pass afterFirst
      (afterSecond >>= Ops.groupsWindowFrom) `shouldBe` Just "grp-pass-4"
      groupCount env tailKey `shouldReturn` Just 99

      afterThird <- pass afterSecond
      (afterThird >>= Ops.groupsWindowFrom) `shouldBe` Just tailKey
      groupCount env tailKey `shouldReturn` Just 1

      -- The cycle ends on a pass that finds nothing.
      pass afterThird `shouldReturn` Nothing

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"setVisibilityTimeout" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"extends visibility timeout for retry" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"visibility-extend-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Test")

      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 1

      -- Extend visibility timeout and verify it succeeded
      result1 <- runM env (HL.setVisibilityTimeout 120 (head claimed))
      result1 `shouldBe` 1

      -- The job is still not claimable
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

      -- Set a zeroed visibility timeout and verify it succeeded
      result2 <- runM env (HL.setVisibilityTimeout 0 (head claimed))
      result2 `shouldBe` 1

      -- The job is re-claimable now
      claimed' <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed' `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"supports fractional timeouts" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"fractional-timeout")
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)

      -- Claim with fractional visibility timeout (0.5 seconds)
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
0.5) :: IO [JobRead payload]
      length claimed `shouldBe` 1

      -- Extend with fractional timeout
      result <- runM env (HL.setVisibilityTimeout 0.5 (head claimed))
      result `shouldBe` 1

      -- Wait for it to expire
      threadDelay 600_000

      -- Claimable again
      reclaimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length reclaimed `shouldBe` 1

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ackJobsBatch" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"removes multiple jobs in a single operation" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let jobs :: [JobWrite payload]
jobs = [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (Text -> payload) -> Text -> payload
forall a b. (a -> b) -> a -> b
$ Text
"Job" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)) | Int
index <- [Int
1 .. Int
5 :: Int]]

      IO [JobRead payload] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [JobRead payload] -> IO ()) -> IO [JobRead payload] -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env ([JobWrite payload] -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m [JobRead payload]
HL.insertJobsBatch [JobWrite payload]
jobs)
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
10 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 5

      -- Ack all jobs in batch
      deleted <- runM env (HL.ackJobsBatch claimed)
      length deleted `shouldBe` 5

      -- A second claim gets nothing.
      claimed2 <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"allows next jobs in groups to be claimed after batch ack" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let batch1 :: [JobWrite payload]
batch1 =
            [ Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"batch-ack-test-1") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"First-A")
            , Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"batch-ack-test-2") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"First-B")
            ]
          batch2 :: [JobWrite payload]
batch2 =
            [ Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"batch-ack-test-1") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Second-A")
            , Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"batch-ack-test-2") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Second-B")
            ]

      IO [JobRead payload] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [JobRead payload] -> IO ()) -> IO [JobRead payload] -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env ([JobWrite payload] -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m [JobRead payload]
HL.insertJobsBatch ([JobWrite payload]
batch1 [JobWrite payload] -> [JobWrite payload] -> [JobWrite payload]
forall a. Semigroup a => a -> a -> a
<> [JobWrite payload]
batch2))

      -- Claim first jobs from each group
      claimed1 <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
10 NominalDiffTime
60) :: IO [JobRead payload]
      length claimed1 `shouldBe` 2

      -- Ack them in batch
      acked <- runM env (HL.ackJobsBatch claimed1)
      length acked `shouldBe` 2

      -- The second jobs are claimable now
      claimed2 <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 2

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"setVisibilityTimeoutBatch" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"extends visibility timeout for multiple jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let jobs :: [JobWrite payload]
jobs = [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (Text -> payload) -> Text -> payload
forall a b. (a -> b) -> a -> b
$ Text
"Job" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)) | Int
index <- [Int
1 .. Int
3 :: Int]]

      IO [JobRead payload] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [JobRead payload] -> IO ()) -> IO [JobRead payload] -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env ([JobWrite payload] -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m [JobRead payload]
HL.insertJobsBatch [JobWrite payload]
jobs)
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
10 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 3

      -- Extend visibility for all jobs in batch
      results <- runM env (HL.setVisibilityTimeoutBatch 120 claimed)
      let successes = [() | VisibilityExtended Int64
_ <- [SetVisibilityResult]
results]
      length successes `shouldBe` 3

      -- The jobs are still not claimable
      claimed2 <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

      -- Reset visibility to zero for all
      _ <- runM env (HL.setVisibilityTimeoutBatch 0 claimed)

      -- The jobs are re-claimable now
      claimed' <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed' `shouldBe` 3

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns JobGone for manually acked jobs (not an error)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- A batch handler acks some jobs before the heartbeat fires.
      let jobs :: [JobWrite payload]
jobs = [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (Text -> payload) -> Text -> payload
forall a b. (a -> b) -> a -> b
$ Text
"Job" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)) | Int
index <- [Int
1 .. Int
5 :: Int]]

      IO [JobRead payload] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [JobRead payload] -> IO ()) -> IO [JobRead payload] -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env ([JobWrite payload] -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m [JobRead payload]
HL.insertJobsBatch [JobWrite payload]
jobs)
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
10 NominalDiffTime
60) :: IO [JobRead payload]
      length claimed `shouldBe` 5

      -- Simulate handler manually acking 2 jobs mid-processing
      let (toAck, stillProcessing) = splitAt 2 claimed
      forM_ toAck $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)

      -- Now the heartbeat fires
      results <- runM env (HL.setVisibilityTimeoutBatch 120 claimed)

      -- The 2 acked jobs are JobGone
      let goneJobs = [Int64
jobId | JobGone Int64
jobId <- [SetVisibilityResult]
results]
      length goneJobs `shouldBe` 2

      -- The 3 still-processing jobs are VisibilityExtended
      let successJobs = [Int64
jobId | VisibilityExtended Int64
jobId <- [SetVisibilityResult]
results]
      length successJobs `shouldBe` 3

      -- Verify the IDs match
      sort goneJobs `shouldBe` sort (map primaryKey toAck)
      sort successJobs `shouldBe` sort (map primaryKey stillProcessing)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"leaves a finalizer a DLQ retry re-suspended out of the beat" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Window 1. A woken finalizer whose child comes back from the DLQ is
      -- re-suspended under the claim it still holds.
      Right (parent :| [child]) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SuspendedFinalizer"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SuspendedFinalizerChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      assertSuspended env (primaryKey parent)

      -- The child dies to the DLQ, which wakes the finalizer for its round.
      [claimedChild] <- claimJobs env 1
      primaryKey claimedChild `shouldBe` primaryKey child
      runM env (HL.moveToDLQ "boom" claimedChild) `shouldReturn` 1
      assertNotSuspended env (primaryKey parent)

      [claimedParent] <- claimJobs env 1
      primaryKey claimedParent `shouldBe` primaryKey parent
      void $ runM env (HL.setVisibilityTimeout 0 claimedParent)

      [dlqChild] <- dlqAll env
      Just _ <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey dlqChild))
      assertSuspended env (primaryKey parent)

      runM env (HL.setVisibilityTimeoutBatch 120 [claimedParent])
        >>= (`shouldBe` [JobSuspended (primaryKey parent)])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refuses a flagged job to a lapsed claim carrying the same worker id" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let owner :: UUID
owner = UUID
UUID.nil
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"same-pool-flag")))
      let jobId = JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
inserted
      [stale] <- claimJobsAs env 1 owner
      void $ runM env (HL.setVisibilityTimeout 0 stale)
      [live] <- claimJobsAs env 1 owner
      claimSeq live `shouldBe` claimSeq stale + 1
      runM env (HL.forceCancelJob @payload jobId) `shouldReturn` 1

      runM env (HL.setVisibilityTimeoutBatch 120 [stale])
        >>= (`shouldBe` [JobReclaimed jobId (claimSeq stale) (claimSeq live + 1)])
      runM env (HL.setVisibilityTimeoutBatch 120 [live])
        >>= (`shouldBe` [JobCancelled jobId])

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Handoff windows" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refuses the retry write for a claim that was stolen" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Window 2.
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"window2")))
      [held] <- claimJobsAs env 1 UUID.nil
      void $ runM env (HL.setVisibilityTimeout 0 held)
      [stolen] <- claimJobsAs env 1 (UUID.fromWords 3 3 3 3)
      primaryKey stolen `shouldBe` primaryKey inserted
      claimSeq stolen `shouldNotBe` claimSeq held

      runM env (HL.updateJobForRetry 60 "boom" held) `shouldReturn` 0
      runM env (HL.updateJobForRetry 60 "boom" stolen) `shouldReturn` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"leaves a written retry's backoff alone when a tick lands on it" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Window 2, with the heartbeat as the second actor. The retry releases the
      -- row and keeps its token. The holder tells the two apart.
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"window2-backoff")))
      [held] <- claimJobsAs env 1 UUID.nil
      runM env (HL.updateJobForRetry 3600 "boom" held) `shouldReturn` 1
      backoff <- getJob env (primaryKey inserted)

      runM env (HL.setVisibilityTimeoutBatch 120 [held])
        >>= (`shouldBe` [VisibilityUnchanged (primaryKey inserted)])

      beaten <- getJob env (primaryKey inserted)
      (notVisibleUntil <$> beaten) `shouldBe` (notVisibleUntil <$> backoff)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports a flagged job and a vanished one in the same tick" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Window 4.
      Just flagged <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"window4-flagged")))
      Just vanished <- runM env (HL.insertJob (defaultJob (mkMessage "window4-gone")))
      claimed <- claimJobsAs env 2 UUID.nil
      length claimed `shouldBe` 2

      runM env (HL.forceCancelJob @payload (primaryKey flagged)) `shouldReturn` 1
      runM env (HL.cancelJob @payload (primaryKey vanished)) `shouldReturn` 1

      results <- runM env (HL.setVisibilityTimeoutBatch 120 claimed)
      results `shouldMatchList` [JobCancelled (primaryKey flagged), JobGone (primaryKey vanished)]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"sweeps a flagged job only once its lease lapses" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Window 5.
      let owner :: UUID
owner = UUID
UUID.nil
          reaper :: UUID
reaper = Word32 -> Word32 -> Word32 -> Word32 -> UUID
UUID.fromWords Word32
2 Word32
2 Word32
2 Word32
2
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"window5")))
      let jobId = JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
inserted
      claimed <- claimJobsAs env 1 owner
      length claimed `shouldBe` 1
      runM env (HL.forceCancelJob @payload jobId) `shouldReturn` 1

      deleteCancelledAs env reaper [jobId] >>= (`shouldBe` [])

      -- The flag bumped the token. The lapse is written against the row's.
      Just flaggedRow <- getJob env jobId
      void $ runM env (HL.setVisibilityTimeout 0 flaggedRow)
      deleteCancelledAs env reaper [jobId] >>= (`shouldBe` [jobId])
      assertGone env jobId

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Tree locks" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"locks an orphaned job's own subtree when its parent row is gone" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (root :| [mid, leaf]) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"orphan-root"))
            (JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"orphan-mid")) (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"orphan-leaf")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      lockedFromRoot env [primaryKey leaf] `shouldReturn` 3
      deleteRowDirectly env (primaryKey root)
      lockedFromRoot env [primaryKey mid] `shouldReturn` 2

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Job Deduplication" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"No dedup key allows multiple jobs with same payload" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey Maybe DedupKey
forall a. Maybe a
Nothing (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-always-test" (Text -> payload
mkMessage Text
"Same")
          job2 :: JobWrite payload
job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey Maybe DedupKey
forall a. Maybe a
Nothing (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-always-test" (Text -> payload
mkMessage Text
"Same")

      Just inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      Just inserted2 <- runM env (HL.insertJob job2)

      -- Both jobs are inserted with different ids
      primaryKey inserted1 `shouldNotBe` primaryKey inserted2
      payload inserted1 `shouldBe` mkMessage "Same"
      payload inserted2 `shouldBe` mkMessage "Same"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"IgnoreDuplicate returns Nothing on conflict (grouped and ungrouped)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- groupKey does not participate in dedup. The same key conflicts whether
      -- the jobs are grouped or ungrouped.
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"unique-key-1")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-ignore-test-1" (Text -> payload
mkMessage Text
"First")
          job2 :: JobWrite payload
job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"unique-key-1")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-ignore-test-2" (Text -> payload
mkMessage Text
"Second")

      Just inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      inserted2 <- runM env (HL.insertJob job2)

      -- The second insert returns Nothing.
      inserted2 `shouldBe` Nothing
      payload inserted1 `shouldBe` mkMessage "First"

      -- Same conflict holds for ungrouped jobs sharing a dedup key.
      let ungrouped1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"ungrouped-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Ungrouped1")
          ungrouped2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"ungrouped-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Ungrouped2")

      Just insertedU1 <- runM env (HL.insertJob ungrouped1)
      insertedU2 <- runM env (HL.insertJob ungrouped2)
      insertedU2 `shouldBe` Nothing
      payload insertedU1 `shouldBe` mkMessage "Ungrouped1"
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"IgnoreDuplicate with different keys creates separate jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"key-1")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-diffkey-test-1" (Text -> payload
mkMessage Text
"Job1")
          job2 :: JobWrite payload
job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"key-2")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-diffkey-test-2" (Text -> payload
mkMessage Text
"Job2")

      Just inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      Just inserted2 <- runM env (HL.insertJob job2)

      -- Both are inserted
      primaryKey inserted1 `shouldNotBe` primaryKey inserted2
      payload inserted1 `shouldBe` mkMessage "Job1"
      payload inserted2 `shouldBe` mkMessage "Job2"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ReplaceDuplicate replaces existing job completely" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"replace-key-1"))
              (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
10
              (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-replace-test-1" (Text -> payload
mkMessage Text
"Original")
          job2 :: JobWrite payload
job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"replace-key-1"))
              (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
5
              (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-replace-test-2" (Text -> payload
mkMessage Text
"Replacement")

      Just inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      Just inserted2 <- runM env (HL.insertJob job2)

      -- Same job id.
      primaryKey inserted1 `shouldBe` primaryKey inserted2

      -- Payload and group carry the new values.
      payload inserted2 `shouldBe` mkMessage "Replacement"
      groupKey inserted2 `shouldBe` Just "dedup-replace-test-2"
      priority inserted2 `shouldBe` 5

      -- Attempts are reset
      attempts inserted2 `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ReplaceDuplicate resets job state (attempts, errors)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"reset-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-reset-test-1" (Text -> payload
mkMessage Text
"First")

      Just inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)

      -- Claim and fail the job to increment attempts
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      claimed `shouldNotBe` []
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
      attempts claimedJob `shouldBe` 1

      -- Update with error
      void $ runM env (HL.updateJobForRetry 1 "Test error" claimedJob)

      -- Now insert replacement job
      let job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"reset-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-reset-test-2" (Text -> payload
mkMessage Text
"Replacement")

      Just inserted2 <- runM env (HL.insertJob job2)

      -- The job is replaced with fresh state
      primaryKey inserted1 `shouldBe` primaryKey inserted2
      attempts inserted2 `shouldBe` 0
      lastError inserted2 `shouldBe` Nothing
      payload inserted2 `shouldBe` mkMessage "Replacement"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ReplaceDuplicate returns Nothing when the existing job is actively claimed" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"inflight-test-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$
              Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-inflight-test-1" (Text -> payload
mkMessage Text
"Original")

      Just _inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)

      -- Claim the job (attempts=1, last_error=NULL, not_visible_until > NOW).
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
      attempts claimedJob `shouldBe` 1
      lastError claimedJob `shouldBe` Nothing

      -- A replace while in flight returns Nothing.
      let job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"inflight-test-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$
              Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-inflight-test-2" (Text -> payload
mkMessage Text
"Replacement")

      replaced <- runM env (HL.insertJob job2)
      replaced `shouldBe` Nothing

      -- The original job is preserved unchanged. Make it visible and re-claim it.
      void $ runM env (HL.setVisibilityTimeout 0 claimedJob)
      reclaimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length reclaimed `shouldBe` 1
      primaryKey (head reclaimed) `shouldBe` primaryKey claimedJob
      payload (head reclaimed) `shouldBe` mkMessage "Original"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ReplaceDuplicate returns Nothing for a force-cancel-flagged job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"flagged-test-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$
              Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-flagged-test-1" (Text -> payload
mkMessage Text
"Original")
      Just inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      let jobId = JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
inserted1
      claimed <- claimJobsAs env 1 UUID.nil
      map primaryKey claimed `shouldBe` [jobId]
      runM env (HL.forceCancelJob @payload jobId) `shouldReturn` 1

      -- Lapse the lease. The refusal below is the flag's.
      Just flaggedRow <- getJob env jobId
      void $ runM env (HL.setVisibilityTimeout 0 flaggedRow)

      let job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"flagged-test-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$
              Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-flagged-test-2" (Text -> payload
mkMessage Text
"Replacement")
      runM env (HL.insertJob job2) >>= (`shouldBe` Nothing)

      Just untouched <- getJob env jobId
      payload untouched `shouldBe` mkMessage "Original"
      claimJobs env 1 >>= (`shouldBe` [])

      deleteCancelledAs env UUID.nil [jobId] >>= (`shouldBe` [jobId])
      Just fresh <- runM env (HL.insertJob job2)
      payload fresh `shouldBe` mkMessage "Replacement"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ReplaceDuplicate succeeds when job is in retry backoff (has last_error)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"retry-backoff-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$
              Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-backoff-test-1" (Text -> payload
mkMessage Text
"Original")

      Just inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)

      -- Claim the job
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed

      -- Update for retry (sets last_error and not_visible_until to future)
      rowsUpdated <- runM env (HL.updateJobForRetry 5 "Simulated failure" claimedJob)
      rowsUpdated `shouldBe` 1

      -- The replace succeeds on a job in backoff.
      let job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"retry-backoff-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$
              Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-backoff-test-2" (Text -> payload
mkMessage Text
"Replacement")

      Just replaced <- runM env (HL.insertJob job2)

      -- Same id with fresh state
      primaryKey replaced `shouldBe` primaryKey inserted1
      payload replaced `shouldBe` mkMessage "Replacement"
      attempts replaced `shouldBe` 0
      lastError replaced `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ReplaceDuplicate returns Nothing when a retried job is running its next attempt" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"retry-live-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$
              Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-retry-live-1" (Text -> payload
mkMessage Text
"Original")
      Just _ <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      void $ runM env (HL.updateJobForRetry 0 "Simulated failure" (head claimed))
      reclaimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length reclaimed `shouldBe` 1
      lastError (head reclaimed) `shouldBe` Just "Simulated failure"

      let job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"retry-live-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$
              Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-retry-live-2" (Text -> payload
mkMessage Text
"Replacement")
      replaced <- runM env (HL.insertJob job2)
      replaced `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Dedup key only applies to jobs in queue (not after ack)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"ack-test-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-ack-test-1" (Text -> payload
mkMessage Text
"First")

      Just inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)

      -- Claim and ack the job (removes from queue)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      void $ runM env (HL.ackJob (head claimed))

      -- Insert another job with same dedup key
      let job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"ack-test-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-ack-test-2" (Text -> payload
mkMessage Text
"Second")

      Just inserted2 <- runM env (HL.insertJob job2)

      -- A new job is created.
      primaryKey inserted1 `shouldNotBe` primaryKey inserted2
      payload inserted2 `shouldBe` mkMessage "Second"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Mixed dedup strategies work independently" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let noDedupJob :: JobWrite payload
noDedupJob =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey Maybe DedupKey
forall a. Maybe a
Nothing (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-mixed-test-1" (Text -> payload
mkMessage Text
"NoDedupe")
          ignoreJob1 :: JobWrite payload
ignoreJob1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"ignore-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-mixed-test-2" (Text -> payload
mkMessage Text
"Ignore1")
          ignoreJob2 :: JobWrite payload
ignoreJob2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"ignore-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-mixed-test-3" (Text -> payload
mkMessage Text
"Ignore2")
          replaceJob1 :: JobWrite payload
replaceJob1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"replace-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-mixed-test-4" (Text -> payload
mkMessage Text
"Replace1")
          replaceJob2 :: JobWrite payload
replaceJob2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"replace-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dedup-mixed-test-5" (Text -> payload
mkMessage Text
"Replace2")

      Just noDedup <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
noDedupJob)
      Just ignore1 <- runM env (HL.insertJob ignoreJob1)
      ignore2 <- runM env (HL.insertJob ignoreJob2) -- Returns Nothing
      Just replace1 <- runM env (HL.insertJob replaceJob1)
      Just replace2 <- runM env (HL.insertJob replaceJob2) -- Replaces replace1

      -- No dedup key creates unique job
      payload noDedup `shouldBe` mkMessage "NoDedupe"

      -- IgnoreDuplicate returns Nothing on conflict
      ignore2 `shouldBe` Nothing
      payload ignore1 `shouldBe` mkMessage "Ignore1"

      -- ReplaceDuplicate replaces
      primaryKey replace1 `shouldBe` primaryKey replace2
      payload replace2 `shouldBe` mkMessage "Replace2"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"IgnoreDuplicate and ReplaceDuplicate with same key conflict" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job1 :: JobWrite payload
job1 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"cross-strategy-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"IgnoreFirst")
          job2 :: JobWrite payload
job2 =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"cross-strategy-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"ReplaceSecond")

      Just inserted1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job1)
      Just inserted2 <- runM env (HL.insertJob job2)

      -- ReplaceDuplicate conflicts with the existing key and replaces it
      primaryKey inserted1 `shouldBe` primaryKey inserted2
      payload inserted2 `shouldBe` mkMessage "ReplaceSecond"

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"insertJobsBatch Deduplication" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"batch insert without dedup keys inserts all jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let jobs :: [JobWrite payload]
jobs =
            [ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (Text -> payload) -> Text -> payload
forall a b. (a -> b) -> a -> b
$ Text
"Batch" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index))
            | Int
index <- [Int
1 .. Int
5 :: Int]
            ]

      inserted <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env ([JobWrite payload] -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m [JobRead payload]
HL.insertJobsBatch [JobWrite payload]
jobs)
      length inserted `shouldBe` 5

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"batch insert with IgnoreDuplicate skips conflicts" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Pre-insert a job with a dedup key
      let existingJob :: JobWrite payload
existingJob =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"batch-ignore-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Existing")
      Just _ <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
existingJob)

      -- Batch insert: one conflicting, two new
      let batchJobs =
            [ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"batch-ignore-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Conflict")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"New1")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"New2")
            ]

      inserted <- runM env (HL.insertJobsBatch batchJobs)
      -- The conflicting job is skipped. Only the 2 new ones are returned
      length inserted `shouldBe` 2
      map payload inserted `shouldMatchList` [mkMessage "New1", mkMessage "New2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"batch insert with ReplaceDuplicate replaces existing job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Pre-insert a job with a dedup key
      let existingJob :: JobWrite payload
existingJob =
            Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
10 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-replace-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Original")
      Just original <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
existingJob)

      -- Batch insert with a replacement
      let batchJobs =
            [ Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
5 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-replace-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Replacement")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Other")
            ]

      inserted <- runM env (HL.insertJobsBatch batchJobs)
      length inserted `shouldBe` 2

      -- Find the replaced job (same ID as original)
      let replacedJob = (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
original) [JobRead payload]
inserted
      length replacedJob `shouldBe` 1
      payload (head replacedJob) `shouldBe` mkMessage "Replacement"
      priority (head replacedJob) `shouldBe` 5

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"batch insert with mixed strategies" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Pre-insert two jobs
      let ignoreExisting :: JobWrite payload
ignoreExisting =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"batch-mixed-ignore")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"IgnoreExisting")
          replaceExisting :: JobWrite payload
replaceExisting =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-mixed-replace")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"ReplaceExisting")
      Just _ <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
ignoreExisting)
      Just origReplace <- runM env (HL.insertJob replaceExisting)

      -- Batch: conflict on ignore (skipped), conflict on replace (updated),
      -- plus one job with no dedup key (always inserted)
      let batchJobs =
            [ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"batch-mixed-ignore")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"IgnoreConflict")
            , Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-mixed-replace")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"ReplaceConflict")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NoDedupJob")
            ]

      inserted <- runM env (HL.insertJobsBatch batchJobs)
      -- IgnoreDuplicate skipped, ReplaceDuplicate replaced, no-dedup inserted
      length inserted `shouldBe` 2
      map payload inserted `shouldMatchList` [mkMessage "ReplaceConflict", mkMessage "NoDedupJob"]

      -- Verify the replacement happened on the same row
      let replacedJob = (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
origReplace) [JobRead payload]
inserted
      length replacedJob `shouldBe` 1
      payload (head replacedJob) `shouldBe` mkMessage "ReplaceConflict"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"batch insert cross-strategy conflict (IgnoreDuplicate then ReplaceDuplicate)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Pre-insert with IgnoreDuplicate
      let existingJob :: JobWrite payload
existingJob =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"batch-cross-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"IgnoreFirst")
      Just original <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
existingJob)

      -- Batch insert with ReplaceDuplicate on the same key
      let batchJobs =
            [ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-cross-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"ReplaceSecond")
            ]

      inserted <- runM env (HL.insertJobsBatch batchJobs)
      -- ReplaceDuplicate replaces the existing IgnoreDuplicate job
      length inserted `shouldBe` 1
      primaryKey (head inserted) `shouldBe` primaryKey original
      payload (head inserted) `shouldBe` mkMessage "ReplaceSecond"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"batch ReplaceDuplicate does not replace in-flight job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert and claim a job, making it actively owned by a worker.
      let existingJob :: JobWrite payload
existingJob =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-inflight-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"InFlight")
      Just _ <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
existingJob)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      -- Job is now in-flight: attempts=1, not_visible_until > NOW, last_error IS NULL

      -- Batch insert with ReplaceDuplicate on the same key
      let batchJobs =
            [ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-inflight-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Replacement")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Other")
            ]

      inserted <- runM env (HL.insertJobsBatch batchJobs)
      -- The in-flight job is kept. Only "Other" is inserted
      length inserted `shouldBe` 1
      payload (head inserted) `shouldBe` mkMessage "Other"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"duplicate IgnoreDuplicate keys within batch: first wins" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let batchJobs :: [JobWrite payload]
batchJobs =
            [ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"ign-ign-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"First")
            , Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"ign-ign-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Second")
            ]

      inserted <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env ([JobWrite payload] -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m [JobRead payload]
HL.insertJobsBatch [JobWrite payload]
batchJobs)
      length inserted `shouldBe` 1
      payload (head inserted) `shouldBe` mkMessage "First"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"duplicate ReplaceDuplicate keys within batch: last wins" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let batchJobs :: [JobWrite payload]
batchJobs =
            [ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"rep-rep-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"First")
            , Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"rep-rep-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Second")
            ]

      inserted <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env ([JobWrite payload] -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m [JobRead payload]
HL.insertJobsBatch [JobWrite payload]
batchJobs)
      length inserted `shouldBe` 1
      payload (head inserted) `shouldBe` mkMessage "Second"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"mixed strategies within batch: ReplaceDuplicate takes precedence" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let batchJobs :: [JobWrite payload]
batchJobs =
            [ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"mixed-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"First")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Middle")
            , Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"mixed-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Last")
            ]

      inserted <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env ([JobWrite payload] -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m [JobRead payload]
HL.insertJobsBatch [JobWrite payload]
batchJobs)
      -- First is dropped. Middle and Last are kept.
      length inserted `shouldBe` 2
      map payload inserted `shouldMatchList` [mkMessage "Middle", mkMessage "Last"]

      let dedupJobs = (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> Maybe DedupKey
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe DedupKey
dedupKey JobRead payload
job Maybe DedupKey -> Maybe DedupKey -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe DedupKey
forall a. Maybe a
Nothing) [JobRead payload]
inserted
      length dedupJobs `shouldBe` 1
      payload (head dedupJobs) `shouldBe` mkMessage "Last"
      dedupKey (head dedupJobs) `shouldBe` Just (ReplaceDuplicate "mixed-key")

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"batch ReplaceDuplicate succeeds when job is in retry backoff" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert, claim, then fail the job (putting it in retry backoff)
      let existingJob :: JobWrite payload
existingJob =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-backoff-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"WillFail")
      Just original <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
existingJob)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      void $ runM env (HL.updateJobForRetry 5 "Simulated failure" (head claimed))

      -- Batch insert with ReplaceDuplicate succeeds on a job in backoff
      let batchJobs =
            [ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-backoff-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"FreshReplacement")
            ]

      inserted <- runM env (HL.insertJobsBatch batchJobs)
      length inserted `shouldBe` 1
      primaryKey (head inserted) `shouldBe` primaryKey original
      payload (head inserted) `shouldBe` mkMessage "FreshReplacement"
      attempts (head inserted) `shouldBe` 0
      lastError (head inserted) `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"batch ReplaceDuplicate does not replace a retried job running its next attempt" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let existingJob :: JobWrite payload
existingJob =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-retry-live-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Original")
      Just _ <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
existingJob)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      void $ runM env (HL.updateJobForRetry 0 "Simulated failure" (head claimed))
      reclaimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length reclaimed `shouldBe` 1

      let batchJobs =
            [ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"batch-retry-live-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Replacement")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Other")
            ]
      inserted <- runM env (HL.insertJobsBatch batchJobs)
      map payload inserted `shouldBe` [mkMessage "Other"]

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"updateJobForRetry" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"updates job with error message and visibility timeout" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"retry-update-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Test")

      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]

      length claimed `shouldBe` 1
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
      attempts claimedJob `shouldBe` 1
      lastError claimedJob `shouldBe` Nothing

      -- Update for retry with error
      retryResult <- runM env (HL.updateJobForRetry 5 "Something went wrong" claimedJob)
      retryResult `shouldBe` 1

      -- The job is not claimable during its backoff.
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

      -- The error message is persisted.
      Just updated <- runM env (HL.getJobById @payload (primaryKey claimedJob))
      lastError updated `shouldBe` Just "Something went wrong"
      attempts updated `shouldBe` 1 -- attempts unchanged by updateJobForRetry
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"clears claimed_by on retry" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"retry-clears-claimed-by")))
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> UUID -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> UUID -> m [JobRead payload]
HL.claimNextVisibleJobsAs Int
1 NominalDiffTime
60 UUID
UUID.nil) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
      claimedBy claimedJob `shouldBe` Just UUID.nil

      void $ runM env (HL.updateJobForRetry 5 "boom" claimedJob)

      Just updated <- runM env (HL.getJobById @payload (primaryKey claimedJob))
      claimedBy updated `shouldBe` Nothing
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not retry a force-cancel-flagged job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"cancel-then-retry")))
      claimed <- runM env (HL.claimNextVisibleJobsAs 1 60 UUID.nil) :: IO [JobRead payload]
      length claimed `shouldBe` 1

      flagged <- runM env (HL.forceCancelJob @payload (primaryKey inserted))
      flagged `shouldBe` 1

      retried <- runM env (HL.updateJobForRetry 5 "boom" (head claimed))
      retried `shouldBe` 0

      getJob env (primaryKey inserted) >>= (`shouldSatisfy` isJust)
  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Dead Letter Queue Operations" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ moves failed job to DLQ and removes from main queue" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dlq-move-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Failed")

      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed

      -- Update the job in the DB to have an error message and make it immediately visible
      void $ runM env (HL.updateJobForRetry 0 "Job failed" claimedJob)

      -- Claim the job again to get the updated state (attempts=2, last_error is now set)
      updatedClaimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length updatedClaimed `shouldBe` 1
      let jobToDLQ = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
updatedClaimed

      -- Move to DLQ with final error message
      rowsAffected <- runM env (HL.moveToDLQ "Final failure" jobToDLQ)
      rowsAffected `shouldBe` 1

      -- The job is out of the main queue
      allJobs <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length allJobs `shouldBe` 0

      -- The job is in the DLQ with the final error message
      dlqJobs <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      length dlqJobs `shouldBe` 1
      let dlqJobSnapshot = DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot ([DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head [DLQJob payload]
dlqJobs)
      payload dlqJobSnapshot `shouldBe` mkMessage "Failed"
      lastError dlqJobSnapshot `shouldBe` Just "Final failure"
      attempts dlqJobSnapshot `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ moves job back to main queue with attempts reset" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dlq-retry-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Retry")

      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      claimed `shouldNotBe` []
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed

      -- Move to DLQ
      void $ runM env (HL.moveToDLQ "Failed" claimedJob)

      -- Get DLQ job
      dlqJobs <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      length dlqJobs `shouldBe` 1

      -- Retry from DLQ
      Just retried <- runM env (HL.retryFromDLQ (DLQ.dlqPrimaryKey (head dlqJobs)))
      attempts retried `shouldBe` 0
      lastError retried `shouldBe` Nothing
      payload retried `shouldBe` mkMessage "Retry"

      -- Claimable from the main queue
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 1
      payload (head claimed2) `shouldBe` mkMessage "Retry"

      -- Removed from the DLQ
      dlqJobs2 <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      length dlqJobs2 `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ advances the claim token, so the pre-DLQ claim cannot ack it" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"dlq-retry-token")))
      claimed <- claimJobs env 1
      claimSeq (head claimed) `shouldBe` 1
      void $ runM env (HL.moveToDLQ "Failed" (head claimed))

      dlqJobs <- dlqAll env
      Just retried <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      claimSeq retried `shouldBe` 2

      runM env (HL.ackJob (head claimed)) `shouldReturn` 0
      getJob env (primaryKey retried) >>= (`shouldSatisfy` isJust)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an exhausted-sweep move refuses a job whose nack restored the attempt" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (JobWrite payload -> m (Maybe (JobRead payload)))
-> JobWrite payload -> m (Maybe (JobRead payload))
forall a b. (a -> b) -> a -> b
$ Maybe Int32 -> JobWrite payload -> JobWrite payload
forall payload. Maybe Int32 -> JobWrite payload -> JobWrite payload
setMaxAttempts (Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
1) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"sweep-nack"))
      claimed <- claimJobsAs env 1 UUID.nil
      map attempts claimed `shouldBe` [1]
      runM env (HL.nackJob (head claimed)) `shouldReturn` 1

      -- Make the job visible. Only the attempt budget can refuse the move.
      runM env (HL.promoteJob @payload (primaryKey inserted)) `shouldReturn` 1

      -- The sweep's snapshot, taken while the job was still out of attempts.
      moved <- runM env $ do
        schemaName <- getSchema
        Ops.moveToDLQFields
          Ops.TakeLocks
          Tmpl.MoveIfExhausted
          schemaName
          (HL.queueTable @payload @m)
          "max attempts exceeded (reaper sweep)"
          (primaryKey inserted)
          (claimSeq (head claimed))
          Nothing
          False
      moved `shouldBe` 0
      dlqAll env >>= (`shouldBe` [])
      getJob env (primaryKey inserted) >>= (`shouldSatisfy` isJust)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ returns Nothing for non-existent DLQ job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Fabricate a DLQ job with a bogus ID
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dlq-phantom") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Phantom")
      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      void $ runM env (HL.moveToDLQ "err" (head claimed))
      dlqJobs <- runM env (HL.listDLQJobs 1 0) :: IO [DLQ.DLQJob payload]
      -- Delete it first, then retry the stale reference
      _ <- runM env (HL.deleteDLQJob @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      result <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      result `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"deleteDLQJob returns 0 for non-existent DLQ job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dlq-ghost") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Ghost")
      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      void $ runM env (HL.moveToDLQ "err" (head claimed))
      dlqJobs <- runM env (HL.listDLQJobs 1 0) :: IO [DLQ.DLQJob payload]
      _ <- runM env (HL.deleteDLQJob @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      -- A second delete returns 0
      deletedAgain <- runM env (HL.deleteDLQJob @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      deletedAgain `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"deleteDLQJob permanently removes job from DLQ" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dlq-delete-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Delete")

      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      claimed `shouldNotBe` []
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed

      -- Move to DLQ
      void $ runM env (HL.moveToDLQ "Delete me" claimedJob)

      -- Verify in DLQ
      dlqJobs <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      length dlqJobs `shouldBe` 1

      -- Delete from DLQ
      deleted <- runM env (HL.deleteDLQJob @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      deleted `shouldBe` 1

      -- Gone
      dlqJobs2 <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      length dlqJobs2 `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"listDLQJobs supports pagination" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert and move 5 jobs to DLQ
      let jobs :: [JobWrite payload]
jobs =
            [ Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"dlq-pagination-test-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index))) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$
                payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (Text
"Job" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)))
            | Int
index <- [Int
1 .. Int
5 :: Int]
            ]

      [JobWrite payload] -> (JobWrite payload -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [JobWrite payload]
jobs ((JobWrite payload -> IO ()) -> IO ())
-> (JobWrite payload -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \JobWrite payload
job -> do
        Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
        claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
        claimed `shouldNotBe` []
        let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
        void $ runM env (HL.moveToDLQ "Failed" claimedJob)

      -- List first 2
      dlqJobs1 <- env -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
2 Int
0) :: IO [DLQ.DLQJob payload]
      length dlqJobs1 `shouldBe` 2

      -- List next 2
      dlqJobs2 <- runM env (HL.listDLQJobs 2 2) :: IO [DLQ.DLQJob payload]
      length dlqJobs2 `shouldBe` 2

      -- List last 1
      dlqJobs3 <- runM env (HL.listDLQJobs 2 4) :: IO [DLQ.DLQJob payload]
      length dlqJobs3 `shouldBe` 1

      -- All pages contain distinct jobs
      let allDlqIds = (DLQJob payload -> Int64) -> [DLQJob payload] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map DLQJob payload -> Int64
forall payload. DLQJob payload -> Int64
DLQ.dlqPrimaryKey ([DLQJob payload]
dlqJobs1 [DLQJob payload] -> [DLQJob payload] -> [DLQJob payload]
forall a. [a] -> [a] -> [a]
++ [DLQJob payload]
dlqJobs2 [DLQJob payload] -> [DLQJob payload] -> [DLQJob payload]
forall a. [a] -> [a] -> [a]
++ [DLQJob payload]
dlqJobs3)
      length allDlqIds `shouldBe` length (nub allDlqIds)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ returns 0 when job already claimed by another worker" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dlq-race-move-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Race")

      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      claimed `shouldNotBe` []
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed

      -- Simulate another worker claiming by making job visible and claiming again
      void $ runM env (HL.setVisibilityTimeout 0 claimedJob)
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 1

      -- Try to DLQ with old attempts value (race lost)
      rowsAffected <- runM env (HL.moveToDLQ "Failed" claimedJob)
      rowsAffected `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"updateJobForRetry returns 0 when job already claimed by another worker" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dlq-race-retry-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Race")

      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      claimed `shouldNotBe` []
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed

      -- Simulate another worker claiming by making job visible and claiming again
      void $ runM env (HL.setVisibilityTimeout 0 claimedJob)
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 1

      -- Try to update for retry with old attempts value (race lost)
      rowsAffected <- runM env (HL.updateJobForRetry 5 "Failed" claimedJob)
      rowsAffected `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ackJob returns 0 when job already claimed by another worker" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job = Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"dlq-race-ack-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Race")

      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      claimed `shouldNotBe` []
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed

      -- Simulate another worker claiming by making job visible and claiming again
      void $ runM env (HL.setVisibilityTimeout 0 claimedJob)
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 1

      -- Try to ack with old attempts value (race lost)
      rowsAffected <- runM env (HL.ackJob claimedJob)
      rowsAffected `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"maxAttempts=2 retries once then moves to DLQ on the second attempt" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: JobWrite payload
job =
            Maybe Int32 -> JobWrite payload -> JobWrite payload
forall payload. Maybe Int32 -> JobWrite payload -> JobWrite payload
setMaxAttempts (Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
2) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"max-attempts-2-test") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MaxAtt2")
      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)

      -- First attempt. The claim brings attempts to 1, below maxAttempts.
      claimed1 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed1 `shouldBe` 1
      let attempt1 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed1
      attempts attempt1 `shouldBe` 1
      -- Zero backoff makes the retry re-claimable at once.
      void $ runM env (HL.updateJobForRetry 0 "fail 1" attempt1)

      -- Second attempt. The claim brings attempts to 2, which reaches maxAttempts.
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 1
      let attempt2 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed2
      attempts attempt2 `shouldBe` 2

      -- This attempt moves the job to the DLQ.
      moved <- runM env (HL.moveToDLQ "fail 2 (exhausted)" attempt2)
      moved `shouldBe` 1

      -- The job is gone from the main queue and sits in the DLQ at attempts=2.
      remaining <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length remaining `shouldBe` 0
      dlqJobs <- dlqAll env
      let dlq = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"MaxAtt2") [DLQJob payload]
dlqJobs
      attempts (DLQ.jobSnapshot dlq) `shouldBe` 2
      lastError (DLQ.jobSnapshot dlq) `shouldBe` Just "fail 2 (exhausted)"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ drops dedup_key so the same key no longer dedups" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- A DLQ'd job carrying an IgnoreDuplicate key.
      let job :: JobWrite payload
job =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"retry-drop-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"RetryDropKey")
      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
job)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      void $ runM env (HL.moveToDLQ "boom" (head claimed))

      dlqJobs <- dlqAll env
      let dlq = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"RetryDropKey") [DLQJob payload]
dlqJobs

      -- Retry restores the job with attempts reset and no dedup_key.
      Just retried <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey dlq))
      dedupKey retried `shouldBe` Nothing

      -- A fresh insert with the original key is not deduped.
      let again =
            Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"retry-drop-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"RetryDropKeyAgain")
      Just insertedAgain <- runM env (HL.insertJob again)
      primaryKey insertedAgain `shouldNotBe` primaryKey retried
      payload insertedAgain `shouldBe` mkMessage "RetryDropKeyAgain"

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Batched Claims (claimNextVisibleJobsBatched)" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    let claimBatched :: env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
batchSize Int
limit = env
-> m [NonEmpty (JobRead payload)]
-> IO [NonEmpty (JobRead payload)]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> NominalDiffTime -> m [NonEmpty (JobRead payload)]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> NominalDiffTime -> m [NonEmpty (JobRead payload)]
HL.claimNextVisibleJobsBatched Int
batchSize Int
limit NominalDiffTime
60)
        claimBatchedFlat :: env -> Int -> Int -> IO [JobRead payload]
claimBatchedFlat env
env Int
batchSize Int
limit = (NonEmpty (JobRead payload) -> [JobRead payload])
-> [NonEmpty (JobRead payload)] -> [JobRead payload]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
NE.toList ([NonEmpty (JobRead payload)] -> [JobRead payload])
-> IO [NonEmpty (JobRead payload)] -> IO [JobRead payload]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
batchSize Int
limit

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"claims multiple jobs from the same group up to batch size" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 5 jobs in the same group
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
5 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-size-test" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Job" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      -- Claim with batch size 3, limit 10
      batches <- env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
3 Int
10 :: IO [NonEmpty (JobRead payload)]

      -- Exactly 1 batch of 3 jobs from batch-size-test
      length batches `shouldBe` 1
      let batch = NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
NE.toList ([NonEmpty (JobRead payload)] -> NonEmpty (JobRead payload)
forall a. HasCallStack => [a] -> a
head [NonEmpty (JobRead payload)]
batches)
      length batch `shouldBe` 3
      forM_ batch $ \JobRead payload
job -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey JobRead payload
job Maybe Text -> Maybe Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"batch-size-test"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"respects batch size limit per group" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 10 jobs in group batch-limit-test-1 and 10 in group batch-limit-test-2
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
10 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index -> do
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-limit-test-1" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"G1-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-limit-test-2" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"G2-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      -- Claim with batch size 3, limit 100
      batches <- env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
3 Int
100 :: IO [NonEmpty (JobRead payload)]

      -- 2 batches of 3 jobs each, one per group
      length batches `shouldBe` 2
      forM_ batches $ \NonEmpty (JobRead payload)
batch -> NonEmpty (JobRead payload) -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty (JobRead payload)
batch Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
3
      let batchGroups = (NonEmpty (JobRead payload) -> Maybe Text)
-> [NonEmpty (JobRead payload)] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (\NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey (NonEmpty (JobRead payload) -> JobRead payload
forall a. NonEmpty a -> a
NE.head NonEmpty (JobRead payload)
batch)) [NonEmpty (JobRead payload)]
batches
      batchGroups `shouldMatchList` [Just "batch-limit-test-1", Just "batch-limit-test-2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"respects overall limit across groups" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 10 jobs each in 5 different groups
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
5 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
groupIndex ->
        [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
10 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
          IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$
            env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM
              env
env
              ( JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob
                  (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"batch-overall-test-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
groupIndex) (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Job" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index)))
              )

      -- Claim with batch size 10, limit 3 batches. The SQL selects 3 groups, up
      -- to 10 jobs each.
      batches <- env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
10 Int
3 :: IO [NonEmpty (JobRead payload)]

      -- Exactly 3 batches, one per group
      length batches `shouldBe` 3
      -- Every batch is grouped
      forM_ batches $ \NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey (NonEmpty (JobRead payload) -> JobRead payload
forall a. NonEmpty a -> a
NE.head NonEmpty (JobRead payload)
batch) Maybe Text -> (Maybe Text -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ungrouped and grouped jobs compete fairly for batch slots" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert ungrouped first (low IDs), then grouped (high IDs)
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
3 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"U" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
2 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"fair-batch-a" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Ga" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
2 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"fair-batch-b" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Gb" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      -- Claim with batchSize=2, limit=3 (3 batch slots)
      -- Slot allocation by FIFO (min_id):
      --   slot 1: ungrouped batch 1 (U1+U2, min_id=1)
      --   slot 2: ungrouped batch 2 (U3, min_id=3)
      --   slot 3: group "a" (Ga1+Ga2, min_id=4)
      -- Group "b" (min_id=6) gets no slot.
      batches <- env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
2 Int
3 :: IO [NonEmpty (JobRead payload)]

      -- 3 batch slots: 2 ungrouped batches + 1 group batch
      length batches `shouldBe` 3
      let ungroupedBatches = (NonEmpty (JobRead payload) -> Bool)
-> [NonEmpty (JobRead payload)] -> [NonEmpty (JobRead payload)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey (NonEmpty (JobRead payload) -> JobRead payload
forall a. NonEmpty a -> a
NE.head NonEmpty (JobRead payload)
batch) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing) [NonEmpty (JobRead payload)]
batches
      let groupedBatches = (NonEmpty (JobRead payload) -> Bool)
-> [NonEmpty (JobRead payload)] -> [NonEmpty (JobRead payload)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey (NonEmpty (JobRead payload) -> JobRead payload
forall a. NonEmpty a -> a
NE.head NonEmpty (JobRead payload)
batch) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
forall a. Maybe a
Nothing) [NonEmpty (JobRead payload)]
batches
      length ungroupedBatches `shouldBe` 2
      length groupedBatches `shouldBe` 1
      -- Ungrouped batches: sizes 2 and 1 (U1+U2, U3)
      sort (map NE.length ungroupedBatches) `shouldBe` [1, 2]
      -- Grouped batch: group "a" with 2 jobs
      NE.length (head groupedBatches) `shouldBe` 2
      groupKey (NE.head (head groupedBatches)) `shouldBe` Just "fair-batch-a"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ranks an ungrouped batch by its head row" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- The oldest ungrouped row carries the worst priority and is not the batch
      -- head. The batch ranks on the head's (priority, id) pair.
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
5 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SlotRankTail")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
0 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"slot-head-rank" (Text -> payload
mkMessage Text
"SlotRankGroup")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
0 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SlotRankHead")))

      -- One slot. The group head has a lower id than the ungrouped head at the
      -- same priority and takes it.
      batches <- env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
2 Int
1 :: IO [NonEmpty (JobRead payload)]
      length batches `shouldBe` 1
      groupKey (NE.head (head batches)) `shouldBe` Just "slot-head-rank"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"respects per-group ordering within groups" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert jobs in batch-hol-test
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-hol-test" (Text -> payload
mkMessage Text
"First")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-hol-test" (Text -> payload
mkMessage Text
"Second")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-hol-test" (Text -> payload
mkMessage Text
"Third")))

      -- Claim batch of 2
      claimed1 <- env -> Int -> Int -> IO [JobRead payload]
claimBatchedFlat env
env Int
2 Int
10 :: IO [JobRead payload]
      length claimed1 `shouldBe` 2
      map payload claimed1 `shouldMatchList` [mkMessage "First", mkMessage "Second"]

      -- The third job is not claimable until the first two are acked.
      claimed2 <- claimBatchedFlat env 2 10 :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

      -- Ack the first two jobs
      forM_ claimed1 $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)

      -- The third job is claimable now
      claimed3 <- claimBatchedFlat env 2 10 :: IO [JobRead payload]
      length claimed3 `shouldBe` 1
      payload (head claimed3) `shouldBe` mkMessage "Third"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"respects priority within batches" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert jobs with different priorities in same group
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
10 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-priority-test" (Text -> payload
mkMessage Text
"Low")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
0 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-priority-test" (Text -> payload
mkMessage Text
"High")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Int32 -> JobWrite payload -> JobWrite payload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority Int32
5 (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-priority-test" (Text -> payload
mkMessage Text
"Med")))

      -- Claim batch of 3
      batches <- env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
3 Int
10 :: IO [NonEmpty (JobRead payload)]

      -- Single batch containing all 3 priority levels
      length batches `shouldBe` 1
      let batch = NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
NE.toList ([NonEmpty (JobRead payload)] -> NonEmpty (JobRead payload)
forall a. HasCallStack => [a] -> a
head [NonEmpty (JobRead payload)]
batches)
      length batch `shouldBe` 3
      forM_ batch $ \JobRead payload
job -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey JobRead payload
job Maybe Text -> Maybe Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"batch-priority-test"
      map priority batch `shouldBe` [0, 5, 10]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"increments attempts for all jobs in batch" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 3 jobs in same group
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
3 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-attempts-test" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Job" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      -- Claim batch
      claimed <- env -> Int -> Int -> IO [JobRead payload]
claimBatchedFlat env
env Int
3 Int
10 :: IO [JobRead payload]
      length claimed `shouldBe` 3

      -- Every job has attempts = 1
      forM_ claimed $ \JobRead payload
job -> JobRead payload -> Int32
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Int32
attempts JobRead payload
job Int32 -> Int32 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int32
1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"blocks group while batch is in-flight" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 10 jobs in same group
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
10 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-block-test" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Job" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      -- Claim first batch of 5
      firstBatch <- env -> Int -> Int -> IO [JobRead payload]
claimBatchedFlat env
env Int
5 Int
10 :: IO [JobRead payload]
      length firstBatch `shouldBe` 5

      -- A claim on the same group while the first batch is in flight gets 0 jobs.
      secondClaim <- claimBatchedFlat env 5 10 :: IO [JobRead payload]
      length secondClaim `shouldBe` 0

      -- Ack the first batch
      forM_ firstBatch $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)

      -- The remaining 5 jobs are claimable now
      thirdClaim <- claimBatchedFlat env 5 10 :: IO [JobRead payload]
      length thirdClaim `shouldBe` 5

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"handles mixed grouped and ungrouped jobs correctly" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Create a more complex scenario
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"U1")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-mixed-test-1" (Text -> payload
mkMessage Text
"G1-1")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-mixed-test-1" (Text -> payload
mkMessage Text
"G1-2")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"U2")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-mixed-test-2" (Text -> payload
mkMessage Text
"G2-1")))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"batch-mixed-test-2" (Text -> payload
mkMessage Text
"G2-2")))

      -- Claim with batch size 2, limit 10
      batches <- env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
2 Int
10 :: IO [NonEmpty (JobRead payload)]

      -- 1 ungrouped batch (U1+U2) + 2 group batches (G1, G2) = 3 batches
      length batches `shouldBe` 3
      let ungroupedBatches = (NonEmpty (JobRead payload) -> Bool)
-> [NonEmpty (JobRead payload)] -> [NonEmpty (JobRead payload)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey (NonEmpty (JobRead payload) -> JobRead payload
forall a. NonEmpty a -> a
NE.head NonEmpty (JobRead payload)
batch) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing) [NonEmpty (JobRead payload)]
batches
      let groupedBatches = (NonEmpty (JobRead payload) -> Bool)
-> [NonEmpty (JobRead payload)] -> [NonEmpty (JobRead payload)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey (NonEmpty (JobRead payload) -> JobRead payload
forall a. NonEmpty a -> a
NE.head NonEmpty (JobRead payload)
batch) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Text
forall a. Maybe a
Nothing) [NonEmpty (JobRead payload)]
batches
      length ungroupedBatches `shouldBe` 1
      NE.length (head ungroupedBatches) `shouldBe` 2
      length groupedBatches `shouldBe` 2
      forM_ groupedBatches $ \NonEmpty (JobRead payload)
batch -> NonEmpty (JobRead payload) -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty (JobRead payload)
batch Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
2
      let batchGroups = [Maybe Text] -> [Maybe Text]
forall a. Ord a => [a] -> [a]
sort ([Maybe Text] -> [Maybe Text]) -> [Maybe Text] -> [Maybe Text]
forall a b. (a -> b) -> a -> b
$ (NonEmpty (JobRead payload) -> Maybe Text)
-> [NonEmpty (JobRead payload)] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (\NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey (NonEmpty (JobRead payload) -> JobRead payload
forall a. NonEmpty a -> a
NE.head NonEmpty (JobRead payload)
batch)) [NonEmpty (JobRead payload)]
groupedBatches
      batchGroups `shouldBe` [Just "batch-mixed-test-1", Just "batch-mixed-test-2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"claims full group batch even when members are separated by ungrouped jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert grouped and ungrouped interleaved. Group members have
      -- non-consecutive ids.
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"spaced-group" (Text -> payload
mkMessage Text
"G1")))
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
3 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"U" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"spaced-group" (Text -> payload
mkMessage Text
"G2")))
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
4 .. Int
6 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"U" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
      IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"spaced-group" (Text -> payload
mkMessage Text
"G3")))

      -- Claim with batch size 3. All 3 group members come out together.
      batches <- env -> Int -> Int -> IO [NonEmpty (JobRead payload)]
claimBatched env
env Int
3 Int
10 :: IO [NonEmpty (JobRead payload)]

      -- 1 group batch (G1+G2+G3) + 2 ungrouped batches (U1-U3, U4-U6) = 3 batches
      length batches `shouldBe` 3
      -- Verify grouped jobs form a single batch of 3
      let groupBatches = (NonEmpty (JobRead payload) -> Bool)
-> [NonEmpty (JobRead payload)] -> [NonEmpty (JobRead payload)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey (NonEmpty (JobRead payload) -> JobRead payload
forall a. NonEmpty a -> a
NE.head NonEmpty (JobRead payload)
batch) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"spaced-group") [NonEmpty (JobRead payload)]
batches
      length groupBatches `shouldBe` 1
      NE.length (head groupBatches) `shouldBe` 3
      map payload (NE.toList (head groupBatches)) `shouldMatchList` [mkMessage "G1", mkMessage "G2", mkMessage "G3"]
      -- Ungrouped jobs form 2 batches of 3
      let ungroupedBatches = (NonEmpty (JobRead payload) -> Bool)
-> [NonEmpty (JobRead payload)] -> [NonEmpty (JobRead payload)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey (NonEmpty (JobRead payload) -> JobRead payload
forall a. NonEmpty a -> a
NE.head NonEmpty (JobRead payload)
batch) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
forall a. Maybe a
Nothing) [NonEmpty (JobRead payload)]
batches
      length ungroupedBatches `shouldBe` 2
      forM_ ungroupedBatches $ \NonEmpty (JobRead payload)
batch -> NonEmpty (JobRead payload) -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty (JobRead payload)
batch Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
3

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"batched mode claims children but not suspended finalizers" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert a rollup tree: finalizer + 2 children
      Right (_parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchExclParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchExclChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchExclChild2"))]
            )

      -- Insert a regular (non-tree) job
      void $ runM env (HL.insertJob (defaultJob (mkMessage "BatchExclRegular")))

      -- Batched claim gets the children and the regular job. The suspended
      -- finalizer stays.
      batches <- claimBatchedFlat env 10 10 :: IO [JobRead payload]
      let claimedPayloads = (JobRead payload -> payload) -> [JobRead payload] -> [payload]
forall a b. (a -> b) -> [a] -> [b]
map JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload [JobRead payload]
batches
      claimedPayloads
        `shouldMatchList` [ mkMessage "BatchExclChild1"
                          , mkMessage "BatchExclChild2"
                          , mkMessage "BatchExclRegular"
                          ]

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Batch Admin Operations" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJobsBatch deletes multiple jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 5 jobs
      insertedJobs <- [Int] -> (Int -> IO (JobRead payload)) -> IO [JobRead payload]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1 .. Int
5 :: Int] ((Int -> IO (JobRead payload)) -> IO [JobRead payload])
-> (Int -> IO (JobRead payload)) -> IO [JobRead payload]
forall a b. (a -> b) -> a -> b
$ \Int
index -> do
        Just job <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Cancel" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
        pure job

      -- Cancel 3 of them
      let idsToCancel = (JobRead payload -> Int64) -> [JobRead payload] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey (Int -> [JobRead payload] -> [JobRead payload]
forall a. Int -> [a] -> [a]
take Int
3 [JobRead payload]
insertedJobs)
      deleted <- runM env (HL.cancelJobsBatch @payload idsToCancel)
      deleted `shouldBe` 3

      -- Verify only 2 remain
      remaining <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length remaining `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJobsBatch returns 0 for empty list" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      deleted <- env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
[Int64] -> m Int64
HL.cancelJobsBatch @payload [])
      deleted `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJobsBatch handles non-existent IDs gracefully" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 2 jobs
      Just job1 <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Keep1")))
      Just job2 <- runM env (HL.insertJob (defaultJob (mkMessage "Keep2")))

      -- Try to cancel with mix of valid and invalid IDs
      let idsToCancel = [JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
job1, Int64
999999, JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
job2, Int64
888888]
      deleted <- runM env (HL.cancelJobsBatch @payload idsToCancel)
      deleted `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancels two batches over the same parents concurrently without deadlocking" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
8 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
round' -> do
        let name :: Text -> payload
name Text
side = Text -> payload
mkMessage (Text
"cancel-lockorder-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
round') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
side)
            tree :: Text -> JobTree payload
tree Text
side =
              JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
name (Text
side Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-parent")))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
name (Text
side Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-x"))) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
name (Text
side Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-y")))])
        Right (_ :| [childAx, childAy]) <- env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree (Text -> JobTree payload
tree Text
"a"))
        Right (_ :| [childBx, childBy]) <- runM env (HL.insertJobTree (tree "b"))
        -- Opposite parent order on each side.
        (left, right) <-
          concurrently
            (runM env (HL.cancelJobsBatch @payload [primaryKey childAx, primaryKey childBy]))
            (runM env (HL.cancelJobsBatch @payload [primaryKey childBx, primaryKey childAy]))
        left `shouldBe` 2
        right `shouldBe` 2
        parents <- claimJobs env 2
        length parents `shouldBe` 2
        runM env (HL.ackJobsBatch parents) >>= ((`shouldBe` 2) . length)
        runM env (HL.listJobs @payload 100 0) >>= (`shouldBe` [])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQBatch moves multiple jobs with individual error messages" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert and claim 3 jobs
      claimedJobs <- [Int] -> (Int -> IO (JobRead payload)) -> IO [JobRead payload]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1 .. Int
3 :: Int] ((Int -> IO (JobRead payload)) -> IO [JobRead payload])
-> (Int -> IO (JobRead payload)) -> IO [JobRead payload]
forall a b. (a -> b) -> a -> b
$ \Int
index -> do
        Just _ <-
          env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM
            env
env
            (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob (Text
"dlq-batch-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)) (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"DLQ" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
        jobs <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
        pure (head jobs)

      -- Move all to DLQ with different error messages
      let jobsWithErrors = [JobRead payload] -> [Text] -> [(JobRead payload, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [JobRead payload]
claimedJobs [Text
"Error 1", Text
"Error 2", Text
"Error 3"]
      moved <- runM env (HL.moveToDLQBatch jobsWithErrors)
      moved `shouldBe` 3

      -- Verify all are in DLQ with correct error messages
      dlqJobs <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      length dlqJobs `shouldBe` 3
      let errors = (DLQJob payload -> Maybe Text) -> [DLQJob payload] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (JobRead payload -> Maybe Text
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Maybe Text
lastError (JobRead payload -> Maybe Text)
-> (DLQJob payload -> JobRead payload)
-> DLQJob payload
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot) [DLQJob payload]
dlqJobs
      sort errors `shouldBe` [Just "Error 1", Just "Error 2", Just "Error 3"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQBatch returns 0 for empty list" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      moved <- env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
JobOperation m payload =>
[(JobRead payload, Text)] -> m Int64
HL.moveToDLQBatch @payload [])
      moved `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQBatch skips jobs with stale attempts (optimistic locking)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert and claim 2 jobs
      Just _ <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"dlq-batch-stale-1" (Text -> payload
mkMessage Text
"Stale1")))
      Just _ <- runM env (HL.insertJob (defaultGroupedJob "dlq-batch-stale-2" (mkMessage "Stale2")))
      claimed <- runM env (HL.claimNextVisibleJobs 2 60) :: IO [JobRead payload]
      length claimed `shouldBe` 2
      [job1, job2] <- pure claimed

      -- Simulate job1 being reclaimed by another worker
      void $ runM env (HL.setVisibilityTimeout 0 job1)
      _ <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]

      -- Move both to the DLQ. job1 has stale attempts and fails, job2 succeeds.
      let jobsWithErrors = [(JobRead payload
job1, Text
"Error 1"), (JobRead payload
job2, Text
"Error 2")]
      moved <- runM env (HL.moveToDLQBatch jobsWithErrors)
      moved `shouldBe` 1

      -- Verify only job2 is in DLQ
      dlqJobs <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      length dlqJobs `shouldBe` 1
      lastError (DLQ.jobSnapshot (head dlqJobs)) `shouldBe` Just "Error 2"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"deleteDLQJobsBatch deletes multiple DLQ jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert, claim, and move 5 jobs to DLQ
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
5 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index -> do
        Just _ <-
          env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM
            env
env
            (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob (Text
"dlq-delete-batch-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)) (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Del" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
        jobs <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
        void $ runM env (HL.moveToDLQ "Failed" (head jobs))

      -- Get DLQ job IDs
      dlqJobs <- env -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
      length dlqJobs `shouldBe` 5

      -- Delete 3 of them
      let idsToDelete = (DLQJob payload -> Int64) -> [DLQJob payload] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map DLQJob payload -> Int64
forall payload. DLQJob payload -> Int64
DLQ.dlqPrimaryKey (Int -> [DLQJob payload] -> [DLQJob payload]
forall a. Int -> [a] -> [a]
take Int
3 [DLQJob payload]
dlqJobs)
      deleted <- runM env (HL.deleteDLQJobsBatch @payload idsToDelete)
      deleted `shouldBe` 3

      -- Verify only 2 remain
      remaining <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      length remaining `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"deleteDLQJobsBatch returns 0 for empty list" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      deleted <- env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
[Int64] -> m Int64
HL.deleteDLQJobsBatch @payload [])
      deleted `shouldBe` 0

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Admin Operations" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"listJobs returns jobs with pagination" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 5 jobs
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
5 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"List" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      -- List first 2
      jobs1 <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [JobRead payload]
HL.listJobs @payload Int
2 Int
0)
      length jobs1 `shouldBe` 2

      -- List next 2
      jobs2 <- runM env (HL.listJobs @payload 2 2)
      length jobs2 `shouldBe` 2

      -- List last 1
      jobs3 <- runM env (HL.listJobs @payload 2 4)
      length jobs3 `shouldBe` 1

      -- All are distinct
      let allIds = (JobRead payload -> Int64) -> [JobRead payload] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey ([JobRead payload]
jobs1 [JobRead payload] -> [JobRead payload] -> [JobRead payload]
forall a. [a] -> [a] -> [a]
++ [JobRead payload]
jobs2 [JobRead payload] -> [JobRead payload] -> [JobRead payload]
forall a. [a] -> [a] -> [a]
++ [JobRead payload]
jobs3)
      length allIds `shouldBe` length (nub allIds)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getJobById returns the job when it exists" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"FindMe")))

      found <- runM env (HL.getJobById @payload (primaryKey inserted))
      found `shouldBe` Just inserted

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getJobById returns Nothing when job doesn't exist" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      found <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.getJobById @payload Int64
999999)
      found `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getJobsByGroup returns jobs filtered by group key" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert jobs in different groups
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
3 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"group-filter-a" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"A" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
2 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"group-filter-b" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"B" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      -- Get only group A
      groupAJobs <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
Text -> Int -> Int -> m [JobRead payload]
HL.getJobsByGroup @payload Text
"group-filter-a" Int
10 Int
0)
      length groupAJobs `shouldBe` 3
      forM_ groupAJobs $ \JobRead payload
job -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey JobRead payload
job Maybe Text -> Maybe Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"group-filter-a"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"promoteJob makes delayed job immediately visible" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert a job, claim it, and put it in retry backoff
      let delayedJob :: JobWrite payload
delayedJob = payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Delayed")
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite payload
delayedJob)

      -- Claim and update for retry (makes it invisible for 60 seconds)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      void $ runM env (HL.updateJobForRetry 60 "Retry later" (head claimed))

      -- The job is not claimable
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

      -- Promote the job
      promoted <- runM env (HL.promoteJob @payload (primaryKey inserted))
      promoted `shouldBe` 1

      -- It is claimable now
      claimed3 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed3 `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getQueueStats returns correct statistics" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 5 jobs
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
5 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$
          env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM
            env
env
            (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob (Text
"stats-test-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)) (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"S" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      -- Check stats before claiming
      stats1 <- env -> m QueueStats -> IO QueueStats
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
m QueueStats
HL.getQueueStats @payload)
      HL.totalJobs stats1 `shouldBe` 5
      HL.readyJobs stats1 `shouldBe` 5
      HL.inFlightJobs stats1 `shouldBe` 0

      -- Claim 2 jobs
      _ <- runM env (HL.claimNextVisibleJobs 2 60) :: IO [JobRead payload]

      -- Check stats after claiming. Claimed jobs are in flight.
      stats2 <- runM env (HL.getQueueStats @payload)
      HL.totalJobs stats2 `shouldBe` 5
      HL.readyJobs stats2 `shouldBe` 3
      HL.inFlightJobs stats2 `shouldBe` 2
      HL.scheduledJobs stats2 `shouldBe` 0
      HL.suspendedJobs stats2 `shouldBe` 0

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Count Operations" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"countJobs returns total job count" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert 4 jobs
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
4 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Count" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      count <- env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *). QueueOperation m payload => m Int64
HL.countJobs @payload)
      count `shouldBe` 4

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"countJobsByGroup returns count for specific group" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert jobs in different groups
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
3 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"count-group-x" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"X" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
      [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
2 :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
index ->
        IO (Maybe (JobRead payload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe (JobRead payload)) -> IO ())
-> IO (Maybe (JobRead payload)) -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"count-group-y" (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Y" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))

      countX <- env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
Text -> m Int64
HL.countJobsByGroup @payload Text
"count-group-x")
      countX `shouldBe` 3

      countY <- runM env (HL.countJobsByGroup @payload "count-group-y")
      countY `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"countDLQJobs returns count of DLQ jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Initially 0 in DLQ
      count0 <- env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *). QueueOperation m payload => m Int64
HL.countDLQJobs @payload)
      count0 `shouldBe` 0

      -- Move 2 jobs to DLQ
      forM_ [1 .. 2 :: Int] $ \Int
index -> do
        Just _ <-
          env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM
            env
env
            (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob (Text
"count-dlq-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)) (Text -> payload
mkMessage (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"DLQ" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index))))
        jobs <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
        void $ runM env (HL.moveToDLQ "Failed" (head jobs))

      -- Now 2 in DLQ
      count2 <- runM env (HL.countDLQJobs @payload)
      count2 `shouldBe` 2

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Job Dependencies" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"no children: normal ack deletes job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert job with no children
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NoChildren")))

      -- Claim and ack
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      rowsAffected <- runM env (HL.ackJob (head claimed))
      rowsAffected `shouldBe` 1

      -- The job is deleted
      found <- runM env (HL.getJobById @payload (primaryKey inserted))
      found `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"pause/resume children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PauseParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PauseChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PauseChild2"))])

      -- Children start unsuspended. Pause them.
      paused <- runM env (HL.pauseChildren @payload (primaryKey parent))
      paused `shouldBe` 2

      -- Children are not claimable
      claimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed `shouldBe` 0

      -- Resume children
      resumed <- runM env (HL.resumeChildren @payload (primaryKey parent))
      resumed `shouldBe` 2

      -- Children are claimable now
      claimed2 <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      let claimedPayloads = (JobRead payload -> payload) -> [JobRead payload] -> [payload]
forall a b. (a -> b) -> [a] -> [b]
map JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload [JobRead payload]
claimed2
      claimedPayloads `shouldContain` [mkMessage "PauseChild1"]
      claimedPayloads `shouldContain` [mkMessage "PauseChild2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"pause/resume children descends through naturally-suspended rollups" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Tree: Grandparent → Parent (rollup) → [Leaf1, Leaf2]
      -- Parent is naturally suspended. pauseChildren on the grandparent pauses
      -- the leaves and leaves Parent alone. resumeChildren on the grandparent
      -- resumes the leaves only.
      Right (grandparent :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NestedGP"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NestedParent"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NestedLeaf1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NestedLeaf2"))])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      let parent = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest

      -- Pause the grandparent's subtree. The leaves are paused.
      paused <- runM env (HL.pauseChildren @payload (primaryKey grandparent))
      paused `shouldBe` 2

      -- Nothing is claimable now.
      noneClaimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length noneClaimed `shouldBe` 0

      -- Parent stays suspended.
      Just parentAfterPause <- runM env (HL.getJobById @payload (primaryKey parent))
      suspended parentAfterPause `shouldBe` True

      -- Resume the grandparent's subtree. The leaves resume and the Parent
      -- rollup stays suspended.
      resumed <- runM env (HL.resumeChildren @payload (primaryKey grandparent))
      resumed `shouldBe` 2

      -- Parent stays suspended.
      Just parentAfterResume <- runM env (HL.getJobById @payload (primaryKey parent))
      suspended parentAfterResume `shouldBe` True

      -- The leaves are claimable.
      claimedLeaves <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      let leafPayloads = (JobRead payload -> payload) -> [JobRead payload] -> [payload]
forall a b. (a -> b) -> [a] -> [b]
map JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload [JobRead payload]
claimedLeaves
      leafPayloads `shouldContain` [mkMessage "NestedLeaf1"]
      leafPayloads `shouldContain` [mkMessage "NestedLeaf2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ on only child wakes parent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      -- Claim the child
      claimedChild <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimedChild `shouldBe` 1

      -- Move the child to the DLQ. The parent wakes.
      void $ runM env (HL.moveToDLQ "Child failed" (head claimedChild))

      -- The parent is resumed
      Just parentResumed <- runM env (HL.getJobById @payload (primaryKey parent))
      suspended parentResumed `shouldBe` False
      (_, childFailures, _, _) <- runM env (HL.readChildResultsRaw @payload (primaryKey parent))
      Map.keys childFailures `shouldBe` [primaryKey (head claimedChild)]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ snapshots the rollup's own child results before the cascade" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SnapshotParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SnapshotChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      [child] <- claimJobs env 1
      void $ runM env (HL.insertResult @payload (primaryKey parent) (primaryKey child) (mkResult "child-done"))
      void $ runM env (HL.ackJob child)

      [claimedParent] <- claimJobs env 1
      primaryKey claimedParent `shouldBe` primaryKey parent
      runM env (HL.moveToDLQ "rollup failed" claimedParent) `shouldReturn` 1

      [dlq] <- dlqAll env
      Just requeued <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey dlq))
      (results, failures, snapshot, _) <- runM env (HL.readChildResultsRaw @payload (primaryKey requeued))
      Map.keys results `shouldBe` []
      Map.keys (HL.mergeRawChildResults results failures snapshot) `shouldBe` [primaryKey child]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"multi-level: grandparent wakes when all descendants complete" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Build: Grandparent → Parent → [Child1, Child2] using nested finalizers
      Right (grandparent :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Grandparent"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Parent"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MLChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MLChild2"))])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      let parent = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest

      -- Only the children are claimable.
      claimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed `shouldBe` 2

      -- Ack child1
      void $ runM env (HL.ackJob (head claimed))
      pStillExists <- runM env (HL.getJobById @payload (primaryKey parent))
      pStillExists `shouldNotBe` Nothing

      -- Ack child2 (last child) → resumes parent for completion round
      void $ runM env (HL.ackJob (claimed !! 1))

      -- The parent is resumed
      Just parentResumed <- runM env (HL.getJobById @payload (primaryKey parent))
      suspended parentResumed `shouldBe` False

      -- Claim and ack parent (completion round) → resumes grandparent
      claimedP <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimedP `shouldBe` 1
      void $ runM env (HL.ackJob (head claimedP))

      pGone <- runM env (HL.getJobById @payload (primaryKey parent))
      pGone `shouldBe` Nothing

      -- The grandparent is resumed
      Just gpResumed <- runM env (HL.getJobById @payload (primaryKey grandparent))
      suspended gpResumed `shouldBe` False

      -- Claim and ack grandparent (completion round)
      claimedGP <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimedGP `shouldBe` 1
      void $ runM env (HL.ackJob (head claimedGP))

      gpGone <- runM env (HL.getJobById @payload (primaryKey grandparent))
      gpGone `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"multi-level: partial completion doesn't wake ancestors" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Build: Grandparent finalizer → [Parent1 finalizer → [C1a], Parent2 finalizer → [C2a]]
      Right (grandparent :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"GPPartial"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"P1Partial"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"C1aPartial")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                       (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"P2Partial"))
                       (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"C2aPartial")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                   ]
            )

      let parent1 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest
          parent2 = [JobRead payload]
rest [JobRead payload] -> Int -> JobRead payload
forall a. HasCallStack => [a] -> Int -> a
!! Int
2 -- parent2 is after parent1 and its child

      -- Only C1a and C2a are claimable
      claimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed `shouldBe` 2

      -- Ack child1a → resumes parent1
      void $ runM env (HL.ackJob (head claimed))

      -- Parent1 is resumed for its completion round. The grandparent still has parent2.
      claimedP1 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimedP1 `shouldBe` 1
      payload (head claimedP1) `shouldBe` mkMessage "P1Partial"
      void $ runM env (HL.ackJob (head claimedP1))

      -- Parent1 is gone. The grandparent still waits.
      p1Gone <- runM env (HL.getJobById @payload (primaryKey parent1))
      p1Gone `shouldBe` Nothing
      gpStill <- runM env (HL.getJobById @payload (primaryKey grandparent))
      gpStill `shouldNotBe` Nothing

      -- Ack child2a → resumes parent2
      void $ runM env (HL.ackJob (claimed !! 1))

      -- Claim and ack parent2 completion round
      claimedP2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimedP2 `shouldBe` 1
      void $ runM env (HL.ackJob (head claimedP2))

      p2Gone <- runM env (HL.getJobById @payload (primaryKey parent2))
      p2Gone `shouldBe` Nothing

      -- The grandparent is resumed now
      claimedGP <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimedGP `shouldBe` 1
      void $ runM env (HL.ackJob (head claimedGP))

      gpGone <- runM env (HL.getJobById @payload (primaryKey grandparent))
      gpGone `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"multi-level: cancel cascade deletes all descendants" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (grandparent :| _rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeGP"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeMLParent"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeMLChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeMLChild2"))])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      -- Cancel cascade from grandparent
      deleted <- runM env (HL.cancelJobCascade @payload (primaryKey grandparent))
      deleted `shouldBe` 4

      -- Nothing remains
      claimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"multi-level: DLQ at leaf wakes parent but not grandparent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (grandparent :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQGrandparent"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQMLParent"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQMLChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      let parent = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest

      -- Claim child, then move to DLQ
      claimedC <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimedC `shouldBe` 1
      void $ runM env (HL.moveToDLQ "Child failed" (head claimedC))

      -- The parent is resumed
      Just pResumed <- runM env (HL.getJobById @payload (primaryKey parent))
      suspended pResumed `shouldBe` False

      -- The grandparent stays suspended while the parent is in the main queue
      Just gpStill <- runM env (HL.getJobById @payload (primaryKey grandparent))
      suspended gpStill `shouldBe` True

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"suspendJob/resumeJob on a standalone job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert an ungrouped job
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SuspendMe")))
      suspended inserted `shouldBe` False

      -- Suspend it
      suspendedRows <- runM env (HL.suspendJob @payload (primaryKey inserted))
      suspendedRows `shouldBe` 1

      -- Not claimable
      claimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed `shouldBe` 0

      -- Verify suspended flag
      Just found <- runM env (HL.getJobById @payload (primaryKey inserted))
      suspended found `shouldBe` True

      -- Resume it
      resumedRows <- runM env (HL.resumeJob @payload (primaryKey inserted))
      resumedRows `shouldBe` 1

      -- Now claimable
      claimed2 <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 1
      payload (head claimed2) `shouldBe` mkMessage "SuspendMe"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"suspendJob on in-flight job is rejected" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"InFlightSuspend")))

      -- Claim the job (makes it in-flight)
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed `shouldBe` 1

      -- Suspend fails with 0 rows.
      suspendedRows <- runM env (HL.suspendJob @payload (primaryKey inserted))
      suspendedRows `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"suspendJob on already-suspended job returns 0" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DoubleSuspend")))
      firstSuspend <- runM env (HL.suspendJob @payload (primaryKey inserted))
      firstSuspend `shouldBe` 1
      secondSuspend <- runM env (HL.suspendJob @payload (primaryKey inserted))
      secondSuspend `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"resumeJob on non-suspended job returns 0" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NotSuspended")))
      resumedRows <- runM env (HL.resumeJob @payload (primaryKey inserted))
      resumedRows `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"insertJob respects notVisibleUntil (delayed job)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      now <- IO UTCTime
getCurrentTime
      let futureTime = UTCTime -> UTCTime
truncateToMicros (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now)
          job = Maybe UTCTime -> JobWrite payload -> JobWrite payload
forall payload.
Maybe UTCTime -> JobWrite payload -> JobWrite payload
setNotVisibleUntil (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
futureTime) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Delayed")
      Just inserted <- runM env (HL.insertJob job)
      notVisibleUntil inserted `shouldBe` Just futureTime

      -- The job is not claimable
      claimed <- claimJobs env 10
      length claimed `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"insertJobsBatch respects notVisibleUntil" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      now <- IO UTCTime
getCurrentTime
      let futureTime = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now
          jobs =
            [ Maybe UTCTime -> JobWrite payload -> JobWrite payload
forall payload.
Maybe UTCTime -> JobWrite payload -> JobWrite payload
setNotVisibleUntil (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
futureTime) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchDelayed1")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchImmediate")
            ]
      inserted <- runM env (HL.insertJobsBatch jobs)
      length inserted `shouldBe` 2

      -- Only the immediate job is claimable
      claimed <- claimJobs env 10
      length claimed `shouldBe` 1
      payload (head claimed) `shouldBe` mkMessage "BatchImmediate"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ preserves parent_id and clears DLQ" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQRetryParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQRetryChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      -- Claim and move child to DLQ
      claimedChild <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimedChild `shouldBe` 1
      void $ runM env (HL.moveToDLQ "Child failed" (head claimedChild))

      -- Retry from DLQ
      dlqJobs <- runM env (HL.listDLQJobs 1 0) :: IO [DLQ.DLQJob payload]
      length dlqJobs `shouldBe` 1
      Just retried <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs)))

      -- parent_id is preserved
      parentId retried `shouldBe` Just (primaryKey parent)

      -- The DLQ is empty
      dlqAfter <- runM env (HL.listDLQJobs 1 0) :: IO [DLQ.DLQJob payload]
      length dlqAfter `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJobCascade on suspended parent with paused children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeSuspParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeSuspChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeSuspChild2"))])

      -- Pause children (makes them suspended)
      _ <- runM env (HL.pauseChildren @payload (primaryKey parent))

      -- Cancel cascade deletes the parent and all suspended children.
      deleted <- runM env (HL.cancelJobCascade @payload (primaryKey parent))
      deleted `shouldBe` 3

      -- Nothing remains
      remaining <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length remaining `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJob on last child wakes suspended parent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelWakeParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelWakeChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      let child = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
children

      assertSuspended env (primaryKey parent)

      -- Cancel the child without cascade. The parent resumes.
      deleted <- runM env (HL.cancelJob @payload (primaryKey child))
      deleted `shouldBe` 1

      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJob on parent with children returns 0 (guard)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelGuardParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelGuardChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      -- cancelJob without cascade refuses to delete a parent with children
      deleted <- runM env (HL.cancelJob @payload (primaryKey parent))
      deleted `shouldBe` 0

      -- Parent and child still exist
      assertSuspended env (primaryKey parent)
      Just childJob <- getJob env (primaryKey (head children))
      payload childJob `shouldBe` mkMessage "CancelGuardChild"

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"insertJobTree" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rollup: parent suspended, children not suspended, children claimable" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let parentJob :: JobWrite payload
parentJob = payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"FanOutParent")
          childJobs :: NonEmpty (JobWrite payload)
childJobs =
            payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"FanOutChild1")
              JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"FanOutChild2")]

      Right (parent :| children) <- env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree (JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup JobWrite payload
parentJob (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (JobWrite payload -> JobTree payload)
-> NonEmpty (JobWrite payload) -> NonEmpty (JobTree payload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (JobWrite payload)
childJobs)))

      -- The parent is suspended
      suspended parent `shouldBe` True
      parentId parent `shouldBe` Nothing

      -- The children are not suspended
      length children `shouldBe` 2
      forM_ children $ \JobRead payload
child -> JobRead payload -> Bool
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Bool
suspended JobRead payload
child Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
False
      forM_ children $ \JobRead payload
child -> JobRead payload -> Maybe Int64
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Maybe Int64
parentId JobRead payload
child Maybe Int64 -> Maybe Int64 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
parent)

      -- Only the children are claimable
      claimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      let claimedPayloads = (JobRead payload -> payload) -> [JobRead payload] -> [payload]
forall a b. (a -> b) -> [a] -> [b]
map JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload [JobRead payload]
claimed
      claimedPayloads `shouldNotContain` [mkMessage "FanOutParent"]
      claimedPayloads `shouldContain` [mkMessage "FanOutChild1"]
      claimedPayloads `shouldContain` [mkMessage "FanOutChild2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns mixed nested trees in pre-order" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let job :: Text -> JobWrite payload
job Text
label = payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
label)
          tree :: JobTree payload
tree =
            JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
              (Text -> JobWrite payload
job Text
"OrderRoot")
              ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (Text -> JobWrite payload
job Text
"OrderLeaf1")
                  JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup (Text -> JobWrite payload
job Text
"OrderNested") (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (Text -> JobWrite payload
job Text
"OrderGrandchild") JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                     , JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (Text -> JobWrite payload
job Text
"OrderLeaf2")
                     ]
              )

      Right inserted <- env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree JobTree payload
tree)
      map payload (NE.toList inserted)
        `shouldBe` map mkMessage ["OrderRoot", "OrderLeaf1", "OrderNested", "OrderGrandchild", "OrderLeaf2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rollup: acking all children resumes parent for completion round" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let parentJob :: JobWrite payload
parentJob = payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"FanOutAckParent")
          childJobs :: NonEmpty (JobWrite payload)
childJobs =
            payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"FanOutAckChild1")
              JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"FanOutAckChild2")]

      Right (parent :| _children) <- env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree (JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup JobWrite payload
parentJob (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (JobWrite payload -> JobTree payload)
-> NonEmpty (JobWrite payload) -> NonEmpty (JobTree payload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (JobWrite payload)
childJobs)))

      -- Claim and ack child 1
      [child1] <- claimJobs env 1
      void $ runM env (HL.ackJob child1)

      -- Claim and ack child 2. The last ack resumes the parent.
      [child2] <- claimJobs env 1
      void $ runM env (HL.ackJob child2)

      assertNotSuspended env (primaryKey parent)

      -- Completion round: claim and ack parent
      [parentJob'] <- claimJobs env 1
      payload parentJob' `shouldBe` mkMessage "FanOutAckParent"
      void $ runM env (HL.ackJob parentJob')

      assertGone env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rollup: parent and children can share group key" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Children can share the parent's group key. Suspended jobs are excluded
      -- from claim queries.
      let parentJob :: JobWrite payload
parentJob = Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"shared-group" (Text -> payload
mkMessage Text
"SharedGKParent")
          childJobs :: NonEmpty (JobWrite payload)
childJobs =
            Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"shared-group" (Text -> payload
mkMessage Text
"SharedGKChild1")
              JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"shared-group" (Text -> payload
mkMessage Text
"SharedGKChild2")]

      Right (parent :| children) <- env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree (JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup JobWrite payload
parentJob (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (JobWrite payload -> JobTree payload)
-> NonEmpty (JobWrite payload) -> NonEmpty (JobTree payload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (JobWrite payload)
childJobs)))

      -- The parent is suspended
      suspended parent `shouldBe` True
      groupKey parent `shouldBe` Just "shared-group"

      -- The children are not suspended and share the group key
      forM_ children $ \JobRead payload
child -> JobRead payload -> Bool
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Bool
suspended JobRead payload
child Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
False
      forM_ children $ \JobRead payload
child -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> Maybe Text
groupKey JobRead payload
child Maybe Text -> Maybe Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"shared-group"

      -- A suspended job does not hold the group. The children are claimable.
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      let claimedPayload = JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload ([JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed)
      -- One of the children is claimed
      claimedPayload `shouldSatisfy` (`elem` [mkMessage "SharedGKChild1", mkMessage "SharedGKChild2"])

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DLQ Child Counts" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"countDLQChildrenBatch returns counts for DLQ'd children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQCountParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQCountChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQCountChild2"))])

      -- Claim and DLQ both children
      claimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed `shouldBe` 2
      void $ runM env (HL.moveToDLQ "fail1" (head claimed))
      void $ runM env (HL.moveToDLQ "fail2" (claimed !! 1))

      -- countDLQChildrenBatch shows 2 DLQ'd children for the parent
      dlqCounts <- runM env (HL.countDLQChildrenBatch @payload [primaryKey parent])
      Map.lookup (primaryKey parent) dlqCounts `shouldBe` Just 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"countDLQChildrenBatch returns empty for non-parents" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just standalone <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQCountStandalone")))
      dlqCounts <- runM env (HL.countDLQChildrenBatch @payload [primaryKey standalone])
      Map.lookup (primaryKey standalone) dlqCounts `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"countDLQChildrenBatch returns empty list for empty input" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      dlqCounts <- env -> m (Map Int64 Int64) -> IO (Map Int64 Int64)
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
[Int64] -> m (Map Int64 Int64)
HL.countDLQChildrenBatch @payload [])
      dlqCounts `shouldBe` Map.empty

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"dlqJobExists returns True for existing DLQ job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just _job <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQExistsJob")))
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      void $ runM env (HL.moveToDLQ "test error" (head claimed))
      dlqJobs <- runM env (HL.listDLQJobs 1 0) :: IO [DLQ.DLQJob payload]
      exists <- runM env (HL.dlqJobExists @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      exists `shouldBe` True

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"dlqJobExists returns False for non-existent DLQ job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      exists <- env -> m Bool -> IO Bool
forall a. env -> m a -> IO a
runM env
env (forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Bool
HL.dlqJobExists @payload Int64
99999)
      exists `shouldBe` False

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ refuses when parent no longer exists" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"OrphanRetryParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"OrphanRetryChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      -- Claim and DLQ the child
      claimedC <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      void $ runM env (HL.moveToDLQ "child failed" (head claimedC))

      -- Cancel (delete) the parent
      void $ runM env (HL.cancelJobCascade @payload (primaryKey parent))

      -- Retry returns Nothing.
      dlqJobs <- runM env (HL.listDLQJobs 1 0) :: IO [DLQ.DLQJob payload]
      length dlqJobs `shouldBe` 1
      result <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      result `shouldBe` Nothing

      -- The DLQ job is still there
      exists <- runM env (HL.dlqJobExists @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      exists `shouldBe` True

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Dependency Bug Fixes" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJobsBatch wakes parent when last child is batch-cancelled" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"TreeCancelParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"TreeCancelChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"TreeCancelChild2"))])

      -- Batch-cancel both children
      let childIds = (JobRead payload -> Int64) -> [JobRead payload] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey [JobRead payload]
children
      deleted <- runM env (HL.cancelJobsBatch @payload childIds)
      deleted `shouldBe` 2

      -- The parent is resumed for its completion round
      Just parentResumed <- runM env (HL.getJobById @payload (primaryKey parent))
      suspended parentResumed `shouldBe` False

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJobCascade on mid-level node wakes grandparent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (grandparent :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeWakeGP"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeWakeMid"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeWakeC1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascadeWakeC2"))])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      let parent = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest

      -- Cancel cascade from the mid-level parent
      deleted <- runM env (HL.cancelJobCascade @payload (primaryKey parent))
      deleted `shouldBe` 3 -- parent + 2 children
      assertNotSuspended env (primaryKey grandparent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ then ack wakes parent (end-to-end DLQ recovery)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQRecoveryParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQRecoveryChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      -- Claim and DLQ the child. The parent wakes.
      [child] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "child failed" child)

      -- Retry from DLQ. The child is re-inserted and the woken rollup parent is
      -- re-suspended.
      dlqJobs <- dlqAll env
      Just retried <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      parentId retried `shouldBe` Just (primaryKey parent)

      -- Only the retried child is claimable. The parent is suspended again.
      Just parentAfterRetry <- runM env (HL.getJobById @payload (primaryKey parent))
      suspended parentAfterRetry `shouldBe` True

      claimed <- claimJobs env 2
      length claimed `shouldBe` 1
      payload (head claimed) `shouldBe` mkMessage "DLQRecoveryChild"

      -- Ack the child. The parent wakes.
      void $ runM env (HL.ackJob (head claimed))
      assertNotSuspended env (primaryKey parent)

      -- Parent is now claimable for its completion round.
      claimedParent <- claimJobs env 1
      length claimedParent `shouldBe` 1
      primaryKey (head claimedParent) `shouldBe` primaryKey parent
      void $ runM env (HL.ackJob (head claimedParent))

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ auto-retries parent from DLQ when retrying child" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"AutoRetryParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"AutoRetryChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"AutoRetryChild2"))]
            )

      -- Claim child1, DLQ it
      [child1] <- claimJobs env 1
      payload child1 `shouldBe` mkMessage "AutoRetryChild1"
      void $ runM env (HL.moveToDLQ "child1 failed" child1)

      -- Claim child2 and ack it. The parent wakes.
      [child2] <- claimJobs env 1
      void $ runM env (HL.ackJob child2)

      -- Claim the woken parent and DLQ it. Both the parent and child1 are in the DLQ.
      [parentClaim] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "parent failed" parentClaim)

      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 2

      -- Retry child1 from the DLQ. The parent is retried too.
      let child1Dlq = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"AutoRetryChild1") [DLQJob payload]
dlqJobs
      Just retriedChild <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey child1Dlq))
      suspended retriedChild `shouldBe` False

      assertSuspended env (primaryKey parent)

      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0

      -- Claim and ack the retried child. The parent wakes.
      [retriedClaim] <- claimJobs env 1
      void $ runM env (HL.ackJob retriedClaim)

      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ auto-retries DLQ'd children when retrying rollup finalizer" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SuspFinParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SuspFinChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SuspFinChild2"))]
            )

      -- Claim both children and DLQ both. The parent wakes.
      claimed <- claimJobs env 2
      length claimed `shouldBe` 2
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (Text -> JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
Text -> JobRead payload -> m Int64
HL.moveToDLQ Text
"child failed" JobRead payload
job)

      -- Claim the woken parent and DLQ it. All three are in the DLQ.
      [parentClaim] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "parent failed" parentClaim)

      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 3

      -- Retry the parent from the DLQ. Both children are retried and the parent comes back suspended.
      let parentDlq = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"SuspFinParent") [DLQJob payload]
dlqJobs
      Just retriedParent <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey parentDlq))
      suspended retriedParent `shouldBe` True

      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0

      -- Claim and ack both children. The parent stays suspended until the last child is acked.
      claimedChildren <- claimJobs env 2
      length claimedChildren `shouldBe` 2
      void $ runM env (HL.ackJob (head claimedChildren))
      assertSuspended env (primaryKey parent)

      void $ runM env (HL.ackJob (claimedChildren !! 1))
      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ auto-retries parent and all siblings when retrying child" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SibRetryParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SibRetryChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SibRetryChild2"))]
            )

      -- Claim both children and DLQ both. The parent wakes.
      claimed <- claimJobs env 2
      length claimed `shouldBe` 2
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (Text -> JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
Text -> JobRead payload -> m Int64
HL.moveToDLQ Text
"child failed" JobRead payload
job)

      -- Claim the woken parent and DLQ it. All three are in the DLQ.
      [parentClaim] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "parent failed" parentClaim)

      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 3

      -- Retry child1 alone. The parent and sibling child2 are retried too.
      let child1Dlq = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"SibRetryChild1") [DLQJob payload]
dlqJobs
      Just retriedChild1 <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey child1Dlq))
      suspended retriedChild1 `shouldBe` False

      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0

      assertSuspended env (primaryKey parent)

      -- Claim and ack both children. The parent wakes.
      claimedChildren <- claimJobs env 2
      length claimedChildren `shouldBe` 2
      forM_ claimedChildren $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)

      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ does not suspend finalizer without DLQ'd children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (_parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NoSuspFinParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NoSuspFinChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      -- Claim the child and ack it. The parent wakes.
      [child] <- claimJobs env 1
      void $ runM env (HL.ackJob child)

      -- Claim the parent and DLQ it.
      [parentClaim] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "parent failed" parentClaim)

      -- Retry the parent from the DLQ. It comes back unsuspended.
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 1
      Just retriedParent <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      suspended retriedParent `shouldBe` False

      -- The parent is claimable at once
      [reclaimed] <- claimJobs env 1
      payload reclaimed `shouldBe` mkMessage "NoSuspFinParent"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ackJobsBatch with finalizer and children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"AckBatchParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"AckBatchChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"AckBatchChild2"))])

      claimedChildren <- claimJobs env 10
      length claimedChildren `shouldBe` 2

      batchResult <- runM env (HL.ackJobsBatch claimedChildren)
      length batchResult `shouldBe` 2

      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ackJobsBatch partial ack leaves the parent suspended" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PartialAckParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PartialChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PartialChild2"))])

      claimedChildren <- claimJobs env 10
      length claimedChildren `shouldBe` 2

      -- Ack only one of the two children. The parent stays suspended.
      acked <- runM env (HL.ackJobsBatch (take 1 claimedChildren))
      length acked `shouldBe` 1

      assertSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"promoteJob on suspended job returns 0" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert a job, then suspend it
      Just inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PromoteSusp")))
      suspendedRows <- runM env (HL.suspendJob @payload (primaryKey inserted))
      suspendedRows `shouldBe` 1

      -- Promote returns 0 on a suspended job.
      promoted <- runM env (HL.promoteJob @payload (primaryKey inserted))
      promoted `shouldBe` 0

      -- The job stays suspended
      Just found <- runM env (HL.getJobById @payload (primaryKey inserted))
      suspended found `shouldBe` True

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"promoteJob leaves a suspended scheduled job's delay alone" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      now <- IO UTCTime
getCurrentTime
      let futureTime = UTCTime -> UTCTime
truncateToMicros (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now)
          job = Maybe UTCTime -> JobWrite payload -> JobWrite payload
forall payload.
Maybe UTCTime -> JobWrite payload -> JobWrite payload
setNotVisibleUntil (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
futureTime) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PromoteSuspSched")
      Just inserted <- runM env (HL.insertJob job)
      runM env (HL.suspendJob @payload (primaryKey inserted)) `shouldReturn` 1
      promoted <- runM env (HL.promoteJob @payload (primaryKey inserted))
      promoted `shouldBe` 0
      Just found <- runM env (HL.getJobById @payload (primaryKey inserted))
      notVisibleUntil found `shouldBe` Just futureTime

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"promoteJob refuses to promote in-flight job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert and claim a job (claiming sets not_visible_until to a future time)
      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PromoteInFlight")))
      claimed <- runM env (HL.claimNextVisibleJobs 1 3600) :: IO [JobRead payload]
      length claimed `shouldBe` 1
      claimed `shouldNotBe` []
      let claimedJob = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed

      -- The job is in flight. Promote returns 0.
      promoted <- runM env (HL.promoteJob @payload (primaryKey claimedJob))
      promoted `shouldBe` 0

      -- The job is still not claimable
      claimed2 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed2 `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"promoteJob refuses to promote a retried job back in flight" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just _inserted <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PromoteRetriedInFlight")))
      [attempt1] <- claimJobsAs env 1 UUID.nil
      void $ runM env (HL.updateJobForRetry 0 "fail 1" attempt1)
      [attempt2] <- claimJobsAs env 1 UUID.nil
      attempts attempt2 `shouldBe` 2

      promotedAgain <- runM env (HL.promoteJob @payload (primaryKey attempt2))
      promotedAgain `shouldBe` 0

      claimed3 <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      length claimed3 `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJobsBatch partial cancel does not wake parent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PartialCancelParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PartialCancelC1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [ JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PartialCancelC2"))
                   , JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PartialCancelC3"))
                   ]
            )

      length children `shouldBe` 3
      let [child1, child2, child3] = children

      -- Cancel 2 of 3 children. The parent stays suspended.
      deleted <- runM env (HL.cancelJobsBatch @payload [primaryKey child1, primaryKey child2])
      deleted `shouldBe` 2
      assertSuspended env (primaryKey parent)

      -- Cancel the last child. The parent resumes.
      deleted2 <- runM env (HL.cancelJobsBatch @payload [primaryKey child3])
      deleted2 `shouldBe` 1
      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ on last main-queue child wakes parent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQDelWakeParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQDelWakeChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQDelWakeChild2"))])

      claimedChildren <- claimJobs env 2
      length claimedChildren `shouldBe` 2
      void $ runM env (HL.ackJob (head claimedChildren))

      -- Move the second child to the DLQ. The parent wakes.
      void $ runM env (HL.moveToDLQ "child2 failed" (claimedChildren !! 1))
      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"delete DLQ'd child when main-queue siblings still exist - parent stays suspended" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQDelNoWakeParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQDelNoWakeC1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [ JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQDelNoWakeC2"))
                   , JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQDelNoWakeC3"))
                   ]
            )

      [child1] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "child1 failed" child1)

      -- Delete the DLQ'd child. The parent stays suspended while child2 and
      -- child3 are in the main queue.
      dlqJobs <- dlqAll env
      deleted <- runM env (HL.deleteDLQJob @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      deleted `shouldBe` 1

      assertSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ on both children wakes parent after last one" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQBatchWakeParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQBatchWakeC1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQBatchWakeC2"))])

      claimedC <- claimJobs env 2
      length claimedC `shouldBe` 2

      -- First moveToDLQ. A sibling is still in the main queue and the parent stays suspended.
      void $ runM env (HL.moveToDLQ "c1 failed" (head claimedC))
      assertSuspended env (primaryKey parent)

      -- Second moveToDLQ. No children remain and the parent wakes.
      void $ runM env (HL.moveToDLQ "c2 failed" (claimedC !! 1))
      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJob on non-last child does NOT wake parent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelNonLastParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelNonLastC1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelNonLastC2"))])

      -- Cancel first child only
      deleted <- runM env (HL.cancelJob @payload (primaryKey (head children)))
      deleted `shouldBe` 1

      assertSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ on child - sibling ack wakes parent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$
          JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQSibAckParent"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQSibAckC1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQSibAckC2"))])
            )

      claimed <- claimJobs env 2
      length claimed `shouldBe` 2

      -- Move the first child to the DLQ. The parent stays suspended.
      void $ runM env (HL.moveToDLQ "child1 failed" (head claimed))
      assertSuspended env (primaryKey parent)

      -- Ack the second child. The parent wakes.
      void $ runM env (HL.ackJob (claimed !! 1))
      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJob on child with DLQ'd sibling wakes parent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert parent + 2 children (rollup)
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$
          JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelDLQSibParent"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelDLQSibC1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CancelDLQSibC2"))])
            )

      -- Claim both children
      claimed <- claimJobs env 2
      length claimed `shouldBe` 2

      -- Move first child to DLQ
      void $ runM env (HL.moveToDLQ "child1 failed" (head claimed))

      -- Cancel the second child. The parent wakes.
      deleted <- runM env (HL.cancelJob @payload (primaryKey (claimed !! 1)))
      deleted `shouldBe` 1

      assertNotSuspended env (primaryKey parent)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ReplaceDuplicate is blocked for parent with children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert a parent with a dedup key + children
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$
          JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"parent-dedup-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DedupParentOrig"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DedupParentChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [])
            )

      -- The replace is blocked while child rows exist.
      let replacement = Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"parent-dedup-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DedupParentReplacement")
      result <- runM env (HL.insertJob replacement)
      result `shouldBe` Nothing

      -- The original parent still exists with its payload
      Just found <- runM env (HL.getJobById @payload (primaryKey parent))
      payload found `shouldBe` mkMessage "DedupParentOrig"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ReplaceDuplicate blocked when child is in DLQ" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert parent + child (rollup: child starts unsuspended)
      Right (_parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$
          JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"dlq-dedup-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DedupDLQParentOrig"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DedupDLQChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [])
            )

      -- Claim and DLQ the child
      [child] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "child failed" child)

      -- The replace is blocked while a DLQ child row exists.
      let replacement = Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"dlq-dedup-key")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DedupDLQParentRepl")
      result <- runM env (HL.insertJob replacement)
      result `shouldBe` Nothing

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"insertJobTree edge cases" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"insertJobTree dedup conflict on root returns Left" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Pre-insert a job with a dedup key
      Just _existing <-
        env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM
          env
env
          (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (JobWrite payload -> m (Maybe (JobRead payload)))
-> JobWrite payload -> m (Maybe (JobRead payload))
forall a b. (a -> b) -> a -> b
$ Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"tree-dedup-root")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"TreeDedupExisting"))

      -- Try to insert a tree whose root has the same dedup key
      let tree =
            JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
              (Maybe DedupKey -> JobWrite payload -> JobWrite payload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
IgnoreDuplicate Text
"tree-dedup-root")) (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"TreeDedupConflict"))
              (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"TreeDedupChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
NE.:| [])
      result <- runM env (HL.insertJobTree tree)
      case result of
        Left Text
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Right NonEmpty (JobRead payload)
_ -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"Expected Left for dedup conflict on root"

      -- The conflicting tree's children are not in the DB
      allJobs <- runM env (HL.listJobs 100 0) :: IO [JobRead payload]
      let orphans = (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"TreeDedupChild") [JobRead payload]
allJobs
      length orphans `shouldBe` 0

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Parent State Aggregation" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"insertResult writes single and multiple child results to results table" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert a tree using rollup (sets isRollup = True)
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"AggParent1"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"AggChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"AggChild2"))]
            )
      let [child1, child2] = children

      -- Verify parent is a rollup
      isRollup parent `shouldBe` True

      -- Single child result upsert returns 1 row
      rowsInserted <-
        runM env $
          HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child1) (Aeson.String "child1-done")
      rowsInserted `shouldBe` 1

      -- A second child upserts independently into its own (parent, child) row
      void $ runM env $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child2) (Aeson.Number 99)

      -- Both results are readable from the results table
      results <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.lookup (primaryKey child1) results `shouldBe` Just (Aeson.String "child1-done")
      Map.lookup (primaryKey child2) results `shouldBe` Just (Aeson.Number 99)

      -- isRollup stays True
      Just updatedParent <- runM env $ HL.getJobById @payload (primaryKey parent)
      isRollup updatedParent `shouldBe` True

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"isRollup is False for regular jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just job <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload)))
-> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"EitherNone"))
      isRollup job `shouldBe` False

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getDLQChildErrorsByParent returns errors for DLQ'd children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQErrParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQErrChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQErrChild2"))]
            )
      let [child1, child2] = children

      -- Claim and DLQ both children with different error messages
      claimed <- claimJobs env 10
      length claimed `shouldBe` 2
      let claimed1 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head ([JobRead payload] -> JobRead payload)
-> [JobRead payload] -> JobRead payload
forall a b. (a -> b) -> a -> b
$ (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
child1) [JobRead payload]
claimed
          claimed2 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head ([JobRead payload] -> JobRead payload)
-> [JobRead payload] -> JobRead payload
forall a b. (a -> b) -> a -> b
$ (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
child2) [JobRead payload]
claimed
      void $ runM env $ HL.moveToDLQ "error-from-child-1" claimed1
      void $ runM env $ HL.moveToDLQ "error-from-child-2" claimed2

      -- getDLQChildErrorsByParent returns both errors
      errors <- runM env $ HL.getDLQChildErrorsByParent @payload (primaryKey parent)
      Map.size errors `shouldBe` 2
      Map.lookup (primaryKey child1) errors `shouldBe` Just "error-from-child-1"
      Map.lookup (primaryKey child2) errors `shouldBe` Just "error-from-child-2"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getDLQChildErrorsByParent maps only DLQ'd children, ignoring live siblings" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQErrMixParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQErrMixChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQErrMixChild2"))]
            )
      let [child1, child2] = children

      -- Before any failure the map is empty.
      emptyMap <- runM env $ HL.getDLQChildErrorsByParent @payload (primaryKey parent)
      emptyMap `shouldBe` Map.empty

      -- DLQ only child1, leaving child2 live in the main queue.
      claimed <- claimJobs env 10
      let claimed1 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head ([JobRead payload] -> JobRead payload)
-> [JobRead payload] -> JobRead payload
forall a b. (a -> b) -> a -> b
$ (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
child1) [JobRead payload]
claimed
      void $ runM env $ HL.moveToDLQ "only-child1-failed" claimed1

      -- The map contains exactly the DLQ'd child.
      errors <- runM env $ HL.getDLQChildErrorsByParent @payload (primaryKey parent)
      Map.size errors `shouldBe` 1
      Map.lookup (primaryKey child1) errors `shouldBe` Just "only-child1-failed"
      Map.lookup (primaryKey child2) errors `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"results table and DLQ errors coexist for mixed outcomes" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MixedParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MixedChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [ JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MixedChild2"))
                   , JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MixedChild3"))
                   ]
            )
      let [child1, _child2, child3] = children

      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child1) (Aeson.String "ok-1")

      claimed <- claimJobs env 10
      let claimed3 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head ([JobRead payload] -> JobRead payload)
-> [JobRead payload] -> JobRead payload
forall a b. (a -> b) -> a -> b
$ (JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\JobRead payload
job -> JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
child3) [JobRead payload]
claimed
      void $ runM env $ HL.moveToDLQ "child3-failed" claimed3

      results <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.lookup (primaryKey child1) results `shouldBe` Just (Aeson.String "ok-1")

      errors <- runM env $ HL.getDLQChildErrorsByParent @payload (primaryKey parent)
      Map.lookup (primaryKey child3) errors `shouldBe` Just "child3-failed"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"results table stores only successful child results" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MergeMixParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MergeMixChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"MergeMixChild2"))]
            )
      let [child1, _child2] = children

      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child1) (Aeson.toJSON (["hello"] :: [Text]))

      results <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size results `shouldBe` 1
      Map.lookup (primaryKey child1) results `shouldBe` Just (Aeson.toJSON (["hello"] :: [Text]))

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"countDLQChildren returns count for parent with DLQ'd children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CountDLQParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CountDLQChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CountDLQChild2"))]
            )
      length children `shouldBe` 2
      -- Claim and DLQ both children
      claimed <- claimJobs env 10
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (m Int64 -> IO Int64) -> m Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$ Text -> JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
Text -> JobRead payload -> m Int64
HL.moveToDLQ Text
"fail" JobRead payload
job
      count <- runM env $ HL.countDLQChildren @payload (primaryKey parent)
      count `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"countDLQChildren returns 0 for parent with no DLQ'd children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CountDLQ0Parent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CountDLQ0Child")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      count <- runM env $ HL.countDLQChildren @payload (primaryKey parent)
      count `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"double DLQ round-trip preserves snapshot" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert tree, store results, ack children, claim parent
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DblDLQParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DblDLQChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DblDLQChild2"))]
            )
      let [child1, child2] = children
      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child1) (Aeson.String "r1")
      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child2) (Aeson.String "r2")
      claimed <- claimJobs env 10
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)
      [parentJob] <- claimJobs env 1

      -- First DLQ round-trip: snapshot results, move to DLQ, retry
      resultMap <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size resultMap `shouldBe` 2
      let merged = (Value -> Either Text Value)
-> Map Int64 Value -> Map Int64 (Either Text Value)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Value -> Either Text Value
forall a b. b -> Either a b
Right Map Int64 Value
resultMap :: Map.Map Int64 (Either Text Aeson.Value)
      void $ runM env $ HL.persistParentState @payload (primaryKey parent) (Aeson.toJSON merged)
      void $ runM env $ HL.moveToDLQ "round-1" parentJob
      dlqJobs1 <- dlqAll env
      let dlq1 = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"DblDLQParent") [DLQJob payload]
dlqJobs1
      Just retried1 <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey dlq1)

      -- The snapshot content survived the first round-trip
      isRollup retried1 `shouldBe` True
      snap1 <- runM env $ HL.getParentStateSnapshot @payload (primaryKey retried1)
      snap1 `shouldBe` Just (Aeson.toJSON merged)

      -- Second DLQ round-trip. The results table is empty and the worker skips
      -- persist. The parent_state column already holds the snapshot from
      -- retryFromDLQ. moveToDLQ copies the full row to the DLQ table.
      [parentJob2] <- claimJobs env 1
      resultMap2 <- runM env $ HL.getResultsByParent @payload (primaryKey parentJob2)
      Map.size resultMap2 `shouldBe` 0
      -- parent_state is already populated from retryFromDLQ
      snap2a <- runM env $ HL.getParentStateSnapshot @payload (primaryKey parentJob2)
      snap2a `shouldBe` Just (Aeson.toJSON merged)
      void $ runM env $ HL.moveToDLQ "round-2" parentJob2
      dlqJobs2 <- dlqAll env
      let dlq2 = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"DblDLQParent") [DLQJob payload]
dlqJobs2
      Just retried2 <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey dlq2)

      -- The snapshot content survived the second round-trip
      isRollup retried2 `shouldBe` True
      snap2b <- runM env $ HL.getParentStateSnapshot @payload (primaryKey retried2)
      snap2b `shouldBe` Just (Aeson.toJSON merged)

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Nested rollup with <~~ operator" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"builds a 3-level tree with correct structure" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      --  root (rollup - aggregates section results)
      --  ├── section-1 (finalizer - waits for its mappers)
      --  │   ├── mapper-1a  (leaf)
      --  │   └── mapper-1b  (leaf)
      --  ├── section-2 (finalizer)
      --  │   ├── mapper-2a  (leaf)
      --  │   └── mapper-2b  (leaf)
      --  └── mapper-solo    (leaf - direct child of root)
      Right allJobs <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"root: compile report"))
          (NonEmpty (JobTree payload) -> JobTree payload)
-> NonEmpty (JobTree payload) -> JobTree payload
forall a b. (a -> b) -> a -> b
$ ( payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"section-1: charts")
                JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-1a") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-1b")])
            )
            JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"section-2: tables")
                   JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-2a") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-2b")])
               , JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-solo"))
               ]

      -- Pre-order: root, section-1, mapper-1a, mapper-1b, section-2, mapper-2a, mapper-2b, mapper-solo
      let jobs = NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (JobRead payload)
allJobs
      length jobs `shouldBe` 8
      let [root, sec1, m1a, m1b, sec2, m2a, m2b, solo] = jobs

      -- Root is a rollup. Suspended with isRollup.
      payload root `shouldBe` mkMessage "root: compile report"
      suspended root `shouldBe` True
      isRollup root `shouldBe` True
      parentId root `shouldBe` Nothing

      -- Section finalizers are suspended, parented to root, rollup enabled
      suspended sec1 `shouldBe` True
      parentId sec1 `shouldBe` Just (primaryKey root)
      isRollup sec1 `shouldBe` True

      suspended sec2 `shouldBe` True
      parentId sec2 `shouldBe` Just (primaryKey root)
      isRollup sec2 `shouldBe` True

      -- Leaf mappers are not suspended, parented to their section
      forM_ [m1a, m1b] $ \JobRead payload
mapper -> do
        JobRead payload -> Bool
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Bool
suspended JobRead payload
mapper Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
False
        JobRead payload -> Maybe Int64
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Maybe Int64
parentId JobRead payload
mapper Maybe Int64 -> Maybe Int64 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
sec1)

      forM_ [m2a, m2b] $ \JobRead payload
mapper -> do
        JobRead payload -> Bool
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Bool
suspended JobRead payload
mapper Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
False
        JobRead payload -> Maybe Int64
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Maybe Int64
parentId JobRead payload
mapper Maybe Int64 -> Maybe Int64 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
sec2)

      -- Solo mapper is not suspended, parented directly to root
      suspended solo `shouldBe` False
      parentId solo `shouldBe` Just (primaryKey root)

      -- Only leaves are claimable (all 5 mappers)
      claimed <- claimJobs env 10
      length claimed `shouldBe` 5
      let claimedPayloads = (JobRead payload -> payload) -> [JobRead payload] -> [payload]
forall a b. (a -> b) -> [a] -> [b]
map JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload [JobRead payload]
claimed
          expectedLeaves = (JobRead payload -> payload) -> [JobRead payload] -> [payload]
forall a b. (a -> b) -> [a] -> [b]
map JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload [JobRead payload
m1a, JobRead payload
m1b, JobRead payload
m2a, JobRead payload
m2b, JobRead payload
solo]
      forM_ expectedLeaves $ \payload
expected -> [payload]
claimedPayloads [payload] -> [payload] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [payload
expected]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rollup aggregates child results in results table" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Rollup: 3 children produce partial word lists stored in results table.
      Right allJobs <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"reducer")
            JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ ( payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-a")
                    JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-b")
                       , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-c")
                       ]
                )
      let [reducer, mapperA, mapperB, mapperC] = NE.toList allJobs

      -- Claim all 3 mappers
      claimed <- claimJobs env 10
      length claimed `shouldBe` 3

      -- Each mapper inserts its partial result
      let insertRes Int64
childId [Text]
result =
            env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (m Int64 -> IO Int64) -> m Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$
              forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> Int64 -> Value -> m Int64
HL.insertResultUnsafe @payload
                (JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
reducer)
                Int64
childId
                ([Text] -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON ([Text]
result :: [Text]))
      void $ insertRes (primaryKey mapperA) ["sales", "growth"]
      void $ insertRes (primaryKey mapperB) ["revenue"]
      void $ insertRes (primaryKey mapperC) ["forecast", "trend"]

      -- Ack all mappers → wakes the reducer
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)

      -- Claim the reducer
      [reducerJob] <- claimJobs env 1
      primaryKey reducerJob `shouldBe` primaryKey reducer

      -- Read results table directly
      resultMap <- runM env $ HL.getResultsByParent @payload (primaryKey reducer)
      Map.size resultMap `shouldBe` 3

      -- Decode and merge.
      let decode Value
value = case Value -> Result [a]
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
value of Aeson.Success [a]
parsed -> [a]
parsed; Result [a]
_ -> []
          merged = (Value -> [Text]) -> [Value] -> [Text]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Value -> [Text]
forall {a}. FromJSON a => Value -> [a]
decode :: Aeson.Value -> [Text]) (Map Int64 Value -> [Value]
forall k a. Map k a -> [a]
Map.elems Map Int64 Value
resultMap)
      length merged `shouldBe` 5
      merged `shouldMatchList` ["sales", "growth", "revenue", "forecast", "trend"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"nested rollup: section finalizers aggregate then root merges" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Two-level rollup:
      --   root (rollup) - merges section results
      --   ├── section-1 (rollup) - merges mapper results
      --   │   ├── mapper-1a  → ["sales", "growth"]
      --   │   └── mapper-1b  → ["revenue"]
      --   └── section-2 (rollup) - merges mapper results
      --       ├── mapper-2a  → ["forecast"]
      --       └── mapper-2b  → ["trend", "outlook"]
      Right allJobs <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"root"))
          (NonEmpty (JobTree payload) -> JobTree payload)
-> NonEmpty (JobTree payload) -> JobTree payload
forall a b. (a -> b) -> a -> b
$ ( payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"section-1")
                JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-1a") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-1b")])
            )
            JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"section-2")
                   JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-2a") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"mapper-2b")])
               ]
      -- Pre-order: root, section-1, mapper-1a, mapper-1b, section-2, mapper-2a, mapper-2b
      let [root, sec1, m1a, m1b, sec2, m2a, m2b] = NE.toList allJobs

      let insertRes Int64
parentPk Int64
childPk [Text]
result =
            env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (m Int64 -> IO Int64) -> m Int64 -> IO Int64
forall a b. (a -> b) -> a -> b
$
              forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> Int64 -> Value -> m Int64
HL.insertResultUnsafe @payload
                Int64
parentPk
                Int64
childPk
                ([Text] -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON ([Text]
result :: [Text]))

      -- Step 1: Claim all 4 leaf mappers
      claimed <- claimJobs env 10
      length claimed `shouldBe` 4

      -- Step 2: Each mapper inserts its partial result into its section's results table
      void $ insertRes (primaryKey sec1) (primaryKey m1a) ["sales", "growth"]
      void $ insertRes (primaryKey sec1) (primaryKey m1b) ["revenue"]
      void $ insertRes (primaryKey sec2) (primaryKey m2a) ["forecast"]
      void $ insertRes (primaryKey sec2) (primaryKey m2b) ["trend", "outlook"]

      -- Step 3: Ack all mappers → wakes both section finalizers
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)

      -- Step 4: Claim both section finalizers
      sections <- claimJobs env 10
      length sections `shouldBe` 2

      let decode Value
value = case Value -> Result [Text]
forall a. FromJSON a => Value -> Result a
Aeson.fromJSON Value
value of Aeson.Success [Text]
parsed -> [Text]
parsed; Result [Text]
_ -> ([] :: [Text])

      -- Step 5: Each section reads its children's results, merges, inserts result to root
      forM_ sections $ \JobRead payload
secJob -> do
        resultMap <- env -> m (Map Int64 Value) -> IO (Map Int64 Value)
forall a. env -> m a -> IO a
runM env
env (m (Map Int64 Value) -> IO (Map Int64 Value))
-> m (Map Int64 Value) -> IO (Map Int64 Value)
forall a b. (a -> b) -> a -> b
$ forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Map Int64 Value)
HL.getResultsByParent @payload (JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
secJob)
        let merged = (Value -> [Text]) -> [Value] -> [Text]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Value -> [Text]
decode (Map Int64 Value -> [Value]
forall k a. Map k a -> [a]
Map.elems Map Int64 Value
resultMap)
        void $ insertRes (primaryKey root) (primaryKey secJob) merged

      -- Step 6: Ack both sections → wakes root
      forM_ sections $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)

      -- Step 7: Claim the root reducer
      [rootJob] <- claimJobs env 1
      primaryKey rootJob `shouldBe` primaryKey root

      -- Step 8: Read root's results table
      rootResultMap <- runM env $ HL.getResultsByParent @payload (primaryKey root)

      -- Root merges section results. All 6 words are present.
      let finalMerged = (Value -> [Text]) -> [Value] -> [Text]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Value -> [Text]
decode (Map Int64 Value -> [Value]
forall k a. Map k a -> [a]
Map.elems Map Int64 Value
rootResultMap)
      length finalMerged `shouldBe` 6
      finalMerged
        `shouldMatchList` ["sales", "growth", "revenue", "forecast", "trend", "outlook"]

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Results Table" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"insertResult encodes the queue's declared result type" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| [child]) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"TypedResultParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"TypedResultChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      rowsInserted <-
        runM env $
          HL.insertResult @payload (primaryKey parent) (primaryKey child) (mkResult "typed")
      rowsInserted `shouldBe` 1

      results <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.lookup (primaryKey child) results `shouldBe` Just (Aeson.toJSON (mkResult "typed"))

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"CASCADE cleanup: acking parent deletes results rows" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert a rollup tree with 2 children
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascChild2"))]
            )
      let [child1, child2] = children

      -- Insert results for both children
      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child1) (Aeson.String "r1")
      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child2) (Aeson.String "r2")

      -- Verify results exist
      results <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size results `shouldBe` 2

      -- Ack both children then the parent
      claimed <- claimJobs env 10
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)
      -- The parent is claimable now
      [parentJob] <- claimJobs env 1
      primaryKey parentJob `shouldBe` primaryKey parent
      void $ runM env (HL.ackJob parentJob)

      -- The results are deleted by FK cascade
      resultsAfter <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size resultsAfter `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"CASCADE cleanup: cancelJobCascade deletes results rows" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascCancelParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascCancelChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      let [child] = children

      -- Insert a result
      void $ runM env $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child) (Aeson.String "r")

      -- Verify result exists
      results <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size results `shouldBe` 1

      -- Cascade cancel the parent (deletes parent + children)
      void $ runM env $ HL.cancelJobCascade @payload (primaryKey parent)

      -- The results are gone
      resultsAfter <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size resultsAfter `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"idempotent upsert: duplicate insertResult overwrites" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"UpsertParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"UpsertChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      let [child] = children

      -- Insert result
      void $ runM env $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child) (Aeson.String "v1")

      -- Insert again with a different value. It overwrites.
      void $ runM env $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child) (Aeson.String "v2")

      -- Verify latest value
      results <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.lookup (primaryKey child) results `shouldBe` Just (Aeson.String "v2")

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rollup finalizer: isRollup is set, results table starts empty" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PlainFinParent")
            JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"PlainFinChild") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      let [child] = children

      isRollup parent `shouldBe` True

      -- Results table starts empty
      results <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size results `shouldBe` 0

      -- Manually inserting works
      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child) (Aeson.String "manual")
      results2 <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size results2 `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DLQ preserves accumulated results via parent_state snapshot" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQSnapParent"))
            ( JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQSnapChild1"))
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQSnapChild2"))]
            )
      let [child1, child2] = children

      -- Insert results for both children
      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child1) (Aeson.String "snap-r1")
      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child2) (Aeson.String "snap-r2")

      -- Ack children to wake the parent
      claimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed `shouldBe` 2
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)

      -- The parent is claimable now
      [parentJob] <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      primaryKey parentJob `shouldBe` primaryKey parent

      -- Simulate a worker. Persist the results snapshot, then move to the DLQ.
      resultMap <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size resultMap `shouldBe` 2
      let mergedSnap = (Value -> Either Text Value)
-> Map Int64 Value -> Map Int64 (Either Text Value)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Value -> Either Text Value
forall a b. b -> Either a b
Right Map Int64 Value
resultMap :: Map.Map Int64 (Either Text Aeson.Value)
      void $ runM env $ HL.persistParentState @payload (primaryKey parent) (Aeson.toJSON mergedSnap)
      void $ runM env $ HL.moveToDLQ "test-failure" parentJob

      -- The results table rows are gone
      resultsAfter <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      Map.size resultsAfter `shouldBe` 0

      -- The DLQ job is still marked as rollup
      dlqJobs <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      let dlqJob = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"DLQSnapParent") [DLQJob payload]
dlqJobs
      isRollup (DLQ.jobSnapshot dlqJob) `shouldBe` True

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DLQ retry preserves parent_state snapshot" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQRetryParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"DLQRetryChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      let [child] = children

      -- Insert result, ack child, claim parent
      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey parent) (primaryKey child) (Aeson.String "retry-val")
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)
      [parentJob] <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]

      -- Persist results and move to DLQ
      resultMap <- runM env $ HL.getResultsByParent @payload (primaryKey parent)
      let mergedSnap = (Value -> Either Text Value)
-> Map Int64 Value -> Map Int64 (Either Text Value)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Value -> Either Text Value
forall a b. b -> Either a b
Right Map Int64 Value
resultMap :: Map.Map Int64 (Either Text Aeson.Value)
      void $ runM env $ HL.persistParentState @payload (primaryKey parent) (Aeson.toJSON mergedSnap)
      void $ runM env $ HL.moveToDLQ "test-err" parentJob

      -- Retry from the DLQ. The snapshot is preserved in the parent_state column.
      dlqJobs <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      let dlqJob = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"DLQRetryParent") [DLQJob payload]
dlqJobs
      Just retried <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey dlqJob)
      isRollup retried `shouldBe` True
      snap <- runM env $ HL.getParentStateSnapshot @payload (primaryKey retried)
      snap `shouldBe` Just (Aeson.toJSON mergedSnap)

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Cascade DLQ for rollup trees" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ on rollup parent cascades children to DLQ" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert rollup tree: parent + 2 children
      Right (parent :| children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascDLQParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascDLQChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascDLQChild2"))])

      -- Parent is suspended (rollup), children are claimable
      assertSuspended env (primaryKey parent)
      length children `shouldBe` 2

      -- moveToDLQ on the parent before the children finish
      void $ runM env (HL.moveToDLQ "Admin DLQ" parent)

      -- All 3 are in the DLQ
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 3

      -- Parent in DLQ with original error
      let parentDLQ = (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"CascDLQParent") [DLQJob payload]
dlqJobs
      length parentDLQ `shouldBe` 1
      lastError (DLQ.jobSnapshot (head parentDLQ)) `shouldBe` Just "Admin DLQ"

      -- Children in DLQ with cascade error
      let childDLQs = (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> payload
mkMessage Text
"CascDLQParent") [DLQJob payload]
dlqJobs
      length childDLQs `shouldBe` 2
      forM_ childDLQs $ \DLQJob payload
candidate ->
        JobRead payload -> Maybe Text
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Maybe Text
lastError (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) Maybe Text -> Maybe Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Parent moved to DLQ"

      -- The main queue is empty
      remaining <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length remaining `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ cascade + retryFromDLQ recovers full tree" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert rollup tree: parent + 2 children
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascRetryParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascRetryChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascRetryChild2"))])

      -- moveToDLQ on parent → all 3 in DLQ
      void $ runM env (HL.moveToDLQ "Admin DLQ" parent)
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 3

      -- retryFromDLQ on parent → entire tree recovered
      let parentDLQ = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"CascRetryParent") [DLQJob payload]
dlqJobs
      Just retried <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey parentDLQ)
      isRollup retried `shouldBe` True
      suspended retried `shouldBe` True

      -- The DLQ is empty now
      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0

      -- The children are claimable
      claimed <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
      length claimed `shouldBe` 2
      map payload claimed `shouldMatchList` [mkMessage "CascRetryChild1", mkMessage "CascRetryChild2"]

      -- Ack children → parent wakes
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)
      assertNotSuspended env (primaryKey retried)

      -- The parent is claimable
      [parentClaimed] <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      payload parentClaimed `shouldBe` mkMessage "CascRetryParent"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ cascade handles multi-level nesting" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Build 3-level tree: grandparent → parent → [child1, child2]
      Right (grandparent :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascGrandparent"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascMidParent"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascGrandChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"CascGrandChild2"))])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      -- grandparent is suspended, mid-parent is suspended, children are claimable
      let midParent = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest
      assertSuspended env (primaryKey grandparent)
      assertSuspended env (primaryKey midParent)

      -- moveToDLQ on grandparent
      void $ runM env (HL.moveToDLQ "Admin cascade" grandparent)

      -- All 4 are in the DLQ
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 4

      -- The main queue is empty
      mainCount <- runM env (HL.countJobs @payload)
      mainCount `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQ on non-rollup job does not cascade" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert a rollup tree, then moveToDLQ a child (non-rollup)
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NoCascParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NoCascChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NoCascChild2"))])

      -- Claim children
      claimed <- runM env (HL.claimNextVisibleJobs 2 60) :: IO [JobRead payload]
      length claimed `shouldBe` 2

      -- moveToDLQ on one child
      let child1 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
      isRollup child1 `shouldBe` False
      void $ runM env (HL.moveToDLQ "child error" child1)

      -- Only that child is in the DLQ
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 1
      payload (DLQ.jobSnapshot (head dlqJobs)) `shouldBe` payload child1

      -- Parent still in main queue (suspended), sibling still in main queue
      assertSuspended env (primaryKey parent)
      mainCount <- runM env (HL.countJobs @payload)
      mainCount `shouldBe` 2 -- parent + remaining child
  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"moveToDLQBatch cascades for rollup parents" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQBatch snapshots a rollup it names alongside its parent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right tree <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchSnapRoot"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchSnapMid"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchSnapLeaf")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )
      let nodeNamed Text
name = (JobRead payload -> Bool)
-> [JobRead payload] -> Maybe (JobRead payload)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
name) (payload -> Bool)
-> (JobRead payload -> payload) -> JobRead payload -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload) (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (JobRead payload)
tree)
      Just root <- pure (nodeNamed "BatchSnapRoot")
      Just mid <- pure (nodeNamed "BatchSnapMid")
      Just leaf <- pure (nodeNamed "BatchSnapLeaf")

      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey mid) (primaryKey leaf) (Aeson.String "batch-snap")
      resultMap <- runM env $ HL.getResultsByParent @payload (primaryKey mid)
      Map.size resultMap `shouldBe` 1

      -- Naming both puts the child's delete in the same statement as the parent's.
      runM env (HL.moveToDLQBatch [(root, "root err"), (mid, "mid err")]) `shouldReturn` 2

      dlqJobs <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
      Just midDlq <- pure (find ((== mkMessage "BatchSnapMid") . payload . DLQ.jobSnapshot) dlqJobs)
      let expected = (Value -> Either Text Value)
-> Map Int64 Value -> Map Int64 (Either Text Value)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Value -> Either Text Value
forall a b. b -> Either a b
Right Map Int64 Value
resultMap :: Map.Map Int64 (Either Text Aeson.Value)
      parentState (DLQ.jobSnapshot midDlq) `shouldBe` Just (Aeson.toJSON expected)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQBatch on rollup parent cascades children to DLQ" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert rollup tree: parent + 2 children (parent is suspended with attempts=0)
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchCascParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchCascChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BatchCascChild2"))])

      -- moveToDLQBatch on the parent
      moved <- runM env (HL.moveToDLQBatch [(parent, "Batch admin DLQ")])
      moved `shouldBe` 1

      -- All 3 are in the DLQ
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 3

      -- The children carry the cascade error message
      let childDLQs = (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> payload
mkMessage Text
"BatchCascParent") [DLQJob payload]
dlqJobs
      length childDLQs `shouldBe` 2
      forM_ childDLQs $ \DLQJob payload
candidate ->
        JobRead payload -> Maybe Text
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Maybe Text
lastError (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) Maybe Text -> Maybe Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Parent moved to DLQ"

      -- The main queue is empty
      mainCount <- runM env (HL.countJobs @payload)
      mainCount `shouldBe` 0

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Intermediate rollup snapshots survive cascade DLQ" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"3-level tree: mid-level rollup snapshot preserved after cascade" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Build 3-level tree: grandparent → mid-parent (rollup) → [child1, child2]
      Right (grandparent :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SnapGrandparent"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SnapMidParent"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SnapChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SnapChild2"))])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      let midParent = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest

      -- Claim and ack one child. The mid-parent gets a partial result.
      claimed <- claimJobs env 2
      length claimed `shouldBe` 2
      let child1 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
      -- Insert a result for child1 under mid-parent, then ack child1
      void
        $ runM env
        $ HL.insertResultUnsafe @payload (primaryKey midParent) (primaryKey child1) (Aeson.String "child1-result")
      void $ runM env (HL.ackJob child1)

      -- Mid-parent still suspended (one child remains)
      assertSuspended env (primaryKey midParent)

      -- Cascade DLQ on the grandparent. The mid-parent's results are snapshotted first.
      void $ runM env (HL.moveToDLQ "Admin cascade" grandparent)

      -- 3 in the DLQ: grandparent, mid-parent, child2.
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 3

      -- Retry the whole tree from grandparent
      let gpDLQ = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"SnapGrandparent") [DLQJob payload]
dlqJobs
      Just retriedGP <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey gpDLQ)

      -- The DLQ is empty. The whole tree is retried.
      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0

      -- The grandparent is suspended
      assertSuspended env (primaryKey retriedGP)

      -- The mid-parent keeps its snapshot with child1's result
      snap <- runM env $ HL.getParentStateSnapshot @payload (primaryKey midParent)
      let expectedSnap = Map Int64 (Either Text Value) -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Int64 -> Either Text Value -> Map Int64 (Either Text Value)
forall k a. k -> a -> Map k a
Map.singleton (JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> key
primaryKey JobRead payload
child1) (Value -> Either Text Value
forall a b. b -> Either a b
Right (Text -> Value
Aeson.String Text
"child1-result") :: Either Text Aeson.Value))
      snap `shouldBe` Just expectedSnap

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"N-level retryFromDLQ" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ from a child retries the entire tree" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Build 2-level tree: parent → [child1, child2]
      Right (_parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NLevelRetryParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NLevelRetryChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NLevelRetryChild2"))])

      -- DLQ the parent (cascades children)
      Just parent' <- runM env $ HL.getJobById @payload (primaryKey _parent)
      void $ runM env (HL.moveToDLQ "Admin" parent')

      -- All in DLQ
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 3

      -- Retry from a child. The whole tree is recovered.
      let child1DLQ = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"NLevelRetryChild1") [DLQJob payload]
dlqJobs
      Just retried <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey child1DLQ)

      -- The returned job is the requested child
      payload retried `shouldBe` mkMessage "NLevelRetryChild1"

      -- The DLQ is empty
      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0

      -- The parent is in the main queue, suspended
      assertSuspended env (primaryKey _parent)

      -- Both children are claimable
      claimed <- claimJobs env 10
      length claimed `shouldBe` 2
      map payload claimed `shouldMatchList` [mkMessage "NLevelRetryChild1", mkMessage "NLevelRetryChild2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ from a grandchild retries the entire 3-level tree" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Build 3-level tree
      Right (grandparent :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"3LRetryGP"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"3LRetryMid"))
                (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"3LRetryLeaf1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"3LRetryLeaf2"))])
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      let midParent = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest

      -- DLQ grandparent → cascades all 4
      void $ runM env (HL.moveToDLQ "Admin" grandparent)
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 4

      -- Retry from a leaf. The entire 3-level tree is recovered.
      let leafDLQ = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"3LRetryLeaf1") [DLQJob payload]
dlqJobs
      Just retried <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey leafDLQ)

      -- The returned job is the leaf
      payload retried `shouldBe` mkMessage "3LRetryLeaf1"

      -- The DLQ is empty
      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0

      -- Grandparent suspended (has mid-parent child)
      assertSuspended env (primaryKey grandparent)
      -- Mid-parent suspended (has leaf children)
      assertSuspended env (primaryKey midParent)

      -- The leaf children are claimable
      claimed <- claimJobs env 10
      length claimed `shouldBe` 2
      map payload claimed `shouldMatchList` [mkMessage "3LRetryLeaf1", mkMessage "3LRetryLeaf2"]

      -- Ack both leaves → mid-parent wakes
      forM_ claimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)
      assertNotSuspended env (primaryKey midParent)

      -- Claim and ack mid-parent → grandparent wakes
      [midClaimed] <- claimJobs env 1
      payload midClaimed `shouldBe` mkMessage "3LRetryMid"
      void $ runM env (HL.ackJob midClaimed)
      assertNotSuspended env (primaryKey grandparent)

      -- The grandparent is claimable
      [gpClaimed] <- claimJobs env 1
      payload gpClaimed `shouldBe` mkMessage "3LRetryGP"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"single child: moveToDLQ cascades and retries correctly" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (parent :| _) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SingleDLQParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"SingleDLQChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

      -- Cascade DLQ the parent
      void $ runM env (HL.moveToDLQ "admin" parent)
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 2

      -- Retry from child
      let childDLQ = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"SingleDLQChild") [DLQJob payload]
dlqJobs
      Just retried <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey childDLQ)
      payload retried `shouldBe` mkMessage "SingleDLQChild"

      -- DLQ empty, parent suspended, child claimable
      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0
      assertSuspended env (primaryKey parent)
      [claimed] <- claimJobs env 1
      payload claimed `shouldBe` mkMessage "SingleDLQChild"

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"retryFromDLQ edge cases" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ on standalone non-rollup job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert a regular job, claim it, DLQ it, retry it
      Just _job <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"StandaloneRetry")))
      [claimed] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "error" claimed)

      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 1

      Just retried <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs))
      payload retried `shouldBe` mkMessage "StandaloneRetry"
      suspended retried `shouldBe` False
      isRollup retried `shouldBe` False

      -- Claimable
      [reClaimed] <- claimJobs env 1
      payload reClaimed `shouldBe` mkMessage "StandaloneRetry"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ on child whose parent is still in main queue" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Tree: parent + 2 children. DLQ one child while the parent is alive.
      -- retryFromDLQ retries that child alone.
      Right (parent :| _children) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"LiveParent"))
            (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"LiveChild1")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"LiveChild2"))])

      -- Claim only 1 child and DLQ it (leave the other unclaimed)
      [child1] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "child fail" child1)

      -- Parent is still in main queue (suspended, other child still exists)
      assertSuspended env (primaryKey parent)

      -- retryFromDLQ on child1. The ancestor walk stops at the live parent.
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 1
      Just retried <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs))
      payload retried `shouldBe` payload child1

      -- DLQ empty, child1 is back in main queue
      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0

      -- Parent still suspended (both children in main queue again)
      assertSuspended env (primaryKey parent)

      -- Claim and ack both children. The parent wakes.
      reClaimed <- claimJobs env 2
      length reClaimed `shouldBe` 2
      forM_ reClaimed $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)
      assertNotSuspended env (primaryKey parent)

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"moveToDLQBatch mixed rollup and non-rollup" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moveToDLQBatch cascades rollup parents but not regular jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Insert standalone first and claim it before tree exists
      Just _standalone <- env -> m (Maybe (JobRead payload)) -> IO (Maybe (JobRead payload))
forall a. env -> m a -> IO a
runM env
env (JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"mix-standalone" (Text -> payload
mkMessage Text
"MixBatchStandalone")))
      [standaloneClaimed] <- claimJobs env 1
      payload standaloneClaimed `shouldBe` mkMessage "MixBatchStandalone"

      -- Now insert the rollup tree
      Right (parent :| _) <-
        runM env
          $ HL.insertJobTree
          $ JT.rollup
            (defaultJob (mkMessage "MixBatchParent"))
            (JT.leaf (defaultJob (mkMessage "MixBatchChild1")) :| [JT.leaf (defaultJob (mkMessage "MixBatchChild2"))])

      -- moveToDLQBatch with both the rollup parent and the standalone job
      moved <- runM env (HL.moveToDLQBatch [(parent, "rollup error"), (standaloneClaimed, "standalone error")])
      moved `shouldBe` 2

      -- The DLQ holds the parent, 2 cascaded children, and the standalone job
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 4

      -- Standalone has its own error
      let standaloneDLQ = (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"MixBatchStandalone") [DLQJob payload]
dlqJobs
      length standaloneDLQ `shouldBe` 1
      lastError (DLQ.jobSnapshot (head standaloneDLQ)) `shouldBe` Just "standalone error"

      -- Children have cascade error
      let childDLQs =
            (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter
              (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> [payload] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text -> payload
mkMessage Text
"MixBatchChild1", Text -> payload
mkMessage Text
"MixBatchChild2"])
              [DLQJob payload]
dlqJobs
      length childDLQs `shouldBe` 2
      forM_ childDLQs $ \DLQJob payload
candidate ->
        JobRead payload -> Maybe Text
forall payload q insertedAt adm.
JobRecord payload Int64 q insertedAt adm -> Maybe Text
lastError (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) Maybe Text -> Maybe Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Parent moved to DLQ"

      -- Main queue empty
      mainCount <- runM env (HL.countJobs @payload)
      mainCount `shouldBe` 0

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"4-level nesting" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"4-level tree: full lifecycle (insert, ack bottom-up, completion cascade)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- L1 (root) → L2 (rollup) → L3 (rollup) → [L4a, L4b]
      Right (level1 :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"L1Root"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"L2Mid"))
                ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                    (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"L3Inner"))
                    (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"L4LeafA")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"L4LeafB"))])
                    JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
                )
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      -- 5 jobs total: L1, L2, L3, L4a, L4b
      length rest `shouldBe` 4

      let level2 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest
          level3 = [JobRead payload]
rest [JobRead payload] -> Int -> JobRead payload
forall a. HasCallStack => [a] -> Int -> a
!! Int
1

      -- All rollup ancestors suspended
      assertSuspended env (primaryKey level1)
      assertSuspended env (primaryKey level2)
      assertSuspended env (primaryKey level3)

      -- Only leaves are claimable
      leaves <- claimJobs env 10
      length leaves `shouldBe` 2
      map payload leaves `shouldMatchList` [mkMessage "L4LeafA", mkMessage "L4LeafB"]

      -- Ack both leaves → L3 wakes
      forM_ leaves $ \JobRead payload
job -> IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ env -> m Int64 -> IO Int64
forall a. env -> m a -> IO a
runM env
env (JobRead payload -> m Int64
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)
      assertNotSuspended env (primaryKey level3)
      assertSuspended env (primaryKey level2)
      assertSuspended env (primaryKey level1)

      -- Claim and ack L3 → L2 wakes
      [l3Claimed] <- claimJobs env 1
      payload l3Claimed `shouldBe` mkMessage "L3Inner"
      void $ runM env (HL.ackJob l3Claimed)
      assertNotSuspended env (primaryKey level2)
      assertSuspended env (primaryKey level1)

      -- Claim and ack L2 → L1 wakes
      [l2Claimed] <- claimJobs env 1
      payload l2Claimed `shouldBe` mkMessage "L2Mid"
      void $ runM env (HL.ackJob l2Claimed)
      assertNotSuspended env (primaryKey level1)

      -- Claim and ack L1 → done
      [l1Claimed] <- claimJobs env 1
      payload l1Claimed `shouldBe` mkMessage "L1Root"
      void $ runM env (HL.ackJob l1Claimed)
      assertGone env (primaryKey level1)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"4-level tree: cascade DLQ from root and retry from deepest leaf" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (level1 :| rest) <-
        env
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a. env -> m a -> IO a
runM env
env
          (m (Either Text (NonEmpty (JobRead payload)))
 -> IO (Either Text (NonEmpty (JobRead payload))))
-> m (Either Text (NonEmpty (JobRead payload)))
-> IO (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree
          (JobTree payload -> m (Either Text (NonEmpty (JobRead payload))))
-> JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
forall a b. (a -> b) -> a -> b
$ JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
            (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"4LDLQRoot"))
            ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"4LDLQMid"))
                ( JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobTree payload) -> JobTree payload
JT.rollup
                    (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"4LDLQInner"))
                    (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"4LDLQLeafA")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"4LDLQLeafB"))])
                    JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
                )
                JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
            )

      let level2 = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
rest
          level3 = [JobRead payload]
rest [JobRead payload] -> Int -> JobRead payload
forall a. HasCallStack => [a] -> Int -> a
!! Int
1

      -- DLQ from root → all 5 in DLQ
      void $ runM env (HL.moveToDLQ "admin" level1)
      dlqJobs <- dlqAll env
      length dlqJobs `shouldBe` 5

      -- Retry from deepest leaf
      let leafDLQ = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (\DLQJob payload
candidate -> JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord payload key q insertedAt adm -> payload
payload (DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot DLQJob payload
candidate) payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"4LDLQLeafA") [DLQJob payload]
dlqJobs
      Just retried <- runM env $ HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey leafDLQ)
      payload retried `shouldBe` mkMessage "4LDLQLeafA"

      -- DLQ empty
      dlqAfter <- dlqAll env
      length dlqAfter `shouldBe` 0

      -- All rollup ancestors suspended
      assertSuspended env (primaryKey level1)
      assertSuspended env (primaryKey level2)
      assertSuspended env (primaryKey level3)

      -- Only leaves claimable
      leaves <- claimJobs env 10
      length leaves `shouldBe` 2
      map payload leaves `shouldMatchList` [mkMessage "4LDLQLeafA", mkMessage "4LDLQLeafB"]