{-# 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.Exceptions (JobGoneException (..), ParsingException (..))
import Arbiter.Core.HighLevel (SetVisibilityResult (..))
import Arbiter.Core.HighLevel qualified as HL
import Arbiter.Core.Job.Archive (archivePrimaryKey)
import Arbiter.Core.Job.Archive qualified as Archive
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 (void)
import Data.Aeson qualified as Aeson
import Data.Foldable (for_, traverse_)
import Data.Int (Int32, Int64)
import Data.List (find, 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.Traversable (for)
import Data.UUID.Types qualified as UUID
import GHC.TypeLits (KnownSymbol)
import Test.Hspec
import UnliftIO.Async (concurrently)

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

-- | Past a 0.5 s lease.
pastHalfSecondLeaseMicros :: Int
pastHalfSecondLeaseMicros :: Int
pastHalfSecondLeaseMicros = Int
600_000

-- | Past a 1 s lease.
pastLeaseMicros :: Int
pastLeaseMicros :: Int
pastLeaseMicros = Int
1_100_000

-- | An id that no job row has.
absentJobId :: Int64
absentJobId :: Int64
absentJobId = Int64
999_999

-- | Build a test suite for the given 'MonadArbiter' runner.
-- Build the schema with 'Arbiter.Test.Setup.setupOnce' and empty it before each test with 'Arbiter.Test.Setup.cleanupData'.
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 test payload. Its 'HasKind' instance must give a label.
  -> (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]
      dlqNamed :: Text -> [DLQJob payload] -> Maybe (DLQJob payload)
dlqNamed Text
name = (DLQJob payload -> Bool)
-> [DLQJob payload] -> Maybe (DLQJob 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)
-> (DLQJob payload -> payload) -> DLQJob payload -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload (JobRead payload -> payload)
-> (DLQJob payload -> JobRead payload) -> DLQJob payload -> payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DLQJob payload -> JobRead payload
forall payload. DLQJob payload -> JobSnapshot payload
DLQ.jobSnapshot)
      claimedFor :: Job payload b q insertedAt adm
-> t (Job payload b q insertedAt adm)
-> Maybe (Job payload b q insertedAt adm)
claimedFor Job payload b q insertedAt adm
job = (Job payload b q insertedAt adm -> Bool)
-> t (Job payload b q insertedAt adm)
-> Maybe (Job payload b q insertedAt adm)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== Job payload b q insertedAt adm -> b
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey Job payload b q insertedAt adm
job) (b -> Bool)
-> (Job payload b q insertedAt adm -> b)
-> Job payload b q insertedAt adm
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Job payload b q insertedAt adm -> b
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey)
      deleteCancelledAs :: env -> UUID -> [JobRead payload] -> IO [Int64]
deleteCancelledAs env
env UUID
owner [JobRead payload]
jobs =
        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) (Ops.HeldBy owner jobs)
      sweepCancelled :: env -> [Int64] -> IO [Int64]
sweepCancelled 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
          Ops.deleteCancelledJobs schemaName (HL.queueTable @payload @m) (Ops.LapsedOnly 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]
      groupColumn :: Text -> env -> Text -> IO (Maybe Int32)
groupColumn Text
column 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 " <> column <> " FROM " <> tbl <> " WHERE group_key = ?") [pval CText key] (col column CInt4)
          pure (listToMaybe rows :: Maybe Int32)
      groupCount :: env -> Text -> IO (Maybe Int32)
groupCount = Text -> env -> Text -> IO (Maybe Int32)
groupColumn Text
"job_count"
      groupHasNextDue :: env -> Text -> IO (Maybe Bool)
groupHasNextDue env
env Text
key =
        env -> m (Maybe Bool) -> IO (Maybe Bool)
forall a. env -> m a -> IO a
runM env
env (m (Maybe Bool) -> IO (Maybe Bool))
-> m (Maybe Bool) -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ do
          tbl <- m Text
groupsTable
          rows <-
            execQuery
              ("SELECT next_due IS NOT NULL AS due FROM " <> tbl <> " WHERE group_key = ?")
              [pval CText key]
              (col "due" CBool)
          pure (listToMaybe rows :: Maybe Bool)
      groupReadyCount :: env -> Text -> IO (Maybe Int32)
groupReadyCount = Text -> env -> Text -> IO (Maybe Int32)
groupColumn Text
"ready_count"

  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
"counts dead letters 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 dead :: payload
dead = Text -> payload
mkMessage Text
"dead-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-dlq-a") (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob payload
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 (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-b") (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob payload
dead)))
      claimed <- env -> Int -> IO [JobRead payload]
claimJobs env
env Int
2
      traverse_ (void . runM env . HL.moveToDLQ "boom") claimed
      Just kind <- pure (kindOf dead)
      stats <- runM env (HL.getQueueStats @payload)
      Map.lookup kind (Ops.dlqKindCounts stats) `shouldBe` Just 2
      Ops.dlqJobs stats `shouldBe` 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
"JobFilter across tables" (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
"matches the main table's id for a job id filter" ((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 (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
"filter-job-id") (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"by-job-id"))))
      matched <- runM env (HL.listJobsFiltered [Ops.FilterJobId (primaryKey inserted)] 10 0) :: IO [JobRead payload]
      map primaryKey matched `shouldBe` [primaryKey inserted]
      counted <- runM env (HL.countJobsFiltered @payload [Ops.FilterJobId (primaryKey inserted)])
      counted `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"matches only parentless jobs for a roots-only filter" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (root :| [_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
"filter-root")) (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
"filter-child")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      Just standalone <- runM env (HL.insertJob (defaultJob (mkMessage "filter-standalone")))
      matched <- runM env (HL.listJobsFiltered [Ops.FilterRootsOnly] 10 0) :: IO [JobRead payload]
      map primaryKey matched `shouldMatchList` [primaryKey root, primaryKey standalone]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"matches nothing for a completion filter on the main table" ((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 (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
"filter-completed") (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"not-completed"))))
      now <- IO UTCTime
getCurrentTime
      let filters = [UTCTime -> JobFilter
Ops.FilterCompletedBefore (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
60 UTCTime
now)]
      listed <- runM env (HL.listJobsFiltered filters 10 0) :: IO [JobRead payload]
      listed `shouldBe` []
      counted <- runM env (HL.countJobsFiltered @payload filters)
      counted `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"matches nothing for a status or completion filter on the DLQ" ((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 (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
"filter-dlq") (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"dead-filtered"))))
      claimed <- env -> Int -> IO [JobRead payload]
claimJobs env
env Int
1
      void $ runM env (HL.moveToDLQ "boom" (head claimed))
      now <- getCurrentTime
      byStatus <- runM env (HL.listDLQFiltered [Ops.FilterStatus Ready] 10 0) :: IO [DLQ.DLQJob payload]
      byStatus `shouldBe` []
      byCompletion <- runM env (HL.countDLQFiltered @payload [Ops.FilterCompletedBefore (addUTCTime 60 now)])
      byCompletion `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"narrows the archive by job id and completion time" ((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 (Maybe Int32 -> JobWrite payload -> JobWrite payload
forall payload. Maybe Int32 -> JobWrite payload -> JobWrite payload
setArchiveFor (Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
dayRetention) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"archive-filtered"))))
      claimed <- claimJobs env 1
      void $ runM env (HL.ackJob (head claimed))
      Just archived <- runM env (HL.getArchiveJobById @payload (primaryKey inserted))
      now <- getCurrentTime
      let byJob = Int64 -> JobFilter
Ops.FilterJobId (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
inserted)
      matched <- runM env (HL.listArchiveFiltered @payload [byJob, Ops.FilterCompletedBefore (addUTCTime 60 now)] 10 0)
      map archivePrimaryKey matched `shouldBe` [archivePrimaryKey archived]
      counted <- runM env (HL.countArchiveFiltered @payload [byJob])
      counted `shouldBe` 1
      later <- runM env (HL.countArchiveFiltered @payload [byJob, Ops.FilterCompletedAfter (addUTCTime 60 now)])
      later `shouldBe` 0
      byStatus <- runM env (HL.countArchiveFiltered @payload [byJob, Ops.FilterStatus Ready])
      byStatus `shouldBe` 0

  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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
1

      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 <- claimJobs env 1

      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
2

      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
1

      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 <- claimJobs env 1
      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
2

      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
3

      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.
Job 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.
Job 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 <- claimJobs env 1
      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
1
      length claimed1 `shouldBe` 1

      -- A second claim gets nothing.
      claimed2 <- claimJobs env 1
      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
1

      length claimed `shouldBe` 1

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

      -- A second claim gets nothing.
      claimed2 <- claimJobs env 1
      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
1
      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 <- claimJobs env 1
      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.
Job 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 claimed >>= (`shouldBe` [])
      getJob env jobId >>= (`shouldSatisfy` isJust)

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

    -- Both claims stamp the same worker. Only the later one holds the lease.
    let flagStaleAndCurrent :: env
-> UUID -> Text -> IO (Int64, [JobRead payload], [JobRead payload])
flagStaleAndCurrent env
env UUID
owner Text
name = 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
name)))
          let jobId = JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
inserted
          stale <- runM env (HL.claimNextVisibleJobsAs 1 0 owner) :: IO [JobRead payload]
          map primaryKey stale `shouldBe` [jobId]
          current <- claimJobsAs env 1 owner
          map primaryKey current `shouldBe` [jobId]
          runM env (HL.forceCancelJob @payload jobId) `shouldReturn` 1
          pure (jobId, stale, current)

    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 to the later claim of the same worker" ((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
      (jobId, stale, current) <- env
-> UUID -> Text -> IO (Int64, [JobRead payload], [JobRead payload])
flagStaleAndCurrent env
env UUID
owner Text
"cancel-stale-claim"

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

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

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"leaves a lapsed force-cancel-flagged job to its holder when an earlier claim deletes" ((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
      (jobId, stale, current) <- env
-> UUID -> Text -> IO (Int64, [JobRead payload], [JobRead payload])
flagStaleAndCurrent env
env UUID
owner Text
"cancel-stale-lapsed"
      Just flaggedRow <- getJob env jobId
      void $ runM env (HL.setVisibilityTimeout 0 flaggedRow)

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

      deleteCancelledAs env owner current >>= (`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
"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
"nackJobAfter" (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
"parks the job for the delay and refunds 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 (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"nack-after")))
      [held] <- claimJobs env 1
      before' <- getCurrentTime

      runM env (HL.nackJobAfter 3600 held) `shouldReturn` 1

      Just reread <- getJob env (primaryKey inserted)
      attempts reread `shouldBe` 0
      claimedBy reread `shouldBe` Nothing
      notVisibleUntil reread `shouldSatisfy` maybe False (> addUTCTime 3500 before')
      claimJobs env 1 `shouldReturn` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"parks a batch for the delay" ((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-after-batch-a")))
      Just jobB <- runM env (HL.insertJob (defaultJob (mkMessage "nack-after-batch-b")))
      held <- claimJobs env 2
      before' <- getCurrentTime

      sort <$> runM env (HL.nackJobsBatchAfter 3600 held) `shouldReturn` sort [primaryKey jobA, primaryKey jobB]

      for_ [jobA, jobB] $ \JobRead payload
job -> do
        Just reread <- env -> Int64 -> IO (Maybe (JobRead payload))
getJob env
env (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job)
        attempts reread `shouldBe` 0
        notVisibleUntil reread `shouldSatisfy` maybe False (> addUTCTime 3500 before')
      claimJobs env 2 `shouldReturn` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"makes the job visible at once for a zero delay" ((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-after-zero")))
      [held] <- claimJobs env 1
      runM env (HL.nackJobAfter 0 held) `shouldReturn` 1
      map primaryKey <$> claimJobs env 1 `shouldReturn` [primaryKey inserted]

  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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
1
      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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"recreates a missing summary for a live group" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let key :: Text
key = Text
"grp-missing"
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 -> 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 ("DELETE FROM " <> tbl <> " WHERE group_key = ?") [pval CText key]
      env -> Text -> IO (Maybe Int32)
groupCount env
env Text
key IO (Maybe Int32) -> Maybe Int32 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe Int32
forall a. Maybe a
Nothing

      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
        void (Ops.refreshGroupsForQueue schemaName (HL.queueTable @payload @m) 10 Nothing)
      env -> Text -> IO (Maybe Int32)
groupCount env
env Text
key 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
1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keeps the latest live lease as a group's in-flight deadline" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let key :: Text
key = Text
"grp-latest-lease"
      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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Text
"lease-a", Text
"lease-b"] ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
name -> 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
name)))
      batches <- 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
2 Int
1 NominalDiffTime
60) :: IO [NE.NonEmpty (JobRead payload)]
      map length batches `shouldBe` [2]
      void $ runM env (HL.setVisibilityTimeout 3600 (NE.head (head batches)))
      lateDeadline <-
        runM env $ do
          tbl <- groupsTable
          execQuery
            ("SELECT in_flight_until > NOW() + interval '600 seconds' AS late FROM " <> tbl <> " WHERE group_key = ?")
            [pval CText key]
            (col "late" CBool)
      lateDeadline `shouldBe` [True]

  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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
1

      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 <- claimJobs env 1
      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' <- claimJobs env 1
      length claimed' `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"releases a row with attempts left into its group's ready count" ((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 (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
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"release-ready" (Text -> payload
mkMessage Text
"retryable")))
      [claimed] <- env -> Int -> IO [JobRead payload]
claimJobs env
env Int
1
      groupReadyCount env "release-ready" `shouldReturn` Just 0
      void $ runM env (HL.setVisibilityTimeout 0 claimed)
      groupReadyCount env "release-ready" `shouldReturn` Just 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keeps a lapsed lease with no attempts left out of its group's next due" ((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 (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
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"lapse-exhausted" (Text -> payload
mkMessage Text
"exhausted")))
      [_] <- 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]
      groupHasNextDue env "lapse-exhausted" `shouldReturn` Just False

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keeps a released row with no attempts left out of its group's ready count" ((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 (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
$ Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"release-exhausted" (Text -> payload
mkMessage Text
"exhausted")))
      [claimed] <- env -> Int -> IO [JobRead payload]
claimJobs env
env Int
1
      void $ runM env (HL.setVisibilityTimeout 0 claimed)
      groupReadyCount env "release-exhausted" `shouldReturn` Just 0

    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 pastHalfSecondLeaseMicros

      -- Claimable again
      reclaimed <- claimJobs env 1
      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
"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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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.
Job 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
"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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
10

      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 <- claimJobs env 10
      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
10
      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 <- claimJobs env 10
      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
10

      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 <- claimJobs env 10
      length claimed2 `shouldBe` 0

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

      -- The jobs are re-claimable now
      claimed' <- claimJobs env 10
      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
10
      length claimed `shouldBe` 5

      -- Simulate handler manually acking 2 jobs mid-processing
      let (toAck, stillProcessing) = splitAt 2 claimed
      for_ 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 :: * -> *).
MonadArbiter m =>
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
"re-suspends a finalizer in retry backoff when a DLQ retry restores its 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 :| [_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
"BackoffFinalizer"))
            (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
"BackoffFinalizerChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      [claimedChild] <- claimJobs env 1
      runM env (HL.moveToDLQ "boom" claimedChild) `shouldReturn` 1
      [claimedParent] <- claimJobs env 1
      primaryKey claimedParent `shouldBe` primaryKey parent
      runM env (HL.updateJobForRetry 3600 "boom" claimedParent) `shouldReturn` 1

      [dlqChild] <- dlqAll env
      Just _ <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey dlqChild))
      assertSuspended env (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-worker-flag")))
      let jobId = JobRead payload -> Int64
forall payload key q insertedAt adm.
Job 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 -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refuses a heartbeat 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-worker-heartbeat")))
      let jobId = JobRead payload -> Int64
forall payload key q insertedAt adm.
Job 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

      runM env (HL.setVisibilityTimeoutBatch 3600 [stale])
        >>= (`shouldBe` [JobReclaimed jobId (claimSeq stale) (claimSeq live)])
      Just held <- getJob env jobId
      notVisibleUntil held `shouldBe` notVisibleUntil live

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports a job force-cancelled twice as cancelled" ((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
"double-flag")))
      let jobId = JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
inserted
      [held] <- claimJobsAs env 1 UUID.nil
      runM env (HL.forceCancelJob @payload jobId) `shouldReturn` 1
      runM env (HL.forceCancelJob @payload jobId) `shouldReturn` 1

      runM env (HL.setVisibilityTimeoutBatch 120 [held])
        >>= (`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 a spawn 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-worker-spawn")))
      [stale] <- claimJobsAs env 1 owner
      void $ runM env (HL.setVisibilityTimeout 0 stale)
      [_live] <- claimJobsAs env 1 owner

      runM env (HL.spawnChildren stale (defaultJob (mkMessage "late-child") :| []))
        `shouldThrow` \JobGoneException {} -> Bool
True
      runM env (HL.countJobs @payload) `shouldReturn` 1
      assertNotSuspended env (primaryKey inserted)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refuses an ack's suspend 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-worker-suspend")))
      let jobId = JobRead payload -> Int64
forall payload key q insertedAt adm.
Job 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
      void $ runM env (HL.spawnChildren live (defaultJob (mkMessage "live-child") :| []))

      runM env (HL.ackJob stale) `shouldReturn` 0
      assertNotSuspended env jobId
      runM env (HL.ackJobsBatch [stale]) `shouldReturn` []
      assertNotSuspended env jobId

    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
      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.
Job 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

      sweepCancelled env [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)
      sweepCancelled env [jobId] >>= (`shouldBe` [jobId])
      assertGone env jobId

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Guard pins" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    let stealAfterLapse :: env -> JobRead payload -> IO (JobRead payload, JobRead payload)
stealAfterLapse env
env JobRead payload
inserted = do
          [held] <- env -> Int -> UUID -> IO [JobRead payload]
claimJobsAs env
env Int
1 UUID
UUID.nil
          void $ runM env (HL.setVisibilityTimeout 0 held)
          [stolen] <- claimJobsAs env 1 (UUID.fromWords 5 5 5 5)
          primaryKey stolen `shouldBe` primaryKey inserted
          pure (held, stolen)
        suspendedFinalizer :: env -> Text -> IO (JobRead payload)
suspendedFinalizer env
env Text
name = 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 (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
name)))
          [held] <- claimJobsAs env 1 UUID.nil
          runM env . MA.withDbTransaction $ do
            void (HL.spawnChildren held (defaultJob (mkMessage (name <> "-kid")) :| []))
            void (HL.ackJob held)
          assertSuspended env (primaryKey held)
          pure held

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the cancelled delete leaves an unflagged sibling its holder still runs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      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
"pin-flagged")))
      Just sibling <- runM env (HL.insertJob (defaultJob (mkMessage "pin-sibling")))
      claimed <- claimJobsAs env 2 UUID.nil
      length claimed `shouldBe` 2
      runM env (HL.forceCancelJob @payload (primaryKey flagged)) `shouldReturn` 1

      deleteCancelledAs env UUID.nil claimed
        >>= (`shouldBe` [primaryKey flagged])
      isJust <$> getJob env (primaryKey sibling) `shouldReturn` True

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a replace-dedup over a lapsed lease leaves the old holder no token to ack with" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let keyed :: Text -> JobWrite payload
keyed Text
name = 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
"pin-replace")) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
name))
      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 -> JobWrite payload
keyed Text
"pin-original"))
      [held] <- claimJobsAs env 1 UUID.nil
      void $ runM env (HL.setVisibilityTimeout 0 held)
      Just replaced <- runM env (HL.insertJob (keyed "pin-replacement"))
      primaryKey replaced `shouldBe` primaryKey held

      runM env (HL.ackJob held) `shouldReturn` 0
      (fmap payload <$> getJob env (primaryKey held)) `shouldReturn` Just (mkMessage "pin-replacement")

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not claim a flagged job whose lease lapsed" ((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
"pin-flag-lapsed")))
      [held] <- claimJobsAs env 1 UUID.nil
      runM env (HL.forceCancelJob @payload (primaryKey inserted)) `shouldReturn` 1
      Just flaggedRow <- getJob env (primaryKey inserted)
      void $ runM env (HL.setVisibilityTimeout 0 flaggedRow)

      claimJobs env 10 `shouldReturn` []
      primaryKey held `shouldBe` primaryKey inserted

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not claim a flagged grouped head whose lease lapsed ahead of a ready sibling" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      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 (Text -> payload -> JobWrite payload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"pin-flag-group" (Text -> payload
mkMessage Text
"pin-flag-head")))
      Just sibling <- runM env (HL.insertJob (defaultGroupedJob "pin-flag-group" (mkMessage "pin-flag-next")))
      [held] <- claimJobsAs env 1 UUID.nil
      primaryKey held `shouldBe` primaryKey flagged
      runM env (HL.forceCancelJob @payload (primaryKey flagged)) `shouldReturn` 1
      Just flaggedRow <- getJob env (primaryKey flagged)
      void $ runM env (HL.setVisibilityTimeout 0 flaggedRow)

      claimed <- claimJobs env 10
      map primaryKey claimed `shouldNotContain` [primaryKey flagged]
      map primaryKey claimed `shouldSatisfy` all (== primaryKey sibling)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not claim a scheduled grouped job ahead of a ready sibling" ((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 future = UTCTime -> UTCTime
truncateToMicros (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 UTCTime
now)
      Just scheduled <-
        runM env . HL.insertJob $
          setNotVisibleUntil (Just future) (setPriority 0 (defaultGroupedJob "pin-sched-group" (mkMessage "pin-sched")))
      Just ready <- runM env (HL.insertJob (setPriority 10 (defaultGroupedJob "pin-sched-group" (mkMessage "pin-ready"))))

      claimed <- claimJobs env 10
      map primaryKey claimed `shouldBe` [primaryKey ready]
      (notVisibleUntil =<<) <$> getJob env (primaryKey scheduled) `shouldReturn` Just future

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the exhausted sweep leaves a final attempt that is still running" ((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 (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) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"pin-last-attempt"))))
      [held] <- claimJobsAs env 1 UUID.nil
      attempts held `shouldBe` 1

      runM env (getSchema >>= \Text
schemaName -> Text -> [Text] -> m (Int64, [Text])
forall (m :: * -> *).
MonadArbiter m =>
Text -> [Text] -> m (Int64, [Text])
Ops.sweepExhaustedJobs Text
schemaName [forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m])
        `shouldReturn` (0, [])
      isJust <$> getJob env (primaryKey inserted) `shouldReturn` True
      dlqAll env `shouldReturn` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the exhausted sweep leaves a suspended job on its last 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 (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) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"pin-sweep-suspended"))))
      [held] <- claimJobsAs env 1 UUID.nil
      void $ runM env (HL.setVisibilityTimeout 0 held)
      runM env (HL.suspendJob @payload (primaryKey inserted)) `shouldReturn` 1

      runM env (getSchema >>= \Text
schemaName -> Text -> [Text] -> m (Int64, [Text])
forall (m :: * -> *).
MonadArbiter m =>
Text -> [Text] -> m (Int64, [Text])
Ops.sweepExhaustedJobs Text
schemaName [forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m])
        `shouldReturn` (0, [])
      assertSuspended env (primaryKey inserted)
      dlqAll env `shouldReturn` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the exhausted sweep leaves a flagged job on its last attempt to the cancelled delete" ((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 (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) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"pin-sweep-flagged"))))
      [_held] <- runM env (HL.claimNextVisibleJobsAs 1 1 UUID.nil) :: IO [JobRead payload]
      runM env (HL.forceCancelJob @payload (primaryKey inserted)) `shouldReturn` 1
      threadDelay pastLeaseMicros
      isJust <$> getJob env (primaryKey inserted) `shouldReturn` True

      runM env (getSchema >>= \Text
schemaName -> Text -> [Text] -> m (Int64, [Text])
forall (m :: * -> *).
MonadArbiter m =>
Text -> [Text] -> m (Int64, [Text])
Ops.sweepExhaustedJobs Text
schemaName [forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m])
        `shouldReturn` (0, [])
      dlqAll env `shouldReturn` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch extend with a re-read suspended finalizer leaves it without a deadline" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      held <- env -> Text -> IO (JobRead payload)
suspendedFinalizer env
env Text
"pin-susp-reread"
      Just reread <- getJob env (primaryKey held)
      void $ runM env (HL.setVisibilityTimeoutBatch 3600 [reread])
      (notVisibleUntil =<<) <$> getJob env (primaryKey held) `shouldReturn` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"resume leaves a finalizer whose children are still queued suspended" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      held <- env -> Text -> IO (JobRead payload)
suspendedFinalizer env
env Text
"pin-resume-finalizer"
      runM env (HL.resumeJob @payload (primaryKey held)) `shouldReturn` 0
      assertSuspended env (primaryKey held)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"promote leaves a job whose delay 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
      past <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (-NominalDiffTime
60) (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
      Just inserted <- runM env (HL.insertJob (setNotVisibleUntil (Just past) (defaultJob (mkMessage "pin-promote-due"))))
      runM env (HL.promoteJob @payload (primaryKey inserted)) `shouldReturn` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch ack after a spawn suspends the job and hands back its 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 (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"pin-batch-spawn")))
      [held] <- claimJobsAs env 1 UUID.nil
      runM env . MA.withDbTransaction $ do
        void (HL.spawnChildren held (defaultJob (mkMessage "pin-batch-spawn-kid") :| []))
        void (HL.ackJobsBatch [held])
      assertSuspended env (primaryKey inserted)
      Just reread <- getJob env (primaryKey inserted)
      attempts reread `shouldBe` attempts held - 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a second batch nack of the same claim hands back nothing" ((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
"pin-double-nack")))
      [held] <- claimJobsAs env 1 UUID.nil
      runM env (HL.nackJobsBatch [held]) `shouldReturn` [primaryKey inserted]
      runM env (HL.nackJobsBatch [held]) `shouldReturn` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a DLQ retry leaves a finalizer under a live lease unsuspended" ((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
"LiveLeaseFinalizer"))
            (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
"LiveLeaseFinalizerChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      [claimedChild] <- claimJobs env 1
      primaryKey claimedChild `shouldBe` primaryKey child
      runM env (HL.moveToDLQ "boom" claimedChild) `shouldReturn` 1
      [claimedParent] <- claimJobs env 1
      primaryKey claimedParent `shouldBe` primaryKey parent

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

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reschedule refuses a flagged job whose lease lapsed" ((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
"pin-reschedule-flagged")))
      [_held] <- runM env (HL.claimNextVisibleJobsAs 1 1 UUID.nil) :: IO [JobRead payload]
      runM env (HL.forceCancelJob @payload (primaryKey inserted)) `shouldReturn` 1
      threadDelay pastLeaseMicros
      now <- getCurrentTime
      runM env (HL.rescheduleJob @payload (primaryKey inserted) now) `shouldReturn` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reschedule refuses an exhausted 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 (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) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"pin-reschedule-exhausted"))))
      [_held] <- runM env (HL.claimNextVisibleJobsAs 1 1 UUID.nil) :: IO [JobRead payload]
      threadDelay pastLeaseMicros
      now <- getCurrentTime
      runM env (HL.rescheduleJob @payload (primaryKey inserted) now) `shouldReturn` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the cancelled sweep leaves an unflagged job whose lease lapsed" ((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
"pin-sweep-unflagged")))
      [held] <- claimJobsAs env 1 UUID.nil
      void $ runM env (HL.setVisibilityTimeout 0 held)
      sweepCancelled env [primaryKey inserted] `shouldReturn` []
      isJust <$> getJob env (primaryKey inserted) `shouldReturn` True

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a stale nack leaves the claim that replaced 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
"pin-stale-nack")))
      (held, stolen) <- stealAfterLapse env inserted

      runM env (HL.nackJob held) `shouldReturn` 0
      Just reread <- getJob env (primaryKey inserted)
      claimedBy reread `shouldBe` claimedBy stolen
      attempts reread `shouldBe` attempts stolen

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a stale extend leaves the claim that replaced 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
"pin-stale-extend")))
      (held, _) <- stealAfterLapse env inserted
      before' <- getJob env (primaryKey inserted)

      runM env (HL.setVisibilityTimeout 3600 held) `shouldReturn` 0
      (notVisibleUntil <$>) <$> getJob env (primaryKey inserted) `shouldReturn` (notVisibleUntil <$> before')

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an extend under the suspended finalizer's own token leaves it without a deadline" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      held <- env -> Text -> IO (JobRead payload)
suspendedFinalizer env
env Text
"pin-susp-extend"
      runM env (HL.setVisibilityTimeout 3600 held) `shouldReturn` 0
      (notVisibleUntil =<<) <$> getJob env (primaryKey held) `shouldReturn` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a retry under the suspended finalizer's own token leaves it without a deadline" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      held <- env -> Text -> IO (JobRead payload)
suspendedFinalizer env
env Text
"pin-susp-retry"
      runM env (HL.updateJobForRetry 3600 "boom" held) `shouldReturn` 0
      (notVisibleUntil =<<) <$> getJob env (primaryKey held) `shouldReturn` Nothing
      assertSuspended env (primaryKey held)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch extend under the suspended finalizer's own token leaves it without a deadline" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      held <- env -> Text -> IO (JobRead payload)
suspendedFinalizer env
env Text
"pin-susp-beat"
      void $ runM env (HL.setVisibilityTimeoutBatch 3600 [held])
      (notVisibleUntil =<<) <$> getJob env (primaryKey held) `shouldReturn` Nothing

  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 <- claimJobs env 1
      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 <- claimJobs env 1
      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 <- claimJobs env 1
      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.
Job 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 claimed >>= (`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 <- claimJobs env 1
      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 <- claimJobs env 1
      void $ runM env (HL.updateJobForRetry 0 "Simulated failure" (head claimed))
      reclaimed <- claimJobs env 1
      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 <- claimJobs env 1
      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.
Job 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.
Job 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.
Job 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.
Job 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 <- claimJobs env 1
      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.
Job 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 <- claimJobs env 1
      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 <- claimJobs env 1
      void $ runM env (HL.updateJobForRetry 0 "Simulated failure" (head claimed))
      reclaimed <- claimJobs env 1
      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 -> Int -> IO [JobRead payload]
claimJobs env
env Int
1

      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 <- claimJobs env 1
      length claimed2 `shouldBe` 0

      -- The error message is persisted.
      Just updated <- getJob env (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 <- getJob env (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 <- claimJobs env 1
      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 <- claimJobs env 1
      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 <- claimJobs env 10
      length allJobs `shouldBe` 0

      -- The job is in the DLQ with the final error message
      dlqJobs <- dlqAll env
      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 <- claimJobs env 1
      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 <- dlqAll env
      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 <- claimJobs env 1
      length claimed2 `shouldBe` 1
      payload (head claimed2) `shouldBe` mkMessage "Retry"

      -- Removed from the DLQ
      dlqJobs2 <- dlqAll env
      length dlqJobs2 `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQWithPayload re-inserts the replacement payload and its label" ((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 (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-edit") (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"Original"))))
      claimed <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "Failed" (head claimed))
      dlqJobs <- dlqAll env
      Just retried <- runM env (HL.retryFromDLQWithPayload (DLQ.dlqPrimaryKey (head dlqJobs)) (mkMessage "Edited"))
      primaryKey retried `shouldBe` primaryKey inserted
      attempts retried `shouldBe` 0
      groupKey retried `shouldBe` Just "dlq-edit"
      payload retried `shouldBe` mkMessage "Edited"
      jobKind (payloadKeys retried) `shouldBe` kindOf (mkMessage "Edited" :: payload)
      fmap payload <$> getJob env (primaryKey inserted) `shouldReturn` Just (mkMessage "Edited")

    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 <- claimJobs env 1
      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 <- claimJobs env 1
      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 <- claimJobs env 1
      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 <- dlqAll env
      length dlqJobs `shouldBe` 1

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

      -- Gone
      dlqJobs2 <- dlqAll env
      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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 <- claimJobs env 1
        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)
      findDuplicates allDlqIds `shouldBe` []

    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 <- claimJobs env 1
      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 <- claimJobs env 1
      length claimed2 `shouldBe` 1

      -- Try to DLQ with the old claim token (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 <- claimJobs env 1
      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 <- claimJobs env 1
      length claimed2 `shouldBe` 1

      -- Try to update for retry with the old claim token (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 <- claimJobs env 1
      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 <- claimJobs env 1
      length claimed2 `shouldBe` 1

      -- Try to ack with the old claim token (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 <- claimJobs env 1
      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 <- claimJobs env 1
      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 <- claimJobs env 10
      length remaining `shouldBe` 0
      dlqJobs <- dlqAll env
      Just dlq <- pure (dlqNamed "MaxAtt2" 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 <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "boom" (head claimed))

      dlqJobs <- dlqAll env
      Just dlq <- pure (dlqNamed "RetryDropKey" 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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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
      for_ batch $ \JobRead payload
job -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
Job 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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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
      for_ 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.
Job 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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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
      for_ batches $ \NonEmpty (JobRead payload)
batch -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
Job 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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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.
Job 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.
Job 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
      for_ 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 :: * -> *).
MonadArbiter m =>
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
      for_ batch $ \JobRead payload
job -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
Job 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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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
      for_ claimed $ \JobRead payload
job -> JobRead payload -> Int32
forall payload q insertedAt adm.
Job 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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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
      for_ 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 :: * -> *).
MonadArbiter m =>
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.
Job 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.
Job 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
      for_ 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.
Job 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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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.
Job 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.
Job 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
      for_ 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.
Job 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 :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [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.
Job 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 <- claimJobs env 10
      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.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job1, Int64
absentJobId, JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job2, Int64 -> Int64
forall a. Enum a => a -> a
succ Int64
absentJobId]
      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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [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 <- claimJobs env 1
        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 <- dlqAll env
      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.
Job 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 :: * -> *).
MonadArbiter m =>
[(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 whose claim was replaced" ((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 <- claimJobs env 2
      length claimed `shouldBe` 2
      [job1, job2] <- pure claimed

      -- Simulate job1 being reclaimed by another worker
      void $ runM env (HL.setVisibilityTimeout 0 job1)
      _ <- claimJobs env 1

      -- Move both to the DLQ. job1 has a stale claim token 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 <- dlqAll env
      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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 <- claimJobs env 1
        void $ runM env (HL.moveToDLQ "Failed" (head jobs))

      -- Get DLQ job IDs
      dlqJobs <- env -> IO [DLQJob payload]
dlqAll env
env
      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 <- dlqAll env
      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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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.
Job 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)
      findDuplicates allIds `shouldBe` []

    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 <- getJob env (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 -> Int64 -> IO (Maybe (JobRead payload))
getJob env
env Int64
absentJobId
      found `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"listJobsByGroup 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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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.listJobsByGroup @payload Text
"group-filter-a" Int
10 Int
0)
      length groupAJobs `shouldBe` 3
      for_ groupAJobs $ \JobRead payload
job -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
Job 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 <- claimJobs env 1
      void $ runM env (HL.updateJobForRetry 60 "Retry later" (head claimed))

      -- The job is not claimable
      claimed2 <- claimJobs env 1
      length claimed2 `shouldBe` 0

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

      -- It is claimable now
      claimed3 <- claimJobs env 1
      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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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
      _ <- claimJobs env 2

      -- 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 -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getQueueStats ages a due scheduled job from when it became visible" ((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
"DueScheduled")))
      runM env $ do
        schemaName <- 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
            ( "UPDATE "
                <> tbl
                <> " SET inserted_at = NOW() - interval '1 day', not_visible_until = NOW() - interval '1 second' WHERE id = ?"
            )
            [pval CInt8 (primaryKey inserted)]
      stats <- runM env (HL.getQueueStats @payload)
      HL.readyJobs stats `shouldBe` 1
      HL.oldestReadyAgeSeconds stats `shouldSatisfy` maybe False (< 60)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getQueueStats ages a promoted job from the promote" ((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
"Promoted")))
      runM env $ do
        schemaName <- 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
            ( "UPDATE "
                <> tbl
                <> " SET inserted_at = NOW() - interval '1 day', not_visible_until = NOW() + interval '1 hour' WHERE id = ?"
            )
            [pval CInt8 (primaryKey inserted)]
      runM env (HL.promoteJob @payload (primaryKey inserted)) `shouldReturn` 1
      stats <- runM env (HL.getQueueStats @payload)
      HL.readyJobs stats `shouldBe` 1
      HL.oldestReadyAgeSeconds stats `shouldSatisfy` maybe False (< 60)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getQueueStats ages a resumed job from the resume" ((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
"Resumed")))
      runM env (HL.suspendJob @payload (primaryKey inserted)) `shouldReturn` 1
      runM env $ do
        schemaName <- 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
            ("UPDATE " <> tbl <> " SET inserted_at = NOW() - interval '1 day' WHERE id = ?")
            [pval CInt8 (primaryKey inserted)]
      runM env (HL.resumeJob @payload (primaryKey inserted)) `shouldReturn` 1
      stats <- runM env (HL.getQueueStats @payload)
      HL.readyJobs stats `shouldBe` 1
      HL.oldestReadyAgeSeconds stats `shouldSatisfy` maybe False (< 60)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getQueueStats counts a job out of attempts as exhausted, not ready" ((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
"Exhausted")))
      runM env $ do
        schemaName <- 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
            ("UPDATE " <> tbl <> " SET attempts = max_attempts WHERE id = ?")
            [pval CInt8 (primaryKey inserted)]
      claimed <- claimJobs env 10
      length claimed `shouldBe` 0
      stats <- runM env (HL.getQueueStats @payload)
      HL.readyJobs stats `shouldBe` 0
      HL.exhaustedJobs stats `shouldBe` 1
      HL.oldestReadyAgeSeconds stats `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"insertJob stamps a job asked for zero attempts with one" ((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 (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
0) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"ZeroAttempts"))))
      maxAttempts inserted `shouldBe` Just minMaxAttempts
      stats <- runM env (HL.getQueueStats @payload)
      HL.readyJobs stats `shouldBe` 1
      HL.exhaustedJobs stats `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ stamps a stored zero attempt limit with one" ((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
"ZeroAttemptsDLQ")))
      claimed <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "Failed" (head claimed))
      runM env $ do
        schemaName <- getSchema
        let dlqTbl = Text -> Text -> Text
Schema.jobQueueDLQTable Text
schemaName (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m)
        void $
          execStatement ("UPDATE " <> dlqTbl <> " SET max_attempts = 0 WHERE job_id = ?") [pval CInt8 (primaryKey inserted)]
      dlqJobs <- dlqAll env
      Just retried <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      maxAttempts retried `shouldBe` Just minMaxAttempts
      stats <- runM env (HL.getQueueStats @payload)
      HL.readyJobs stats `shouldBe` 1
      HL.exhaustedJobs stats `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reEnqueueFromArchive stamps a stored zero attempt limit with one" ((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 (Maybe Int32 -> JobWrite payload -> JobWrite payload
forall payload. Maybe Int32 -> JobWrite payload -> JobWrite payload
setArchiveFor (Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
dayRetention) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"ZeroAttemptsArchive"))))
      claimed <- claimJobs env 1
      void $ runM env (HL.ackJob (head claimed))
      runM env $ do
        schemaName <- getSchema
        let archiveTbl = Text -> Text -> Text
Schema.jobQueueArchiveTable Text
schemaName (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m)
        void $
          execStatement ("UPDATE " <> archiveTbl <> " SET max_attempts = 0 WHERE job_id = ?") [pval CInt8 (primaryKey inserted)]
      Just archived <- runM env (HL.getArchiveJobById @payload (primaryKey inserted))
      Just again <- runM env (HL.reEnqueueFromArchive @payload (archivePrimaryKey archived))
      maxAttempts again `shouldBe` Just minMaxAttempts

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ stamps a stored null attempt limit with the default" ((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
"NullAttemptsDLQ")))
      claimed <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "Failed" (head claimed))
      runM env $ do
        schemaName <- getSchema
        let dlqTbl = Text -> Text -> Text
Schema.jobQueueDLQTable Text
schemaName (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m)
        void $
          execStatement ("UPDATE " <> dlqTbl <> " SET max_attempts = NULL WHERE job_id = ?") [pval CInt8 (primaryKey inserted)]
      dlqJobs <- dlqAll env
      Just retried <- runM env (HL.retryFromDLQ @payload (DLQ.dlqPrimaryKey (head dlqJobs)))
      maxAttempts retried `shouldBe` Just defaultMaxAttempts

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reEnqueueFromArchiveWithPayload enqueues the replacement and keeps the archive row" ((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 (Maybe Int32 -> JobWrite payload -> JobWrite payload
forall payload. Maybe Int32 -> JobWrite payload -> JobWrite payload
setArchiveFor (Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
dayRetention) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"ArchivedOriginal"))))
      claimed <- claimJobs env 1
      void $ runM env (HL.ackJob (head claimed))
      Just archived <- runM env (HL.getArchiveJobById @payload (primaryKey inserted))
      Just again <- runM env (HL.reEnqueueFromArchiveWithPayload (archivePrimaryKey archived) (mkMessage "ArchivedEdited"))
      payload again `shouldBe` mkMessage "ArchivedEdited"
      jobKind (payloadKeys again) `shouldBe` kindOf (mkMessage "ArchivedEdited" :: payload)
      Just kept <- runM env (HL.getArchiveJobById @payload (primaryKey inserted))
      payload (Archive.jobSnapshot kept) `shouldBe` mkMessage "ArchivedOriginal"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reEnqueueFromArchive stamps a stored null attempt limit with the default" ((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 (Maybe Int32 -> JobWrite payload -> JobWrite payload
forall payload. Maybe Int32 -> JobWrite payload -> JobWrite payload
setArchiveFor (Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
dayRetention) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"NullAttemptsArchive"))))
      claimed <- claimJobs env 1
      void $ runM env (HL.ackJob (head claimed))
      runM env $ do
        schemaName <- getSchema
        let archiveTbl = Text -> Text -> Text
Schema.jobQueueArchiveTable Text
schemaName (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m)
        void $
          execStatement
            ("UPDATE " <> archiveTbl <> " SET max_attempts = NULL WHERE job_id = ?")
            [pval CInt8 (primaryKey inserted)]
      Just archived <- runM env (HL.getArchiveJobById @payload (primaryKey inserted))
      Just again <- runM env (HL.reEnqueueFromArchive @payload (archivePrimaryKey archived))
      maxAttempts again `shouldBe` Just defaultMaxAttempts

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retryFromDLQ leaves a row its payload type rejects in the DLQ" ((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
"BogusDLQ")))
      claimed <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "Failed" (head claimed))
      dlqJobs <- dlqAll env
      let dlqId = DLQJob payload -> Int64
forall payload. DLQJob payload -> Int64
DLQ.dlqPrimaryKey ([DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head [DLQJob payload]
dlqJobs)
      runM env $ do
        schemaName <- getSchema
        let dlqTbl = Text -> Text -> Text
Schema.jobQueueDLQTable Text
schemaName (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m)
        void $
          execStatement
            ("UPDATE " <> dlqTbl <> " SET payload = '{\"bogus\": 1}' WHERE job_id = ?")
            [pval CInt8 (primaryKey inserted)]
      runM env (HL.retryFromDLQ @payload dlqId) `shouldThrow` \ParsingException {} -> Bool
True
      runM env (HL.dlqJobExists @payload dlqId) `shouldReturn` True
      stats <- runM env (HL.getQueueStats @payload)
      HL.readyJobs stats `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reEnqueueFromArchive enqueues nothing for a row its payload type rejects" ((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 (Maybe Int32 -> JobWrite payload -> JobWrite payload
forall payload. Maybe Int32 -> JobWrite payload -> JobWrite payload
setArchiveFor (Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
dayRetention) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkMessage Text
"BogusArchive"))))
      claimed <- claimJobs env 1
      void $ runM env (HL.ackJob (head claimed))
      Just archived <- runM env (HL.getArchiveJobById @payload (primaryKey inserted))
      runM env $ do
        schemaName <- getSchema
        let archiveTbl = Text -> Text -> Text
Schema.jobQueueArchiveTable Text
schemaName (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m)
        void $
          execStatement
            ("UPDATE " <> archiveTbl <> " SET payload = '{\"bogus\": 1}' WHERE job_id = ?")
            [pval CInt8 (primaryKey inserted)]
      runM env (HL.reEnqueueFromArchive @payload (archivePrimaryKey archived)) `shouldThrow` \ParsingException {} -> Bool
True
      stats <- runM env (HL.getQueueStats @payload)
      HL.readyJobs stats `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"getQueueStats counts grouped jobs behind their head as blocked" ((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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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
"blocked-group" (Text -> payload
mkMessage (String -> Text
T.pack (String
"B" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
index)))))
      queued <- 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.readyJobs queued `shouldBe` 1
      HL.blockedJobs queued `shouldBe` 2
      claimed <- claimJobs env 10
      length claimed `shouldBe` 1
      running <- runM env (HL.getQueueStats @payload)
      HL.inFlightJobs running `shouldBe` 1
      HL.readyJobs running `shouldBe` 0
      HL.blockedJobs running `shouldBe` 2
      HL.oldestReadyAgeSeconds running `shouldSatisfy` isJust

  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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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 :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [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
      for_ [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 <- claimJobs env 1
        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 <- claimJobs env 1
      length claimed `shouldBe` 1
      rowsAffected <- runM env (HL.ackJob (head claimed))
      rowsAffected `shouldBe` 1

      -- The job is deleted
      found <- getJob env (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 <- claimJobs env 10
      length claimed `shouldBe` 0

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

      -- Children are claimable now
      claimed2 <- claimJobs env 10
      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.
Job 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 leaves a delayed child alone" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      future <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
      Right (parent :| [delayed, ready]) <-
        runM env
          $ HL.insertJobTree
          $ JT.rollup
            (defaultJob (mkMessage "DelayParent"))
            ( JT.leaf (setNotVisibleUntil (Just future) (defaultJob (mkMessage "DelayedChild")))
                :| [JT.leaf (defaultJob (mkMessage "ReadyChild"))]
            )
      map payload [delayed, ready] `shouldBe` [mkMessage "DelayedChild", mkMessage "ReadyChild"]

      runM env (HL.pauseChildren @payload (primaryKey parent)) `shouldReturn` 1
      assertNotSuspended env (primaryKey delayed)
      assertSuspended env (primaryKey ready)
      runM env (HL.resumeChildren @payload (primaryKey parent)) `shouldReturn` 1

    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 <- claimJobs env 10
      length noneClaimed `shouldBe` 0

      -- Parent stays suspended.
      Just parentAfterPause <- getJob env (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 <- getJob env (primaryKey parent)
      suspended parentAfterResume `shouldBe` True

      -- The leaves are claimable.
      claimedLeaves <- claimJobs env 10
      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.
Job 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 <- claimJobs env 1
      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 <- getJob env (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 <- claimJobs env 10
      length claimed `shouldBe` 2

      -- Ack child1
      void $ runM env (HL.ackJob (head claimed))
      pStillExists <- getJob env (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 <- getJob env (primaryKey parent)
      suspended parentResumed `shouldBe` False

      -- Claim and ack parent (completion round) → resumes grandparent
      claimedP <- claimJobs env 1
      length claimedP `shouldBe` 1
      void $ runM env (HL.ackJob (head claimedP))

      pGone <- getJob env (primaryKey parent)
      pGone `shouldBe` Nothing

      -- The grandparent is resumed
      Just gpResumed <- getJob env (primaryKey grandparent)
      suspended gpResumed `shouldBe` False

      -- Claim and ack grandparent (completion round)
      claimedGP <- claimJobs env 1
      length claimedGP `shouldBe` 1
      void $ runM env (HL.ackJob (head claimedGP))

      gpGone <- getJob env (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 <- claimJobs env 10
      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 <- claimJobs env 1
      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 <- getJob env (primaryKey parent1)
      p1Gone `shouldBe` Nothing
      gpStill <- getJob env (primaryKey grandparent)
      gpStill `shouldNotBe` Nothing

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

      -- Claim and ack parent2 completion round
      claimedP2 <- claimJobs env 1
      length claimedP2 `shouldBe` 1
      void $ runM env (HL.ackJob (head claimedP2))

      p2Gone <- getJob env (primaryKey parent2)
      p2Gone `shouldBe` Nothing

      -- The grandparent is resumed now
      claimedGP <- claimJobs env 1
      length claimedGP `shouldBe` 1
      void $ runM env (HL.ackJob (head claimedGP))

      gpGone <- getJob env (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 <- 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
"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 <- claimJobs env 1
      length claimedC `shouldBe` 1
      void $ runM env (HL.moveToDLQ "Child failed" (head claimedC))

      -- The parent is resumed
      Just pResumed <- getJob env (primaryKey parent)
      suspended pResumed `shouldBe` False

      -- The grandparent stays suspended while the parent is in the main queue
      Just gpStill <- getJob env (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 <- claimJobs env 10
      length claimed `shouldBe` 0

      -- Verify suspended flag
      Just found <- getJob env (primaryKey inserted)
      suspended found `shouldBe` True

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

      -- Now claimable
      claimed2 <- claimJobs env 10
      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 <- claimJobs env 1
      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 suspends a job 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
      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
"BackoffSuspend")))
      [held] <- claimJobs env 1
      runM env (HL.updateJobForRetry 3600 "boom" held) `shouldReturn` 1

      runM env (HL.suspendJob @payload (primaryKey inserted)) `shouldReturn` 1
      assertSuspended env (primaryKey inserted)

    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 <- claimJobs env 1
      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 <- claimJobs env 10
      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
      for_ children $ \JobRead payload
child -> JobRead payload -> Bool
forall payload q insertedAt adm.
Job 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
      for_ children $ \JobRead payload
child -> JobRead payload -> Maybe Int64
forall payload q insertedAt adm.
Job 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.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
parent)

      -- Only the children are claimable
      claimed <- claimJobs env 10
      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.
Job 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
      for_ children $ \JobRead payload
child -> JobRead payload -> Bool
forall payload q insertedAt adm.
Job 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
      for_ children $ \JobRead payload
child -> JobRead payload -> Maybe Text
forall payload key q insertedAt adm.
Job 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 <- claimJobs env 1
      length claimed `shouldBe` 1
      let claimedPayload = JobRead payload -> payload
forall payload key q insertedAt adm.
Job 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
"Child Counts" (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
"countChildrenBatch returns total and suspended counts per 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
"CountParent"))
            (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
"CountChild1")) 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
"CountChild2"))])

      counts <- runM env (HL.countChildrenBatch @payload [primaryKey parent])
      Map.lookup (primaryKey parent) counts `shouldBe` Just (2, 0)

  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 <- claimJobs env 10
      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 <- claimJobs env 1
      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
absentJobId)
      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 <- claimJobs env 1
      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.
Job 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 <- getJob env (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 <- getJob env (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
"a finalizer its ack suspends after a DLQ retry is claimable for its next round" ((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
            (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
"LastAttemptFinalizer"))
            (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
"LastAttemptChild")) JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| [])

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

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

      [retried] <- claimJobs env 1
      void $ runM env (HL.ackJob retried)
      assertNotSuspended env (primaryKey parent)

      map primaryKey <$> claimJobs env 1 `shouldReturn` [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 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.
      Just child1Dlq <- pure (dlqNamed "AutoRetryChild1" 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
      for_ 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 :: * -> *).
MonadArbiter m =>
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.
      Just parentDlq <- pure (dlqNamed "SuspFinParent" 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
      for_ 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 :: * -> *).
MonadArbiter m =>
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.
      Just child1Dlq <- pure (dlqNamed "SibRetryChild1" 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
      for_ 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 :: * -> *).
MonadArbiter m =>
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 <- getJob env (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 <- getJob env (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 <- claimJobs env 1
      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 <- claimJobs env 1
      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 <- getJob env (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.
Job 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
"insertResultUnsafe 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 <- getJob env (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
      Just claimed1 <- pure (claimedFor child1 claimed)
      Just claimed2 <- pure (claimedFor child2 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
      Just claimed1 <- pure (claimedFor child1 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
      Just claimed3 <- pure (claimedFor child3 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
"getResultsByParent returns only children with a stored result" ((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
      for_ 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 :: * -> *).
MonadArbiter m =>
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
      for_ 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 :: * -> *).
MonadArbiter m =>
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
      Just dlq1 <- pure (dlqNamed "DblDLQParent" 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
      Just dlq2 <- pure (dlqNamed "DblDLQParent" 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
      for_ [m1a, m1b] $ \JobRead payload
mapper -> do
        JobRead payload -> Bool
forall payload q insertedAt adm.
Job 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.
Job 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.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
sec1)

      for_ [m2a, m2b] $ \JobRead payload
mapper -> do
        JobRead payload -> Bool
forall payload q insertedAt adm.
Job 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.
Job 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.
Job 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.
Job 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.
Job payload key q insertedAt adm -> payload
payload [JobRead payload
m1a, JobRead payload
m1b, JobRead payload
m2a, JobRead payload
m2b, JobRead payload
solo]
      for_ 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.
Job 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
      for_ 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 :: * -> *).
MonadArbiter m =>
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
      for_ 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 :: * -> *).
MonadArbiter m =>
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
      for_ 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.
Job 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
      for_ 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 :: * -> *).
MonadArbiter m =>
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
      for_ 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 :: * -> *).
MonadArbiter m =>
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 insertResultUnsafe 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 <- claimJobs env 10
      length claimed `shouldBe` 2
      for_ 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 :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)

      -- The parent is claimable now
      [parentJob] <- claimJobs env 1
      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 carries the snapshot
      dlqJobs <- dlqAll env
      Just dlqJob <- pure (dlqNamed "DLQSnapParent" dlqJobs)
      parentState (DLQ.jobSnapshot dlqJob) `shouldBe` Just (Aeson.toJSON mergedSnap)

    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 <- claimJobs env 1
      for_ 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 :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)
      [parentJob] <- claimJobs env 1

      -- 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 <- dlqAll env
      Just dlqJob <- pure (dlqNamed "DLQRetryParent" 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.
Job 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.
Job 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
      for_ childDLQs $ \DLQJob payload
candidate ->
        JobRead payload -> Maybe Text
forall payload q insertedAt adm.
Job 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 <- claimJobs env 10
      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
      Just parentDLQ <- pure (dlqNamed "CascRetryParent" 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 <- claimJobs env 10
      length claimed `shouldBe` 2
      map payload claimed `shouldMatchList` [mkMessage "CascRetryChild1", mkMessage "CascRetryChild2"]

      -- Ack children → parent wakes
      for_ 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 :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job)
      assertNotSuspended env (primaryKey retried)

      -- The parent is claimable
      [parentClaimed] <- claimJobs env 1
      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 <- claimJobs env 2
      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.
Job 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 <- dlqAll env
      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.
Job 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
      for_ childDLQs $ \DLQJob payload
candidate ->
        JobRead payload -> Maybe Text
forall payload q insertedAt adm.
Job 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
      Just gpDLQ <- pure (dlqNamed "SnapGrandparent" 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.
Job 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' <- getJob env (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.
      Just child1DLQ <- pure (dlqNamed "NLevelRetryChild1" 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.
      Just leafDLQ <- pure (dlqNamed "3LRetryLeaf1" 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
      for_ 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 :: * -> *).
MonadArbiter m =>
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
      Just childDLQ <- pure (dlqNamed "SingleDLQChild" 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
      for_ 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 :: * -> *).
MonadArbiter m =>
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
"purgeDLQ" (SpecWith env -> SpecWith env) -> SpecWith env -> SpecWith env
forall a b. (a -> b) -> a -> b
$ do
    let dlqTable :: m Text
dlqTable = do
          schemaName <- m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema
          pure (Schema.jobQueueDLQTable schemaName (HL.queueTable @payload @m))
        backdateDLQ :: env -> Int64 -> IO ()
backdateDLQ 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
            tbl <- m Text
dlqTable
            void $
              execStatement
                ("UPDATE " <> tbl <> " SET failed_at = NOW() - interval '2 hours' WHERE job_id = ?")
                [pval CInt8 jobId]
        purge :: env -> Maybe NominalDiffTime -> IO (Int64, [Text])
purge env
env Maybe NominalDiffTime
retention =
          env -> m (Int64, [Text]) -> IO (Int64, [Text])
forall a. env -> m a -> IO a
runM env
env (m (Int64, [Text]) -> IO (Int64, [Text]))
-> m (Int64, [Text]) -> IO (Int64, [Text])
forall a b. (a -> b) -> a -> b
$ do
            (NominalDiffTime -> m ()) -> Maybe NominalDiffTime -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Text -> Maybe NominalDiffTime -> m ()
forall (m :: * -> *).
MonadArbiter m =>
Text -> Maybe NominalDiffTime -> m ()
HL.setQueueDLQRetention (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m) (Maybe NominalDiffTime -> m ())
-> (NominalDiffTime -> Maybe NominalDiffTime)
-> NominalDiffTime
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just) Maybe NominalDiffTime
retention
            schemaName <- m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema
            Ops.purgeDLQ schemaName [HL.queueTable @payload @m]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"deletes DLQ jobs older than the retention and keeps newer ones" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just old <- 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-purge-old")))
      Just _new <- runM env (HL.insertJob (defaultJob (mkMessage "dlq-purge-new")))
      claimed <- claimJobs env 2
      void $ runM env (HL.moveToDLQBatch [(job, "boom") | job <- claimed])
      backdateDLQ env (primaryKey old)

      purge env (Just 3600) `shouldReturn` (1, [])

      remaining <- dlqAll env
      map (payload . DLQ.jobSnapshot) remaining `shouldBe` [mkMessage "dlq-purge-new"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"deletes every row of an expired DLQ tree" ((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
"dlq-purge-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
"dlq-purge-child1")) 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
"dlq-purge-child2"))])
      void $ runM env (HL.moveToDLQ "parent failed" parent)
      traverse_ (backdateDLQ env . primaryKey) (parent : children)

      purge env (Just 3600) `shouldReturn` (3, [])
      dlqAll env `shouldReturn` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keeps the DLQ of a queue without a retention" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Just old <- 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-purge-kept")))
      [claimed] <- claimJobs env 1
      void $ runM env (HL.moveToDLQ "boom" claimed)
      backdateDLQ env (primaryKey old)

      purge env Nothing `shouldReturn` (0, [])
      length <$> dlqAll env `shouldReturn` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"stores the retention on the queue's row" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (Text -> Maybe NominalDiffTime -> m ()
forall (m :: * -> *).
MonadArbiter m =>
Text -> Maybe NominalDiffTime -> m ()
HL.setQueueDLQRetention (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m) (NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
86400))
      (Maybe QueueRow
-> (QueueRow -> Maybe NominalDiffTime) -> Maybe NominalDiffTime
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= QueueRow -> Maybe NominalDiffTime
HL.dlqRetention) (Maybe QueueRow -> Maybe NominalDiffTime)
-> IO (Maybe QueueRow) -> IO (Maybe NominalDiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> m (Maybe QueueRow) -> IO (Maybe QueueRow)
forall a. env -> m a -> IO a
runM env
env (Text -> m (Maybe QueueRow)
forall (m :: * -> *). MonadArbiter m => Text -> m (Maybe QueueRow)
HL.getQueue (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m)) IO (Maybe NominalDiffTime) -> Maybe NominalDiffTime -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
86400
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (Text -> Maybe NominalDiffTime -> m ()
forall (m :: * -> *).
MonadArbiter m =>
Text -> Maybe NominalDiffTime -> m ()
HL.setQueueDLQRetention (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m) Maybe NominalDiffTime
forall a. Maybe a
Nothing)
      (Maybe QueueRow
-> (QueueRow -> Maybe NominalDiffTime) -> Maybe NominalDiffTime
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= QueueRow -> Maybe NominalDiffTime
HL.dlqRetention) (Maybe QueueRow -> Maybe NominalDiffTime)
-> IO (Maybe QueueRow) -> IO (Maybe NominalDiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> m (Maybe QueueRow) -> IO (Maybe QueueRow)
forall a. env -> m a -> IO a
runM env
env (Text -> m (Maybe QueueRow)
forall (m :: * -> *). MonadArbiter m => Text -> m (Maybe QueueRow)
HL.getQueue (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m)) IO (Maybe NominalDiffTime) -> Maybe NominalDiffTime -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Maybe NominalDiffTime
forall a. Maybe a
Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rejects a retention that is not positive" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env ->
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (Text -> Maybe NominalDiffTime -> m ()
forall (m :: * -> *).
MonadArbiter m =>
Text -> Maybe NominalDiffTime -> m ()
HL.setQueueDLQRetention (forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m) (NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
0)) IO () -> Selector SomeException -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` Selector SomeException
anyException

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"schemaQueues" (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
"adds registered queues whose tables exist to the given ones" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let table :: Text
table = forall payload (m :: * -> *).
KnownSymbol (TableForPayload payload (RegistryOf m)) =>
Text
HL.queueTable @payload @m
      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 -> m Int64
forall (m :: * -> *). MonadArbiter m => Text -> m Int64
HL.ensureQueue Text
table)
      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 -> m Int64
forall (m :: * -> *). MonadArbiter m => Text -> m Int64
HL.ensureQueue Text
"no_such_queue")
      env -> m [Text] -> IO [Text]
forall a. env -> m a -> IO a
runM env
env (m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema m Text -> (Text -> m [Text]) -> m [Text]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
schemaName -> Text -> [Text] -> m [Text]
forall (m :: * -> *). MonadArbiter m => Text -> [Text] -> m [Text]
Ops.schemaQueues Text
schemaName []) IO [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [Text
table]
      env -> m [Text] -> IO [Text]
forall a. env -> m a -> IO a
runM env
env (m Text
forall (m :: * -> *). MonadArbiter m => m Text
getSchema m Text -> (Text -> m [Text]) -> m [Text]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
schemaName -> Text -> [Text] -> m [Text]
forall (m :: * -> *). MonadArbiter m => Text -> [Text] -> m [Text]
Ops.schemaQueues Text
schemaName [Text
"registry_only"])
        IO [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text
"registry_only", Text
table]

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"retryFromDLQBatch" (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
"retries each DLQ row and skips unknown ids" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      [Text] -> (Text -> IO (Maybe (JobRead payload))) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Text
"dlq-batch-a", Text
"dlq-batch-b", Text
"dlq-batch-c"] ((Text -> IO (Maybe (JobRead payload))) -> IO ())
-> (Text -> IO (Maybe (JobRead payload))) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
name ->
        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
name)))
      claimed <- env -> Int -> IO [JobRead payload]
claimJobs env
env Int
3
      void $ runM env (HL.moveToDLQBatch [(job, "boom") | job <- claimed])
      dlqIds <- map DLQ.dlqPrimaryKey <$> dlqAll env

      runM env (HL.retryFromDLQBatch @payload (absentJobId : dlqIds)) `shouldReturn` 3

      dlqAll env `shouldReturn` []
      length <$> claimJobs env 3 `shouldReturn` 3

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"counts a tree once when several of its rows are named" ((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
"dlq-batch-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
"dlq-batch-child1")) 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
"dlq-batch-child2"))])
      void $ runM env (HL.moveToDLQ "parent failed" parent)
      dlqIds <- map DLQ.dlqPrimaryKey <$> dlqAll env
      length dlqIds `shouldBe` 3

      runM env (HL.retryFromDLQBatch @payload dlqIds) `shouldReturn` 1

      dlqAll env `shouldReturn` []
      assertSuspended env (primaryKey parent)

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"retryDLQFiltered" (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
"retries only the DLQ rows the filters match" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      [Text] -> (Text -> IO (Maybe (JobRead payload))) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Text
"dlq-filter-a", Text
"dlq-filter-b", Text
"dlq-filter-c"] ((Text -> IO (Maybe (JobRead payload))) -> IO ())
-> (Text -> IO (Maybe (JobRead payload))) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
name ->
        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
name)))
      claimed <- env -> Int -> IO [JobRead payload]
claimJobs env
env Int
3
      let failure JobRead payload
job
            | JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkMessage Text
"dlq-filter-c" = Text
"bad input"
            | Bool
otherwise = Text
"upstream timeout"
      void $ runM env (HL.moveToDLQBatch [(job, failure job) | job <- claimed])

      runM env (HL.retryDLQFiltered @payload [Ops.FilterErrorText "TIMEOUT"]) `shouldReturn` 2

      remaining <- dlqAll env
      map (payload . DLQ.jobSnapshot) remaining `shouldBe` [mkMessage "dlq-filter-c"]
      requeued <- map payload <$> claimJobs env 3
      length requeued `shouldBe` 2
      requeued `shouldSatisfy` all (`elem` [mkMessage "dlq-filter-a", mkMessage "dlq-filter-b"])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retries the whole DLQ with no filters" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      [Text] -> (Text -> IO (Maybe (JobRead payload))) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Text
"dlq-filter-all-a", Text
"dlq-filter-all-b"] ((Text -> IO (Maybe (JobRead payload))) -> IO ())
-> (Text -> IO (Maybe (JobRead payload))) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
name ->
        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
name)))
      claimed <- env -> Int -> IO [JobRead payload]
claimJobs env
env Int
2
      void $ runM env (HL.moveToDLQBatch [(job, "boom") | job <- claimed])

      runM env (HL.retryDLQFiltered @payload []) `shouldReturn` 2
      dlqAll env `shouldReturn` []

  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.
Job 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.
Job 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
      for_ childDLQs $ \DLQJob payload
candidate ->
        JobRead payload -> Maybe Text
forall payload q insertedAt adm.
Job 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
      for_ 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 :: * -> *).
MonadArbiter m =>
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
      Just leafDLQ <- pure (dlqNamed "4LDLQLeafA" 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"]