{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-x-partial #-}

-- | Worker conformance suites, instantiated for each backend.
-- Build the schema with 'Arbiter.Test.Setup.setupOnce' with notify on. Empty it in
-- 'mkEnv' and 'mkFreshEnv' with 'Arbiter.Test.Setup.cleanupData' or
-- 'Arbiter.Test.Setup.cleanupOnce'.
module Arbiter.Test.Worker
  ( workerSpec
  , listenerSpec
  , multiQueueListenerSpec
  , deadlineSpec
  , cronSpec
  , reclaimSpec
  , connectionRecoverySpec
  , lifecycleSpec
  , TestBackend (..)
  , plainHandler
  , statementCommand
  ) where

import Arbiter.Core.Exceptions
  ( JobException (..)
  , JobGoneException (..)
  , JobPermanentException (..)
  , JobScopedFailure (..)
  , throwBranchCancel
  , throwJobGone
  , throwNack
  , throwNackAfter
  , throwPermanent
  , throwRetryable
  , throwRetryableAfter
  , throwScopedFailure
  , throwTreeCancel
  )
import Arbiter.Core.HighLevel (QueueOperation, RegistryAdmissionPolicies)
import Arbiter.Core.HighLevel qualified as HL
import Arbiter.Core.Job.Archive qualified as Archive
import Arbiter.Core.Job.DLQ qualified as DLQ
import Arbiter.Core.Job.Dedup (DedupKey (..))
import Arbiter.Core.Job.Schema qualified as Schema
import Arbiter.Core.Job.Types
  ( JobRead
  , ObservabilityHooks (..)
  , attempts
  , claimedBy
  , dayRetention
  , defaultJob
  , defaultObservabilityHooks
  , groupKey
  , isRollup
  , jobKind
  , kindOf
  , lastError
  , notVisibleUntil
  , parentId
  , payload
  , payloadKeys
  , primaryKey
  , setArchiveFor
  , setDedupKey
  , setGroupKey
  , setMaxAttempts
  , setNotVisibleUntil
  )
import Arbiter.Core.JobTree ((<~~))
import Arbiter.Core.JobTree qualified as JT
import Arbiter.Core.Listen qualified as Listen
import Arbiter.Core.MonadArbiter
  ( JobHandler
  , MonadArbiter
  , RegistryOf
  , ResultOf
  , executeStatement
  , getListener
  , withDbTransaction
  )
import Arbiter.Core.QueueRegistry (RegistryTables)
import Arbiter.Core.Sql.Query (raw)
import Arbiter.Worker (childResults, runWorkerPool)
import Arbiter.Worker.BackoffStrategy (BackoffStrategy (Constant), Jitter (NoJitter))
import Arbiter.Worker.Config
  ( BatchCallbacks
  , WorkerConfig (..)
  , ack
  , ackAll
  , ackAllWith
  , ackWith
  , batchedWorkerConfig
  , cancelBranch
  , cancelTree
  , failPermanent
  , failRetry
  , failRetryAfter
  , nack
  , nackAfter
  , spawn
  , transactionalWorkerConfig
  )
import Control.Concurrent (threadDelay)
import Control.Monad (join, void, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (toJSON)
import Data.ByteString (ByteString)
import Data.Foldable (for_, toList, traverse_)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
import Data.Int (Int32, Int64)
import Data.List (find, partition)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Time (addUTCTime, getCurrentTime)
import Database.PostgreSQL.Simple (Only (..))
import Database.PostgreSQL.Simple qualified as PG
import Database.PostgreSQL.Simple.Types (Identifier (..))
import Test.Hspec
import UnliftIO (atomically, bracket, newEmptyMVar, putMVar, takeMVar, try)
import UnliftIO.Async (concurrently_, withAsync)

import Arbiter.Test.Poll (bumpRef, waitUntil)
import Arbiter.Test.Setup (listenerConnectionCount, quietHubLog, terminateBackendsMatching, withConn)
import Arbiter.Test.Worker.Backend (TestBackend (..))
import Arbiter.Test.Worker.ConnectionRecovery (connectionRecoverySpec)
import Arbiter.Test.Worker.Cron (cronSpec)
import Arbiter.Test.Worker.Deadline (deadlineSpec)
import Arbiter.Test.Worker.Lifecycle (lifecycleSpec)
import Arbiter.Test.Worker.Reclaim (reclaimSpec)

-- | How long each handler runs in the worker-count test.
concurrentHandlerMicros :: Int
concurrentHandlerMicros :: Int
concurrentHandlerMicros = Int
500_000

-- | A pause for the worker to settle the job and run its hooks.
settleMicros :: Int
settleMicros :: Int
settleMicros = Int
300_000

-- | How long each handler runs in the multi-group test.
groupHandlerMicros :: Int
groupHandlerMicros :: Int
groupHandlerMicros = Int
1_000_000

-- | A handler run longer than the test.
longHandlerMicros :: Int
longHandlerMicros :: Int
longHandlerMicros = Int
10_000_000

-- | Longer than two visibility timeouts. The heartbeat keeps the leases alive.
leaseOutlastMicros :: Int
leaseOutlastMicros :: Int
leaseOutlastMicros = Int
8_000_000

-- | A pause for late hooks after the queue drains.
afterDrainMicros :: Int
afterDrainMicros :: Int
afterDrainMicros = Int
200_000

-- | A short handler run.
shortHandlerMicros :: Int
shortHandlerMicros :: Int
shortHandlerMicros = Int
200_000

-- | A handler run that covers several heartbeat ticks.
heartbeatHandlerMicros :: Int
heartbeatHandlerMicros :: Int
heartbeatHandlerMicros = Int
3_000_000

-- | A batch handler run that covers several heartbeat ticks.
batchHeartbeatHandlerMicros :: Int
batchHeartbeatHandlerMicros :: Int
batchHeartbeatHandlerMicros = Int
6_000_000

-- | A pause after the inserts, before the worker starts.
beforeStartMicros :: Int
beforeStartMicros :: Int
beforeStartMicros = Int
100_000

-- | Longer than one heartbeat tick.
heartbeatTickMicros :: Int
heartbeatTickMicros :: Int
heartbeatTickMicros = Int
1_500_000

-- | A success hook slow enough for a heartbeat tick to run during it.
slowSuccessHookMicros :: Int
slowSuccessHookMicros :: Int
slowSuccessHookMicros = Int
400_000

-- | How long the spawn transaction stays open after the ack.
spawnHoldMicros :: Int
spawnHoldMicros :: Int
spawnHoldMicros = Int
300_000

-- | A pause for the listener to subscribe.
listenerStartMicros :: Int
listenerStartMicros :: Int
listenerStartMicros = Int
1_000_000

-- | A pause for the listener to reconnect and subscribe again.
reconnectMicros :: Int
reconnectMicros :: Int
reconnectMicros = Int
3_000_000

-- | A pause in which a wrong wake-up would show.
strayWakeMicros :: Int
strayWakeMicros :: Int
strayWakeMicros = Int
500_000

-- | A backend handler that ignores the connection argument.
plainHandler :: (job -> m r) -> conn -> job -> m r
plainHandler :: forall {k} job (m :: k -> *) (r :: k) conn.
(job -> m r) -> conn -> job -> m r
plainHandler job -> m r
handler conn
_conn job
job = job -> m r
handler job
job

-- | Run a command through 'executeStatement' and discard its row count.
statementCommand :: (MonadArbiter m) => Text -> m ()
statementCommand :: forall (m :: * -> *). MonadArbiter m => Text -> m ()
statementCommand = m Int64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Int64 -> m ()) -> (Text -> m Int64) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query () -> m Int64
forall a. Query a -> m Int64
forall (m :: * -> *) a. MonadArbiter m => Query a -> m Int64
executeStatement (Query () -> m Int64) -> (Text -> Query ()) -> Text -> m Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Query ()
raw

-- | Worker-pool suite. The queue under test declares @Maybe [Text]@ as its result type.
workerSpec
  :: forall payload m env
   . ( Eq payload
     , QueueOperation m payload
     , RegistryAdmissionPolicies (RegistryOf m)
     , RegistryTables (RegistryOf m)
     , ResultOf m payload ~ Maybe [Text]
     , Show payload
     )
  => TestBackend payload m env
  -> Spec
workerSpec :: forall payload (m :: * -> *) env.
(Eq payload, QueueOperation m payload,
 RegistryAdmissionPolicies (RegistryOf m),
 RegistryTables (RegistryOf m), ResultOf m payload ~ Maybe [Text],
 Show payload) =>
TestBackend payload m env -> Spec
workerSpec TestBackend {Text -> payload
mkSimple :: Text -> payload
mkSimple :: forall payload (m :: * -> *) env.
TestBackend payload m env -> Text -> payload
mkSimple, Int -> payload
mkFailing :: Int -> payload
mkFailing :: forall payload (m :: * -> *) env.
TestBackend payload m env -> Int -> payload
mkFailing, IO env
mkEnv :: forall payload (m :: * -> *) env.
TestBackend payload m env -> IO env
mkEnv :: IO env
mkEnv, (JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler :: (JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler :: forall payload (m :: * -> *) env.
TestBackend payload m env
-> (JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler, forall a. env -> m a -> IO a
runM :: forall a. env -> m a -> IO a
runM :: forall payload (m :: * -> *) env.
TestBackend payload m env -> forall a. env -> m a -> IO a
runM} = IO env -> SpecWith env -> Spec
forall a. IO a -> SpecWith a -> Spec
before IO env
mkEnv (SpecWith env -> Spec) -> SpecWith env -> Spec
forall a b. (a -> b) -> a -> b
$ do
  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Worker Pool" (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
"processes jobs successfully" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      completedRef <- [payload] -> IO (IORef [payload])
forall a. a -> IO (IORef a)
newIORef []
      config <- mkConfig $ \JobRead payload
job ->
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
completedRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
jobs -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
jobs, ())
      let 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
"g1") (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
mkSimple Text
"Job 1")
            , 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
"g2") (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
mkSimple Text
"Job 2")
            , 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
"g3") (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
mkSimple Text
"Job 3")
            ]

      runM env $ traverse_ HL.insertJob jobs

      withAsync (runM env $ runWorkerPool config {workerCount = 3, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3) (Int -> Bool) -> ([payload] -> Int) -> [payload] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([payload] -> Bool) -> IO [payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
completedRef
        completed <- IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
completedRef
        length completed `shouldBe` 3
        completed `shouldMatchList` [mkSimple "Job 1", mkSimple "Job 2", mkSimple "Job 3"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"respects worker count concurrency limit" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      activeRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      maxActiveRef <- newIORef (0 :: Int)
      completedRef <- newIORef (0 :: Int)
      config <- mkConfig $ \JobRead payload
_job -> do
        active <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
activeRef ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
count -> let count' :: Int
count' = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in (Int
count', Int
count')
        liftIO $ atomicModifyIORef' maxActiveRef $ \Int
maxN -> (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
maxN Int
active, ())
        liftIO $ threadDelay concurrentHandlerMicros
        liftIO $ atomicModifyIORef' activeRef $ \Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, ())
        liftIO $ bumpRef completedRef
      let jobs =
            (Int -> JobWrite payload) -> [Int] -> [JobWrite payload]
forall a b. (a -> b) -> [a] -> [b]
map
              (\Int
index -> Maybe Text -> JobWrite payload -> JobWrite payload
forall payload. Maybe Text -> JobWrite payload -> JobWrite payload
setGroupKey (Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"g" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> 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
mkSimple (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
<> forall a. Show a => a -> String
show @Int Int
index)))
              [Int
1 .. Int
10]

      runM env $ traverse_ HL.insertJob jobs

      withAsync (runM env $ runWorkerPool config {workerCount = 3, pollInterval = 0.05}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
completedRef
        completed <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
completedRef
        completed `shouldBe` 10
        maxActive <- readIORef maxActiveRef
        maxActive `shouldSatisfy` (> 1)
        maxActive `shouldSatisfy` (<= 3)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retries failed jobs up to max attempts" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      attemptsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      -- The handler throws on the first two attempts.
      config <- mkConfig $ \JobRead payload
_job -> do
        attempt <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
attemptsRef ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        when (attempt < 3) $ throwRetryable "Not yet!"
      let 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
5) (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
"g1") (JobWrite payload -> JobWrite payload)
-> JobWrite payload -> JobWrite payload
forall a b. (a -> b) -> a -> b
$ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Int -> payload
mkFailing Int
3)

      void $ runM env $ HL.insertJob job

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1, jitter = NoJitter}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
attemptsRef
        attempts' <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
attemptsRef
        attempts' `shouldBe` 3

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moves jobs to DLQ after max attempts" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> Text -> m ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwRetryable Text
"Always fails"
      let 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
1) (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
"g1") (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
mkSimple Text
"Doomed")

      void $ runM env $ HL.insertJob job

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          dlqJobs <- env -> IO [DLQJob payload]
dlqAll env
env
          pure (length dlqJobs == 1)
        dlqJobs <- env -> IO [DLQJob payload]
dlqAll env
env
        length dlqJobs `shouldBe` 1
        let dlqJob = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head [DLQJob payload]
dlqJobs
        payload (DLQ.jobSnapshot dlqJob) `shouldBe` mkSimple "Doomed"
        attempts (DLQ.jobSnapshot dlqJob) `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"archives a completed job when archiveFor is set" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      void
        $ runM env
        $ HL.insertJob (setArchiveFor (Just dayRetention) $ setGroupKey (Just "g1") $ defaultJob (mkSimple "arch-done"))

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ArchiveJob payload) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ArchiveJob payload) -> Bool)
-> IO (Maybe (ArchiveJob payload)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"arch-done"
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        map (payload . Archive.jobSnapshot) arch `shouldBe` [mkSimple "arch-done"]
        map (jobKind . payloadKeys . Archive.jobSnapshot) arch
          `shouldBe` [kindOf (mkSimple "arch-done" :: payload)]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fetches an archived job by id" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      void
        $ runM env
        $ HL.insertJob (setArchiveFor (Just dayRetention) $ setGroupKey (Just "gk") $ defaultJob (mkSimple "arch-byid"))

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ArchiveJob payload) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ArchiveJob payload) -> Bool)
-> IO (Maybe (ArchiveJob payload)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"arch-byid"
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        let jid = JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey (ArchiveJob payload -> JobRead payload
forall payload. ArchiveJob payload -> JobSnapshot payload
Archive.jobSnapshot ([ArchiveJob payload] -> ArchiveJob payload
forall a. HasCallStack => [a] -> a
head [ArchiveJob payload]
arch))
        found <- runM env $ HL.getArchiveJobById @payload jid
        fmap (payload . Archive.jobSnapshot) found `shouldBe` Just (mkSimple "arch-byid")
        miss <- runM env $ HL.getArchiveJobById @payload 999_999
        (miss :: Maybe (Archive.ArchiveJob payload)) `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"lists archived jobs 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
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      let jobs =
            [ 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) (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
"ga") (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
mkSimple Text
"g-a")
            , 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) (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
"ga") (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
mkSimple Text
"g-b")
            , 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) (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
"gb") (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
mkSimple Text
"other")
            ]
      runM env $ traverse_ HL.insertJob jobs

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          inGa <- env -> m [ArchiveJob payload] -> IO [ArchiveJob payload]
forall a. env -> m a -> IO a
runM env
env (m [ArchiveJob payload] -> IO [ArchiveJob payload])
-> m [ArchiveJob payload] -> IO [ArchiveJob payload]
forall a b. (a -> b) -> a -> b
$ forall payload (m :: * -> *).
QueueOperation m payload =>
Text -> Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobsByGroup @payload Text
"ga" Int
100 Int
0
          pure (length inGa == 2)
        inGa <- env -> m [ArchiveJob payload] -> IO [ArchiveJob payload]
forall a. env -> m a -> IO a
runM env
env (m [ArchiveJob payload] -> IO [ArchiveJob payload])
-> m [ArchiveJob payload] -> IO [ArchiveJob payload]
forall a b. (a -> b) -> a -> b
$ forall payload (m :: * -> *).
QueueOperation m payload =>
Text -> Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobsByGroup @payload Text
"ga" Int
100 Int
0
        map (payload . Archive.jobSnapshot) inGa `shouldMatchList` [mkSimple "g-a", mkSimple "g-b"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not archive a job whose archiveFor is Nothing" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      doneRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
      config <- mkConfig $ \JobRead payload
_job -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
doneRef Bool
True
      void $ runM env $ HL.insertJob (setArchiveFor Nothing $ setGroupKey (Just "g1") $ defaultJob (mkSimple "no-arch"))

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
doneRef
        Int -> IO ()
threadDelay Int
settleMicros
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        map (payload . Archive.jobSnapshot) arch `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reaper purges archived jobs past their archiveFor window" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      void $ runM env $ HL.insertJob (setArchiveFor (Just 1) $ setGroupKey (Just "g1") $ defaultJob (mkSimple "arch-purge"))

      withAsync
        (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1, reaperInterval = 0.5})
        $ \Async ()
_ -> do
          -- First archived, then purged once it ages past the 1s window.
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ArchiveJob payload) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ArchiveJob payload) -> Bool)
-> IO (Maybe (ArchiveJob payload)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"arch-purge"
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ArchiveJob payload) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (ArchiveJob payload) -> Bool)
-> IO (Maybe (ArchiveJob payload)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"arch-purge"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-enqueues an archived job, keeping 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
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      void
        $ runM env
        $ HL.insertJob (setArchiveFor (Just dayRetention) $ setGroupKey (Just "rg") $ defaultJob (mkSimple "re-job"))

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        let countReJob :: [ArchiveJob payload] -> Int
countReJob [ArchiveJob payload]
arch = [ArchiveJob payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((ArchiveJob payload -> Bool)
-> [ArchiveJob payload] -> [ArchiveJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter ((payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkSimple Text
"re-job") (payload -> Bool)
-> (ArchiveJob payload -> payload) -> ArchiveJob 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)
-> (ArchiveJob payload -> JobRead payload)
-> ArchiveJob payload
-> payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveJob payload -> JobRead payload
forall payload. ArchiveJob payload -> JobSnapshot payload
Archive.jobSnapshot) [ArchiveJob payload]
arch)
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          arch <- env -> IO [ArchiveJob payload]
archived env
env
          pure (countReJob arch == 1)
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        let archiveId = ArchiveJob payload -> Int64
forall payload. ArchiveJob payload -> Int64
Archive.archivePrimaryKey ([ArchiveJob payload] -> ArchiveJob payload
forall a. HasCallStack => [a] -> a
head [ArchiveJob payload]
arch)
        reEnq <- runM env $ HL.reEnqueueFromArchive @payload archiveId
        (payload <$> reEnq) `shouldBe` Just (mkSimple "re-job")
        -- Original archive row is kept. The re-run is processed and archived too.
        waitUntil 10_000 $ do
          arch2 <- archived env
          pure (countReJob arch2 == 2)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"purges an archived job by id" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      void
        $ runM env
        $ HL.insertJob (setArchiveFor (Just dayRetention) $ setGroupKey (Just "pg") $ defaultJob (mkSimple "purge-one"))

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ArchiveJob payload) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ArchiveJob payload) -> Bool)
-> IO (Maybe (ArchiveJob payload)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"purge-one"
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        let archiveId = ArchiveJob payload -> Int64
forall payload. ArchiveJob payload -> Int64
Archive.archivePrimaryKey ([ArchiveJob payload] -> ArchiveJob payload
forall a. HasCallStack => [a] -> a
head [ArchiveJob payload]
arch)
        deleted <- runM env $ HL.deleteArchiveJob @payload archiveId
        deleted `shouldBe` 1
        arch2 <- archived env
        map (payload . Archive.jobSnapshot) arch2 `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"bulk-purges archived jobs" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      let jobs =
            [ 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) (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
"b1") (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
mkSimple Text
"bp-1")
            , 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) (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
"b2") (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
mkSimple Text
"bp-2")
            ]
      runM env $ traverse_ HL.insertJob jobs

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          arch <- env -> IO [ArchiveJob payload]
archived env
env
          pure (length arch == 2)
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        let pks = (ArchiveJob payload -> Int64) -> [ArchiveJob payload] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map ArchiveJob payload -> Int64
forall payload. ArchiveJob payload -> Int64
Archive.archivePrimaryKey [ArchiveJob payload]
arch
        deleted <- runM env $ HL.deleteArchiveJobsBatch @payload pks
        deleted `shouldBe` 2
        arch2 <- archived env
        map (payload . Archive.jobSnapshot) arch2 `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DLQ-retried job retains archiveFor and is archived on later success" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      config <- mkConfig $ \JobRead payload
_job -> do
        call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
        when (call == 1) $ throwPermanent "fail first time"
      void
        $ runM env
        $ HL.insertJob
          (setArchiveFor (Just dayRetention) $ setMaxAttempts (Just 1) $ setGroupKey (Just "da") $ defaultJob (mkSimple "dlq-arch"))

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          dlq <- env -> IO [DLQJob payload]
dlqAll env
env
          pure (any ((== mkSimple "dlq-arch") . payload . DLQ.jobSnapshot) dlq)
        dlq <- env -> IO [DLQJob payload]
dlqAll env
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]
dlq)
        void $ runM env $ HL.retryFromDLQ @payload dlqId
        -- On the retry it succeeds. archive_for survived the DLQ round-trip. The job is archived.
        waitUntil 10_000 $ isJust <$> archivedNamed env "dlq-arch"

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"archives the row but stores no result for a Nothing result" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      cfg :: WorkerConfig m payload <-
        Int
-> JobHandler m payload (ResultOf m payload)
-> IO (WorkerConfig m payload)
forall (n :: * -> *) (m :: * -> *) payload.
(MonadArbiter n, MonadIO m) =>
Int
-> JobHandler n payload (ResultOf n payload)
-> m (WorkerConfig n payload)
transactionalWorkerConfig Int
1 ((JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler (\JobRead payload
_job -> Maybe [Text] -> m (Maybe [Text])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Text]
forall a. Maybe a
Nothing :: Maybe [Text])))
      void $ runM env $ HL.insertJob (setArchiveFor (Just dayRetention) $ defaultJob (mkSimple "null-result"))

      withAsync (runM env $ runWorkerPool cfg {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ArchiveJob payload) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ArchiveJob payload) -> Bool)
-> IO (Maybe (ArchiveJob payload)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"null-result"
        mine <- env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"null-result"
        (Archive.archivedResult =<< mine) `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"stores the wrapped value for a Just result" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      cfg :: WorkerConfig m payload <-
        Int
-> JobHandler m payload (ResultOf m payload)
-> IO (WorkerConfig m payload)
forall (n :: * -> *) (m :: * -> *) payload.
(MonadArbiter n, MonadIO m) =>
Int
-> JobHandler n payload (ResultOf n payload)
-> m (WorkerConfig n payload)
transactionalWorkerConfig Int
1 ((JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler (\JobRead payload
_job -> Maybe [Text] -> m (Maybe [Text])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"kept"] :: Maybe [Text])))
      void $ runM env $ HL.insertJob (setArchiveFor (Just dayRetention) $ defaultJob (mkSimple "just-result"))

      withAsync (runM env $ runWorkerPool cfg {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ArchiveJob payload) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ArchiveJob payload) -> Bool)
-> IO (Maybe (ArchiveJob payload)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"just-result"
        mine <- env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"just-result"
        (Archive.archivedResult =<< mine) `shouldBe` Just (toJSON ["kept" :: Text])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not archive a result when archiveFor is unset" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      doneRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
      cfg :: WorkerConfig m payload <-
        transactionalWorkerConfig
          1
          (mkHandler (\JobRead payload
_job -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
doneRef Bool
True) m () -> m (Maybe [Text]) -> m (Maybe [Text])
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe [Text] -> m (Maybe [Text])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"unkept"] :: Maybe [Text])))
      void $ runM env $ HL.insertJob (defaultJob (mkSimple "no-arch-result"))

      withAsync (runM env $ runWorkerPool cfg {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
doneRef
        Int -> IO ()
threadDelay Int
settleMicros
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        map (payload . Archive.jobSnapshot) arch `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"stores a child's result in the tree and leaves its archive row bare" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      cfg :: WorkerConfig m payload <-
        Int
-> JobHandler m payload (ResultOf m payload)
-> IO (WorkerConfig m payload)
forall (n :: * -> *) (m :: * -> *) payload.
(MonadArbiter n, MonadIO m) =>
Int
-> JobHandler n payload (ResultOf n payload)
-> m (WorkerConfig n payload)
transactionalWorkerConfig Int
1 ((JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler (\JobRead payload
_job -> Maybe [Text] -> m (Maybe [Text])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"child-result"] :: Maybe [Text])))
      let child = 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) (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
mkSimple Text
"arch-child")
      void $ runM env $ HL.insertJobTree $ defaultJob (mkSimple "arch-root") <~~ (child :| [])

      withAsync (runM env $ runWorkerPool cfg {workerCount = 2, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ArchiveJob payload) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ArchiveJob payload) -> Bool)
-> IO (Maybe (ArchiveJob payload)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"arch-child"
        childRow <- env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"arch-child"
        (Archive.archivedResult =<< childRow) `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"preserves the attempt count on the archived row" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      config <- mkConfig $ \JobRead payload
_job -> do
        call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
        when (call == 1) $ throwRetryable "fail once"
      void
        $ runM env
        $ HL.insertJob
          ( setArchiveFor (Just dayRetention)
              $ setMaxAttempts (Just 5)
              $ setGroupKey (Just "aa")
              $ defaultJob (mkSimple "arch-attempts")
          )

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1, jitter = NoJitter}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (ArchiveJob payload) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ArchiveJob payload) -> Bool)
-> IO (Maybe (ArchiveJob payload)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"arch-attempts"
        mine <- env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
"arch-attempts"
        -- Claimed twice, one retryable failure and then success. The ack-copy
        -- carries attempts = 2.
        fmap (attempts . Archive.jobSnapshot) mine `shouldBe` Just 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"preserves a child's parent linkage on its archived row" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      cfg :: WorkerConfig m payload <-
        Int
-> JobHandler m payload (ResultOf m payload)
-> IO (WorkerConfig m payload)
forall (n :: * -> *) (m :: * -> *) payload.
(MonadArbiter n, MonadIO m) =>
Int
-> JobHandler n payload (ResultOf n payload)
-> m (WorkerConfig n payload)
transactionalWorkerConfig Int
1 ((JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler (\JobRead payload
_job -> Maybe [Text] -> m (Maybe [Text])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"ok"] :: Maybe [Text])))
      let child = 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) (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
mkSimple Text
"pl-child")
          root = 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) (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
mkSimple Text
"pl-root")
      void $ runM env $ HL.insertJobTree $ root <~~ (child :| [])

      withAsync (runM env $ runWorkerPool cfg {workerCount = 2, pollInterval = 0.1}) $ \Async ()
_ -> do
        let snap :: Text -> [ArchiveJob payload] -> Maybe (JobRead payload)
snap Text
name [ArchiveJob payload]
arch = ArchiveJob payload -> JobRead payload
forall payload. ArchiveJob payload -> JobSnapshot payload
Archive.jobSnapshot (ArchiveJob payload -> JobRead payload)
-> Maybe (ArchiveJob payload) -> Maybe (JobRead payload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ArchiveJob payload -> Bool)
-> [ArchiveJob payload] -> Maybe (ArchiveJob 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
mkSimple Text
name) (payload -> Bool)
-> (ArchiveJob payload -> payload) -> ArchiveJob 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)
-> (ArchiveJob payload -> JobRead payload)
-> ArchiveJob payload
-> payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveJob payload -> JobRead payload
forall payload. ArchiveJob payload -> JobSnapshot payload
Archive.jobSnapshot) [ArchiveJob payload]
arch
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          arch <- env -> IO [ArchiveJob payload]
archived env
env
          pure (isJust (snap "pl-child" arch) && isJust (snap "pl-root" arch))
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        -- The child's archived parent_id points at the root's original job id.
        (parentId =<< snap "pl-child" arch) `shouldBe` (primaryKey <$> snap "pl-root" arch)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reaper purges only expired archived rows, keeping live ones" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      runM env $
        traverse_
          HL.insertJob
          [ setArchiveFor (Just 1) $ setGroupKey (Just "pe1") $ defaultJob (mkSimple "purge-expired")
          , setArchiveFor (Just dayRetention) $ setGroupKey (Just "pe2") $ defaultJob (mkSimple "purge-kept")
          ]

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1, reaperInterval = 0.5}) $ \Async ()
_ -> do
        let has :: Text -> [ArchiveJob payload] -> Bool
has Text
name [ArchiveJob payload]
arch = (ArchiveJob payload -> Bool) -> [ArchiveJob payload] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkSimple Text
name) (payload -> Bool)
-> (ArchiveJob payload -> payload) -> ArchiveJob 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)
-> (ArchiveJob payload -> JobRead payload)
-> ArchiveJob payload
-> payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveJob payload -> JobRead payload
forall payload. ArchiveJob payload -> JobSnapshot payload
Archive.jobSnapshot) [ArchiveJob payload]
arch
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          arch <- env -> IO [ArchiveJob payload]
archived env
env
          pure (has "purge-expired" arch && has "purge-kept" arch)
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          arch <- env -> IO [ArchiveJob payload]
archived env
env
          pure (not (has "purge-expired" arch))
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        has "purge-kept" arch `shouldBe` True

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not archive a job whose archiveFor is zero" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      doneRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
      config <- mkConfig $ \JobRead payload
_job -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
doneRef Bool
True
      void $ runM env $ HL.insertJob (setArchiveFor (Just 0) $ setGroupKey (Just "z1") $ defaultJob (mkSimple "zero-arch"))

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
doneRef
        Int -> IO ()
threadDelay Int
settleMicros
        arch <- env -> IO [ArchiveJob payload]
archived env
env
        map (payload . Archive.jobSnapshot) arch `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"processes all 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
      processingRef <- [Maybe Text] -> IO (IORef [Maybe Text])
forall a. a -> IO (IORef a)
newIORef []
      config <- mkConfig $ \JobRead payload
job -> do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Maybe Text] -> ([Maybe Text] -> ([Maybe Text], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe Text]
processingRef (([Maybe Text] -> ([Maybe Text], ())) -> IO ())
-> ([Maybe Text] -> ([Maybe Text], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Maybe Text]
groups -> (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] -> [Maybe Text]
forall a. a -> [a] -> [a]
: [Maybe Text]
groups, ())
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
groupHandlerMicros
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g2") (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
mkSimple Text
"G2-1")
            , 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
"g3") (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
mkSimple Text
"G3-1")
            ]

      runM env $ traverse_ HL.insertJob jobs

      withAsync (runM env $ runWorkerPool config {workerCount = 3, pollInterval = 0.05}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3) (Int -> Bool) -> ([Maybe Text] -> Int) -> [Maybe Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Maybe Text] -> Bool) -> IO [Maybe Text] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Maybe Text] -> IO [Maybe Text]
forall a. IORef a -> IO a
readIORef IORef [Maybe Text]
processingRef
        processed <- IORef [Maybe Text] -> IO [Maybe Text]
forall a. IORef a -> IO a
readIORef IORef [Maybe Text]
processingRef
        length processed `shouldBe` 3
        processed `shouldMatchList` [Just "g1", Just "g2", Just "g3"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retries once then DLQs at maxAttempts 2" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      attemptsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      retryRef <- newIORef (0 :: Int)
      dlqRef <- newIORef (0 :: Int)
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobRetry = \JobRead payload
_ NominalDiffTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
retryRef
              , onJobFailedAndMovedToDLQ = \JobRead payload
_ Text
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
dlqRef
              }
      config <- mkConfig $ \JobRead payload
_job -> do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
attemptsRef
        Text -> m ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwRetryable Text
"always fails"

      let 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
"g1") (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
mkSimple Text
"Boundary")
      void $ runM env $ HL.insertJob job

      withAsync
        (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1, jitter = NoJitter, observabilityHooks = hooks})
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
retryRef
          dlqAfterFirst <- env -> IO [DLQJob payload]
dlqAll env
env
          length dlqAfterFirst `shouldBe` 0

          waitUntil 10_000 $ (== 1) <$> readIORef dlqRef
          dlqJobs <- dlqAll env
          length dlqJobs `shouldBe` 1
          attempts (DLQ.jobSnapshot (head dlqJobs)) `shouldBe` 2
          readIORef attemptsRef `shouldReturn` 2
          readIORef retryRef `shouldReturn` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"permanent exception goes straight to DLQ on first attempt" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      retryCalls <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      dlqCalls <- newIORef (0 :: Int)
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobRetry = \JobRead payload
_ NominalDiffTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
retryCalls
              , onJobFailedAndMovedToDLQ = \JobRead payload
_ Text
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
dlqCalls
              }
      config <- mkConfig $ \JobRead payload
_job -> Text -> m ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwPermanent Text
"Unrecoverable error"

      void $ runM env $ HL.insertJob (defaultJob (mkSimple "PermanentFail"))

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1, observabilityHooks = hooks}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
dlqCalls
        retryCount <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
retryCalls
        retryCount `shouldBe` 0
        dlqJobs <- dlqAll env
        length dlqJobs `shouldBe` 1
        payload (DLQ.jobSnapshot (head dlqJobs)) `shouldBe` mkSimple "PermanentFail"
        attempts (DLQ.jobSnapshot (head dlqJobs)) `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"heartbeat keeps leases alive when every worker holds a long transaction" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- workerCnt stays below the shared pool size, leaving connections for
      -- heartbeat queries.
      let workerCnt :: Int
workerCnt = Int
3
      let jobNames :: [Text]
jobNames = [Text
"long-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show @Int Int
index) | Int
index <- [Int
1 .. Int
workerCnt]]
      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 -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Text
name -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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
mkSimple Text
name))) [Text]
jobNames
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
longHandlerMicros

      withAsync
        ( runM env $
            runWorkerPool
              config
                { workerCount = workerCnt
                , visibilityTimeout = 3
                , jobHeartbeatInterval = 1
                , pollInterval = 0.1
                , jitter = NoJitter
                }
        )
        $ \Async ()
_ -> do
          Int -> IO ()
threadDelay Int
leaseOutlastMicros
          reclaimed <-
            env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (m [JobRead payload] -> IO [JobRead payload])
-> m [JobRead payload] -> IO [JobRead payload]
forall a b. (a -> b) -> a -> b
$
              forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs @payload Int
workerCnt NominalDiffTime
3
          length reclaimed `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"completing a job acks it and fires onJobSuccess" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      successRef <- [Int64] -> IO (IORef [Int64])
forall a. a -> IO (IORef a)
newIORef ([] :: [Int64])
      let handler (JobRead payload
job :| [JobRead payload]
_) BatchCallbacks m payload result
cbs = BatchCallbacks m payload result -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload result
cbs JobRead payload
job
          hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
job ClaimTime
_ ClaimTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int64] -> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int64]
successRef (([Int64] -> ([Int64], ())) -> IO ())
-> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int64]
seen -> (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
seen, ())
              }
      void $ runM env $ HL.insertJob (defaultJob (mkSimple "ManualAckSuccess"))
      config <- mkBatchedConfig 1 1 handler
      let manualConfig = WorkerConfig m payload
config {pollInterval = 0.1, observabilityHooks = hooks}

      withAsync (runM env $ runWorkerPool manualConfig) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)

      runM env (HL.countJobs @payload) `shouldReturn` 0
      successes <- readIORef successRef
      length successes `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"completing a reclaimed job skips without firing onJobSuccess" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      successRef <- [Int64] -> IO (IORef [Int64])
forall a. a -> IO (IORef a)
newIORef ([] :: [Int64])
      let handler (JobRead payload
job :| [JobRead payload]
_) BatchCallbacks m payload result
cbs = do
            m Int64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Int64 -> m ()) -> m Int64 -> m ()
forall a b. (a -> b) -> a -> b
$ JobRead payload -> m Int64
forall payload (m :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job
            BatchCallbacks m payload result -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload result
cbs JobRead payload
job
          hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
job ClaimTime
_ ClaimTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int64] -> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int64]
successRef (([Int64] -> ([Int64], ())) -> IO ())
-> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int64]
seen -> (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
seen, ())
              }
      void $ runM env $ HL.insertJob (defaultJob (mkSimple "ManualReclaimed"))
      config <- mkBatchedConfig 1 1 handler
      let manualConfig = WorkerConfig m payload
config {pollInterval = 0.1, observabilityHooks = hooks}

      withAsync (runM env $ runWorkerPool manualConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
        Int -> IO ()
threadDelay Int
afterDrainMicros

      successes <- readIORef successRef
      length successes `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"failing a job acked elsewhere skips without firing onJobRetry" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      retryRef <- [Int64] -> IO (IORef [Int64])
forall a. a -> IO (IORef a)
newIORef ([] :: [Int64])
      let handler (JobRead payload
job :| [JobRead payload]
_) p
_cbs = do
            m Int64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Int64 -> m ()) -> m Int64 -> m ()
forall a b. (a -> b) -> a -> b
$ JobRead payload -> m Int64
forall payload (m :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob JobRead payload
job
            Text -> m b
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwRetryable Text
"failed after the job was gone"
          hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobRetry = \JobRead payload
job NominalDiffTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int64] -> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int64]
retryRef (([Int64] -> ([Int64], ())) -> IO ())
-> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int64]
seen -> (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
seen, ())
              }
      void $ runM env $ HL.insertJob (setMaxAttempts (Just 5) $ defaultJob (mkSimple "FailedAfterGone"))
      config <- mkBatchedConfig 1 1 handler
      let manualConfig = WorkerConfig m payload
config {pollInterval = 0.1, observabilityHooks = hooks}

      withAsync (runM env $ runWorkerPool manualConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
        Int -> IO ()
threadDelay Int
afterDrainMicros

      readIORef retryRef `shouldReturn` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ackWith and ackAllWith store each job's result on its archive row" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let handler :: NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
handler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            let ([JobRead payload]
single, [JobRead payload]
batch) = (JobRead payload -> Bool)
-> [JobRead payload] -> ([JobRead payload], [JobRead payload])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkSimple Text
"aw-1") (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]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\JobRead payload
job -> BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> Maybe [Text] -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> result -> m ()
ackWith BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"first"])) [JobRead payload]
single
            BatchCallbacks m payload (Maybe [Text])
-> [(JobRead payload, Maybe [Text])] -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> [(JobRead payload, result)] -> m ()
ackAllWith BatchCallbacks m payload (Maybe [Text])
cbs ((JobRead payload -> (JobRead payload, Maybe [Text]))
-> [JobRead payload] -> [(JobRead payload, Maybe [Text])]
forall a b. (a -> b) -> [a] -> [b]
map (\JobRead payload
job -> (JobRead payload
job, [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"rest"])) [JobRead payload]
batch)
      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 -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
          (\Text
name -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (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) (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
"aw") (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
mkSimple Text
name)))
          [Text
"aw-1", Text
"aw-2", Text
"aw-3"]
      config <- Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks m payload (ResultOf m payload) -> m ())
-> IO (WorkerConfig m payload)
mkBatchedConfig Int
1 Int
3 NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
NonEmpty (JobRead payload)
-> BatchCallbacks m payload (ResultOf m payload) -> m ()
handler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.1, jitter = NoJitter}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)

      arch <- archived env
      let resultFor Text
name = ArchiveJob payload -> Maybe Value
forall payload. ArchiveJob payload -> Maybe Value
Archive.archivedResult (ArchiveJob payload -> Maybe Value)
-> Maybe (ArchiveJob payload) -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ArchiveJob payload -> Bool)
-> [ArchiveJob payload] -> Maybe (ArchiveJob 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
mkSimple Text
name) (payload -> Bool)
-> (ArchiveJob payload -> payload) -> ArchiveJob 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)
-> (ArchiveJob payload -> JobRead payload)
-> ArchiveJob payload
-> payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveJob payload -> JobRead payload
forall payload. ArchiveJob payload -> JobSnapshot payload
Archive.jobSnapshot) [ArchiveJob payload]
arch
      resultFor "aw-1" `shouldBe` Just (toJSON ["first" :: Text])
      resultFor "aw-2" `shouldBe` Just (toJSON ["rest" :: Text])
      resultFor "aw-3" `shouldBe` Just (toJSON ["rest" :: Text])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ackWith stores each result only on its own job's archive row" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let resultOf :: Job payload a q insertedAt adm -> Maybe [Text]
resultOf Job payload a q insertedAt adm
job = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show (Job payload a q insertedAt adm -> a
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey Job payload a q insertedAt adm
job))]
          handler :: t (JobRead payload)
-> BatchCallbacks f payload (Maybe [Text]) -> f ()
handler t (JobRead payload)
jobs BatchCallbacks f payload (Maybe [Text])
cbs = (JobRead payload -> f ()) -> [JobRead payload] -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\JobRead payload
job -> BatchCallbacks f payload (Maybe [Text])
-> JobRead payload -> Maybe [Text] -> f ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> result -> m ()
ackWith BatchCallbacks f payload (Maybe [Text])
cbs JobRead payload
job (JobRead payload -> Maybe [Text]
forall {a} {payload} {q} {insertedAt} {adm}.
Show a =>
Job payload a q insertedAt adm -> Maybe [Text]
resultOf JobRead payload
job)) (t (JobRead payload) -> [JobRead payload]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (JobRead payload)
jobs)
      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 -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
          (\Text
name -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (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) (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
"ow") (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
mkSimple Text
name)))
          [Text
"ow-1", Text
"ow-2", Text
"ow-3"]
      config <- Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks m payload (ResultOf m payload) -> m ())
-> IO (WorkerConfig m payload)
mkBatchedConfig Int
1 Int
3 NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
NonEmpty (JobRead payload)
-> BatchCallbacks m payload (ResultOf m payload) -> m ()
forall {f :: * -> *} {t :: * -> *} {payload}.
(Applicative f, Foldable t) =>
t (JobRead payload)
-> BatchCallbacks f payload (Maybe [Text]) -> f ()
handler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.1, jitter = NoJitter}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)

      arch <- archived env
      length arch `shouldBe` 3
      for_ arch $ \ArchiveJob payload
row ->
        ArchiveJob payload -> Maybe Value
forall payload. ArchiveJob payload -> Maybe Value
Archive.archivedResult ArchiveJob payload
row Maybe Value -> Maybe Value -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Value -> Maybe Value
forall a. a -> Maybe a
Just (Maybe [Text] -> Value
forall a. ToJSON a => a -> Value
toJSON (JobRead payload -> Maybe [Text]
forall {a} {payload} {q} {insertedAt} {adm}.
Show a =>
Job payload a q insertedAt adm -> Maybe [Text]
resultOf (ArchiveJob payload -> JobRead payload
forall payload. ArchiveJob payload -> JobSnapshot payload
Archive.jobSnapshot ArchiveJob payload
row)))

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch ack archives only the jobs with a positive archiveFor" ((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 (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ((Text, Maybe Int32) -> m ()) -> [(Text, Maybe Int32)] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
          (\(Text
name, Maybe Int32
window) -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (Maybe Int32 -> JobWrite payload -> JobWrite payload
forall payload. Maybe Int32 -> JobWrite payload -> JobWrite payload
setArchiveFor Maybe Int32
window (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
"pw") (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
mkSimple Text
name)))
          [(Text
"pw-kept", Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
dayRetention), (Text
"pw-zero", Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
0), (Text
"pw-unset", Maybe Int32
forall a. Maybe a
Nothing)]
      config <- Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks m payload (ResultOf m payload) -> m ())
-> IO (WorkerConfig m payload)
mkBatchedConfig Int
1 Int
3 (\NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (ResultOf m payload)
cbs -> BatchCallbacks m payload (Maybe [Text])
-> [JobRead payload] -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> [JobRead payload] -> m ()
ackAll BatchCallbacks m payload (Maybe [Text])
BatchCallbacks m payload (ResultOf m payload)
cbs (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs))

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.1, jitter = NoJitter}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)

      arch <- archived env
      map (payload . Archive.jobSnapshot) arch `shouldBe` [mkSimple "pw-kept"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-enqueues only the named archive row" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      runM env $
        traverse_
          (\Text
name -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (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) (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
name) (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
mkSimple Text
name)))
          ["one-a", "one-b"]

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool)
-> ([ArchiveJob payload] -> Int) -> [ArchiveJob payload] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ArchiveJob payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ArchiveJob payload] -> Bool)
-> IO [ArchiveJob payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> IO [ArchiveJob payload]
archived env
env

      Just row <- archivedNamed env "one-a"
      void $ runM env $ HL.reEnqueueFromArchive @payload (Archive.archivePrimaryKey row)
      queued <- runM env $ HL.listJobs @payload 100 0
      map payload queued `shouldBe` [mkSimple "one-a"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"bulk-purges only the named archive rows" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      runM env $
        traverse_
          (\Text
name -> m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (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) (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
name) (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
mkSimple Text
name)))
          ["bn-gone", "bn-kept"]

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool)
-> ([ArchiveJob payload] -> Int) -> [ArchiveJob payload] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ArchiveJob payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ArchiveJob payload] -> Bool)
-> IO [ArchiveJob payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> IO [ArchiveJob payload]
archived env
env

      Just row <- archivedNamed env "bn-gone"
      deleted <- runM env $ HL.deleteArchiveJobsBatch @payload [Archive.archivePrimaryKey row]
      deleted `shouldBe` 1
      arch <- archived env
      map (payload . Archive.jobSnapshot) arch `shouldBe` [mkSimple "bn-kept"]

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Group Ordering" (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
"processes jobs in the same group serially" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      orderRef <- [payload] -> IO (IORef [payload])
forall a. a -> IO (IORef a)
newIORef []
      activeRef <- newIORef (0 :: Int)
      maxActiveRef <- newIORef (0 :: Int)
      config <- mkConfig $ \JobRead payload
job -> do
        active <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
activeRef ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
count -> let count' :: Int
count' = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 in (Int
count', Int
count')
        liftIO $ atomicModifyIORef' maxActiveRef $ \Int
maxN -> (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
maxN Int
active, ())
        liftIO $ threadDelay shortHandlerMicros
        liftIO $ atomicModifyIORef' orderRef $ \[payload]
order -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
order, ())
        liftIO $ atomicModifyIORef' activeRef $ \Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, ())
      let 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
"g1") (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
mkSimple Text
"First")
            , 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
"g1") (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
mkSimple Text
"Second")
            , 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
"g1") (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
mkSimple Text
"Third")
            ]

      runM env $ traverse_ HL.insertJob jobs

      withAsync (runM env $ runWorkerPool config {workerCount = 3, pollInterval = 0.05}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3) (Int -> Bool) -> ([payload] -> Int) -> [payload] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([payload] -> Bool) -> IO [payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
orderRef
        order <- IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
orderRef
        length order `shouldBe` 3
        reverse order `shouldBe` [mkSimple "First", mkSimple "Second", mkSimple "Third"]
        maxActive <- readIORef maxActiveRef
        maxActive `shouldBe` 1

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Observability Hooks" (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
"onJobClaimed is called with start time when job is claimed" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      claimedRef <- [(Int64, ClaimTime)] -> IO (IORef [(Int64, ClaimTime)])
forall a. a -> IO (IORef a)
newIORef []
      successRef <- newIORef []
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobClaimed = \JobRead payload
job ClaimTime
startTime -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [(Int64, ClaimTime)]
-> ([(Int64, ClaimTime)] -> ([(Int64, ClaimTime)], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [(Int64, ClaimTime)]
claimedRef (([(Int64, ClaimTime)] -> ([(Int64, ClaimTime)], ())) -> IO ())
-> ([(Int64, ClaimTime)] -> ([(Int64, ClaimTime)], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Int64, ClaimTime)]
jobs -> ((JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job, ClaimTime
startTime) (Int64, ClaimTime) -> [(Int64, ClaimTime)] -> [(Int64, ClaimTime)]
forall a. a -> [a] -> [a]
: [(Int64, ClaimTime)]
jobs, ())
              , onJobSuccess = \JobRead payload
_ ClaimTime
startTime ClaimTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [ClaimTime] -> ([ClaimTime] -> ([ClaimTime], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [ClaimTime]
successRef (([ClaimTime] -> ([ClaimTime], ())) -> IO ())
-> ([ClaimTime] -> ([ClaimTime], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[ClaimTime]
times -> (ClaimTime
startTime ClaimTime -> [ClaimTime] -> [ClaimTime]
forall a. a -> [a] -> [a]
: [ClaimTime]
times, ())
              }
      config <- mkConfig $ \JobRead payload
_job -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      let configWithHooks = WorkerConfig m payload
config {observabilityHooks = hooks, workerCount = 1, pollInterval = 0.1}

      let 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
"g1") (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
mkSimple Text
"Test")
      Just inserted <- runM env $ HL.insertJob job

      withAsync (runM env $ runWorkerPool configWithHooks) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool)
-> ([(Int64, ClaimTime)] -> Int) -> [(Int64, ClaimTime)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int64, ClaimTime)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Int64, ClaimTime)] -> Bool)
-> IO [(Int64, ClaimTime)] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(Int64, ClaimTime)] -> IO [(Int64, ClaimTime)]
forall a. IORef a -> IO a
readIORef IORef [(Int64, ClaimTime)]
claimedRef
        claimed <- IORef [(Int64, ClaimTime)] -> IO [(Int64, ClaimTime)]
forall a. IORef a -> IO a
readIORef IORef [(Int64, ClaimTime)]
claimedRef
        length claimed `shouldBe` 1
        waitUntil 10_000 $ (== 1) . length <$> readIORef successRef
        successTimes <- readIORef successRef
        let (claimedId, claimedStart) = head claimed
        -- onJobClaimed fires for the claimed job, before processing starts.
        claimedId `shouldBe` primaryKey inserted
        claimedStart `shouldSatisfy` (<= head successTimes)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"onJobSuccess is called with start and end times" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      successRef <- [(Int64, ClaimTime, ClaimTime)]
-> IO (IORef [(Int64, ClaimTime, ClaimTime)])
forall a. a -> IO (IORef a)
newIORef []
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
job ClaimTime
startTime ClaimTime
endTime ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [(Int64, ClaimTime, ClaimTime)]
-> ([(Int64, ClaimTime, ClaimTime)]
    -> ([(Int64, ClaimTime, ClaimTime)], ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [(Int64, ClaimTime, ClaimTime)]
successRef (([(Int64, ClaimTime, ClaimTime)]
  -> ([(Int64, ClaimTime, ClaimTime)], ()))
 -> IO ())
-> ([(Int64, ClaimTime, ClaimTime)]
    -> ([(Int64, ClaimTime, ClaimTime)], ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Int64, ClaimTime, ClaimTime)]
results -> ((JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job, ClaimTime
startTime, ClaimTime
endTime) (Int64, ClaimTime, ClaimTime)
-> [(Int64, ClaimTime, ClaimTime)]
-> [(Int64, ClaimTime, ClaimTime)]
forall a. a -> [a] -> [a]
: [(Int64, ClaimTime, ClaimTime)]
results, ())
              }
      config <- mkConfig $ \JobRead payload
_job -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
shortHandlerMicros
      let configWithHooks = WorkerConfig m payload
config {observabilityHooks = hooks, workerCount = 1, pollInterval = 0.1}

      let 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
"g1") (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
mkSimple Text
"Test")
      void $ runM env $ HL.insertJob job

      withAsync (runM env $ runWorkerPool configWithHooks) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool)
-> ([(Int64, ClaimTime, ClaimTime)] -> Int)
-> [(Int64, ClaimTime, ClaimTime)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int64, ClaimTime, ClaimTime)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Int64, ClaimTime, ClaimTime)] -> Bool)
-> IO [(Int64, ClaimTime, ClaimTime)] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(Int64, ClaimTime, ClaimTime)]
-> IO [(Int64, ClaimTime, ClaimTime)]
forall a. IORef a -> IO a
readIORef IORef [(Int64, ClaimTime, ClaimTime)]
successRef
        results <- IORef [(Int64, ClaimTime, ClaimTime)]
-> IO [(Int64, ClaimTime, ClaimTime)]
forall a. IORef a -> IO a
readIORef IORef [(Int64, ClaimTime, ClaimTime)]
successRef
        length results `shouldBe` 1
        let (_, startTime, endTime) = head results
        endTime `shouldSatisfy` (> startTime)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"onJobFailure is called with start and end times on failure" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      failureRef <- [(Int64, ClaimTime, ClaimTime)]
-> IO (IORef [(Int64, ClaimTime, ClaimTime)])
forall a. a -> IO (IORef a)
newIORef []
      successRef <- newIORef (0 :: Int)
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobFailure = \JobRead payload
job Text
_err ClaimTime
startTime ClaimTime
endTime ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [(Int64, ClaimTime, ClaimTime)]
-> ([(Int64, ClaimTime, ClaimTime)]
    -> ([(Int64, ClaimTime, ClaimTime)], ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [(Int64, ClaimTime, ClaimTime)]
failureRef (([(Int64, ClaimTime, ClaimTime)]
  -> ([(Int64, ClaimTime, ClaimTime)], ()))
 -> IO ())
-> ([(Int64, ClaimTime, ClaimTime)]
    -> ([(Int64, ClaimTime, ClaimTime)], ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Int64, ClaimTime, ClaimTime)]
results -> ((JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job, ClaimTime
startTime, ClaimTime
endTime) (Int64, ClaimTime, ClaimTime)
-> [(Int64, ClaimTime, ClaimTime)]
-> [(Int64, ClaimTime, ClaimTime)]
forall a. a -> [a] -> [a]
: [(Int64, ClaimTime, ClaimTime)]
results, ())
              , onJobSuccess = \JobRead payload
_ ClaimTime
_ ClaimTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
successRef
              }
      config <- mkConfig $ \JobRead payload
_job -> do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
shortHandlerMicros
        Text -> m ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwRetryable Text
"Test failure"
      let configWithHooks = WorkerConfig m payload
config {observabilityHooks = hooks, workerCount = 1, pollInterval = 0.1}

      let 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
1) (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
"g1") (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
mkSimple Text
"Test")
      void $ runM env $ HL.insertJob job

      withAsync (runM env $ runWorkerPool configWithHooks) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool)
-> ([(Int64, ClaimTime, ClaimTime)] -> Int)
-> [(Int64, ClaimTime, ClaimTime)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int64, ClaimTime, ClaimTime)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Int64, ClaimTime, ClaimTime)] -> Bool)
-> IO [(Int64, ClaimTime, ClaimTime)] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(Int64, ClaimTime, ClaimTime)]
-> IO [(Int64, ClaimTime, ClaimTime)]
forall a. IORef a -> IO a
readIORef IORef [(Int64, ClaimTime, ClaimTime)]
failureRef
        results <- IORef [(Int64, ClaimTime, ClaimTime)]
-> IO [(Int64, ClaimTime, ClaimTime)]
forall a. IORef a -> IO a
readIORef IORef [(Int64, ClaimTime, ClaimTime)]
failureRef
        length results `shouldBe` 1
        let (_, startTime, endTime) = head results
        endTime `shouldSatisfy` (> startTime)
        -- A failing job never fires the success hook.
        readIORef successRef >>= (`shouldBe` 0)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"onJobHeartbeat is called periodically during job execution" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      heartbeatRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobHeartbeat = \JobRead payload
_ ClaimTime
_currentTime ClaimTime
_startTime ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
heartbeatRef
              }
      config <- mkConfig $ \JobRead payload
_job -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
heartbeatHandlerMicros
      let configWithHooks =
            WorkerConfig m payload
config
              { observabilityHooks = hooks
              , workerCount = 1
              , pollInterval = 0.1
              , jobHeartbeatInterval = 1
              }

      let 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
"g1") (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
mkSimple Text
"LongRunning")
      void $ runM env $ HL.insertJob job

      withAsync (runM env $ runWorkerPool configWithHooks) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
heartbeatRef
        heartbeatCount <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
heartbeatRef
        heartbeatCount `shouldSatisfy` (>= 2)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"onJobRetry is called with backoff delay on retriable failure" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      retryRef <- [(Int64, NominalDiffTime)] -> IO (IORef [(Int64, NominalDiffTime)])
forall a. a -> IO (IORef a)
newIORef []
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobRetry = \JobRead payload
job NominalDiffTime
backoff ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [(Int64, NominalDiffTime)]
-> ([(Int64, NominalDiffTime)] -> ([(Int64, NominalDiffTime)], ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [(Int64, NominalDiffTime)]
retryRef (([(Int64, NominalDiffTime)] -> ([(Int64, NominalDiffTime)], ()))
 -> IO ())
-> ([(Int64, NominalDiffTime)] -> ([(Int64, NominalDiffTime)], ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Int64, NominalDiffTime)]
seen -> ((JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job, NominalDiffTime
backoff) (Int64, NominalDiffTime)
-> [(Int64, NominalDiffTime)] -> [(Int64, NominalDiffTime)]
forall a. a -> [a] -> [a]
: [(Int64, NominalDiffTime)]
seen, ())
              }
      config <- mkConfig $ \JobRead payload
_job -> Text -> m ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwRetryable Text
"retry me"
      let configWithHooks = WorkerConfig m payload
config {observabilityHooks = hooks, workerCount = 1, pollInterval = 0.1}

      let 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
3) (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
"g1") (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
mkSimple Text
"RetryHook")
      void $ runM env $ HL.insertJob job

      withAsync (runM env $ runWorkerPool configWithHooks) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool)
-> ([(Int64, NominalDiffTime)] -> Int)
-> [(Int64, NominalDiffTime)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int64, NominalDiffTime)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Int64, NominalDiffTime)] -> Bool)
-> IO [(Int64, NominalDiffTime)] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(Int64, NominalDiffTime)] -> IO [(Int64, NominalDiffTime)]
forall a. IORef a -> IO a
readIORef IORef [(Int64, NominalDiffTime)]
retryRef
        retries <- IORef [(Int64, NominalDiffTime)] -> IO [(Int64, NominalDiffTime)]
forall a. IORef a -> IO a
readIORef IORef [(Int64, NominalDiffTime)]
retryRef
        length retries `shouldBe` 2
        traverse_ (\(Int64
_, NominalDiffTime
backoff) -> NominalDiffTime
backoff NominalDiffTime -> (NominalDiffTime -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` (NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0)) retries

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"throwRetryableAfter retries after its delay in place of the backoff" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      retryRef <- [NominalDiffTime] -> IO (IORef [NominalDiffTime])
forall a. a -> IO (IORef a)
newIORef []
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobRetry = \JobRead payload
_ NominalDiffTime
delay -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [NominalDiffTime]
-> ([NominalDiffTime] -> ([NominalDiffTime], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [NominalDiffTime]
retryRef (([NominalDiffTime] -> ([NominalDiffTime], ())) -> IO ())
-> ([NominalDiffTime] -> ([NominalDiffTime], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[NominalDiffTime]
seen -> (NominalDiffTime
delay NominalDiffTime -> [NominalDiffTime] -> [NominalDiffTime]
forall a. a -> [a] -> [a]
: [NominalDiffTime]
seen, ())
              }
      config <- mkConfig $ \JobRead payload
_job -> NominalDiffTime -> Text -> m ()
forall (m :: * -> *) a. MonadIO m => NominalDiffTime -> Text -> m a
throwRetryableAfter NominalDiffTime
3600 Text
"rate limited"
      Just inserted <- runM env $ HL.insertJob (setMaxAttempts (Just 3) $ defaultJob (mkSimple "retry-after"))
      before' <- getCurrentTime

      withAsync
        ( runM env $
            runWorkerPool
              config
                { observabilityHooks = hooks
                , workerCount = 1
                , pollInterval = 0.1
                , backoffStrategy = Constant 0
                , jitter = NoJitter
                }
        )
        $ \Async ()
_ -> HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool)
-> ([NominalDiffTime] -> Bool) -> [NominalDiffTime] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NominalDiffTime] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([NominalDiffTime] -> Bool) -> IO [NominalDiffTime] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [NominalDiffTime] -> IO [NominalDiffTime]
forall a. IORef a -> IO a
readIORef IORef [NominalDiffTime]
retryRef

      readIORef retryRef `shouldReturn` [3600]
      Just parked <- runM env (HL.getJobById @payload (primaryKey inserted))
      attempts parked `shouldBe` 1
      lastError parked `shouldBe` Just "rate limited"
      notVisibleUntil parked `shouldSatisfy` maybe False (> addUTCTime 3500 before')

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"throwNackAfter parks the job without using an attempt" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      config <- mkConfig $ \JobRead payload
_job -> do
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
callsRef
        NominalDiffTime -> m ()
forall (m :: * -> *) a. MonadIO m => NominalDiffTime -> m a
throwNackAfter NominalDiffTime
3600
      Just inserted <- runM env $ HL.insertJob (defaultJob (mkSimple "nack-after"))
      before' <- getCurrentTime
      let parked = do
            Just job <- 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 (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
inserted))
            pure (attempts job == 0 && isNothing (claimedBy job) && maybe False (> addUTCTime 3500 before') (notVisibleUntil job))

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 IO Bool
parked

      readIORef callsRef `shouldReturn` 1
      Just job <- runM env (HL.getJobById @payload (primaryKey inserted))
      lastError job `shouldBe` Nothing

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"onJobFailedAndMovedToDLQ is called when job exhausts retries" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      dlqRef <- [(Text, Int64)] -> IO (IORef [(Text, Int64)])
forall a. a -> IO (IORef a)
newIORef []
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobFailedAndMovedToDLQ = \JobRead payload
job Text
errMsg ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [(Text, Int64)]
-> ([(Text, Int64)] -> ([(Text, Int64)], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [(Text, Int64)]
dlqRef (([(Text, Int64)] -> ([(Text, Int64)], ())) -> IO ())
-> ([(Text, Int64)] -> ([(Text, Int64)], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Text, Int64)]
seen -> ((Text
errMsg, JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job) (Text, Int64) -> [(Text, Int64)] -> [(Text, Int64)]
forall a. a -> [a] -> [a]
: [(Text, Int64)]
seen, ())
              }
      config <- mkConfig $ \JobRead payload
_job -> Text -> m ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwRetryable Text
"always fails"
      let configWithHooks = WorkerConfig m payload
config {observabilityHooks = hooks, workerCount = 1, pollInterval = 0.1}

      let 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
1) (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
"g1") (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
mkSimple Text
"DLQHook")
      void $ runM env $ HL.insertJob job

      withAsync (runM env $ runWorkerPool configWithHooks) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool)
-> ([(Text, Int64)] -> Int) -> [(Text, Int64)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Int64)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Text, Int64)] -> Bool) -> IO [(Text, Int64)] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(Text, Int64)] -> IO [(Text, Int64)]
forall a. IORef a -> IO a
readIORef IORef [(Text, Int64)]
dlqRef
        dlqCalls <- IORef [(Text, Int64)] -> IO [(Text, Int64)]
forall a. IORef a -> IO a
readIORef IORef [(Text, Int64)]
dlqRef
        length dlqCalls `shouldBe` 1
        let (errMsg, _) = head dlqCalls
        errMsg `shouldBe` "always fails"

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Batched Job Mode" (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
"processes a batch of jobs from the same group together" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      batchesRef <- [[payload]] -> IO (IORef [[payload]])
forall a. a -> IO (IORef a)
newIORef []
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            let payloads :: [payload]
payloads = (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 (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [[payload]] -> ([[payload]] -> ([[payload]], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [[payload]]
batchesRef (([[payload]] -> ([[payload]], ())) -> IO ())
-> ([[payload]] -> ([[payload]], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[[payload]]
batches -> ([payload]
payloads [payload] -> [[payload]] -> [[payload]]
forall a. a -> [a] -> [a]
: [[payload]]
batches, ())
            (JobRead payload -> m ()) -> NonEmpty (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs) NonEmpty (JobRead payload)
jobs
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            , 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
"g1") (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
mkSimple Text
"G1-3")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> ([[payload]] -> Int) -> [[payload]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[payload]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[payload]] -> Bool) -> IO [[payload]] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [[payload]] -> IO [[payload]]
forall a. IORef a -> IO a
readIORef IORef [[payload]]
batchesRef
        batches <- IORef [[payload]] -> IO [[payload]]
forall a. IORef a -> IO a
readIORef IORef [[payload]]
batchesRef
        length batches `shouldBe` 1
        let processedJobs = [[payload]] -> [payload]
forall a. HasCallStack => [a] -> a
head [[payload]]
batches
        processedJobs `shouldMatchList` [mkSimple "G1-1", mkSimple "G1-2", mkSimple "G1-3"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"processes multiple groups as separate batches" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      batchesRef <- [[payload]] -> IO (IORef [[payload]])
forall a. a -> IO (IORef a)
newIORef []
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            let payloads :: [payload]
payloads = (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 (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [[payload]] -> ([[payload]] -> ([[payload]], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [[payload]]
batchesRef (([[payload]] -> ([[payload]], ())) -> IO ())
-> ([[payload]] -> ([[payload]], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[[payload]]
batches -> ([payload]
payloads [payload] -> [[payload]] -> [[payload]]
forall a. a -> [a] -> [a]
: [[payload]]
batches, ())
            (JobRead payload -> m ()) -> NonEmpty (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs) NonEmpty (JobRead payload)
jobs
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            , 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
"g2") (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
mkSimple Text
"G2-1")
            , 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
"g2") (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
mkSimple Text
"G2-2")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 2 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool) -> ([[payload]] -> Int) -> [[payload]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[payload]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[payload]] -> Bool) -> IO [[payload]] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [[payload]] -> IO [[payload]]
forall a. IORef a -> IO a
readIORef IORef [[payload]]
batchesRef
        batches <- IORef [[payload]] -> IO [[payload]]
forall a. IORef a -> IO a
readIORef IORef [[payload]]
batchesRef
        length batches `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"respects batch size limit" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      batchSizesRef <- [Int] -> IO (IORef [Int])
forall a. a -> IO (IORef a)
newIORef []
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            let batchSize :: Int
batchSize = NonEmpty (JobRead payload) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (JobRead payload)
jobs
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int] -> ([Int] -> ([Int], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int]
batchSizesRef (([Int] -> ([Int], ())) -> IO ())
-> ([Int] -> ([Int], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int]
sizes -> (Int
batchSize Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
sizes, ())
            (JobRead payload -> m ()) -> NonEmpty (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs) NonEmpty (JobRead payload)
jobs
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            , 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
"g1") (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
mkSimple Text
"G1-3")
            , 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
"g1") (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
mkSimple Text
"G1-4")
            , 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
"g1") (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
mkSimple Text
"G1-5")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 2 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3) (Int -> Bool) -> ([Int] -> Int) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Bool) -> IO [Int] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Int] -> IO [Int]
forall a. IORef a -> IO a
readIORef IORef [Int]
batchSizesRef
        batchSizes <- IORef [Int] -> IO [Int]
forall a. IORef a -> IO a
readIORef IORef [Int]
batchSizesRef
        batchSizes `shouldMatchList` [2, 2, 1]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retries entire batch on failure" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      attemptsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            atts <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
attemptsRef ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            if atts < 2 then throwRetryable "Batch failed!" else traverse_ (ack cbs) jobs
      let jobs =
            [ 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
3) (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
"g1") (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
mkSimple Text
"G1-1")
            , 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
3) (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
"g1") (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
mkSimple Text
"G1-2")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050, jitter = NoJitter}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
attemptsRef
        atts <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
attemptsRef
        atts `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"moves entire batch to DLQ on max failures" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let batchHandler :: p -> p -> m a
batchHandler p
_jobs p
_cbs = Text -> m a
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwRetryable Text
"Always fails"
      let jobs :: [JobWrite payload]
jobs =
            [ 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
$ 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
$ 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
"g1") (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
mkSimple Text
"G1-2")
            ]
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ (JobWrite payload -> m (Maybe (JobRead payload)))
-> [JobWrite payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob [JobWrite payload]
jobs
      config <- Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks m payload (ResultOf m payload) -> m ())
-> IO (WorkerConfig m payload)
mkBatchedConfig Int
1 Int
10 NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
NonEmpty (JobRead payload)
-> BatchCallbacks m payload (ResultOf m payload) -> m ()
forall {m :: * -> *} {p} {p} {a}. MonadIO m => p -> p -> m a
batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          dlqJobs <- env -> IO [DLQJob payload]
dlqAll env
env
          pure (length dlqJobs == 2)
        dlqJobs <- env -> IO [DLQJob payload]
dlqAll env
env
        length dlqJobs `shouldBe` 2
        map (payload . DLQ.jobSnapshot) dlqJobs `shouldMatchList` [mkSimple "G1-1", mkSimple "G1-2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"uses each job's own maxAttempts in a batch" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let batchHandler :: p -> p -> m a
batchHandler p
_jobs p
_cbs = Text -> m a
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwRetryable Text
"Always fails"
      let jobs :: [JobWrite payload]
jobs =
            [ 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
3) (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
"g1") (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
mkSimple Text
"G1-2")
            ]
      env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ (JobWrite payload -> m (Maybe (JobRead payload)))
-> [JobWrite payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobWrite payload -> m (Maybe (JobRead payload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob [JobWrite payload]
jobs
      config <- Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks m payload (ResultOf m payload) -> m ())
-> IO (WorkerConfig m payload)
mkBatchedConfig Int
1 Int
10 NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
NonEmpty (JobRead payload)
-> BatchCallbacks m payload (ResultOf m payload) -> m ()
forall {m :: * -> *} {p} {p} {a}. MonadIO m => p -> p -> m a
batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050, jitter = NoJitter}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          dlqJobs <- env -> IO [DLQJob payload]
dlqAll env
env
          pure (length dlqJobs == 2)
        dlqJobs <- env -> IO [DLQJob payload]
dlqAll env
env
        length dlqJobs `shouldBe` 2
        let dlqFor 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
mkSimple 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) [DLQJob payload]
dlqJobs
        fmap (attempts . DLQ.jobSnapshot) (dlqFor "G1-1") `shouldBe` Just 2
        fmap (attempts . DLQ.jobSnapshot) (dlqFor "G1-2") `shouldBe` Just 3

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"completed jobs survive a throwNack while the rest reprocess" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callCountRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      seenRef <- newIORef ([] :: [[payload]])
      completedRef <- newIORef ([] :: [payload])
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callCountRef ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            liftIO $ atomicModifyIORef' seenRef $ \[[payload]]
batches -> ((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 (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs) [payload] -> [[payload]] -> [[payload]]
forall a. a -> [a] -> [a]
: [[payload]]
batches, ())
            let finish JobRead payload
job = do
                  BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
completedRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
            if call == 1
              then do
                traverse_ finish (filter ((== mkSimple "G1-1") . payload) (toList jobs))
                throwNack
              else traverse_ finish jobs
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            , 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
"g1") (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
mkSimple Text
"G1-3")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.1, visibilityTimeout = 2, jobHeartbeatInterval = 1}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        let names :: [payload]
names = (Text -> payload) -> [Text] -> [payload]
forall a b. (a -> b) -> [a] -> [b]
map Text -> payload
mkSimple [Text
"G1-1", Text
"G1-2", Text
"G1-3"]
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          completed <- IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
completedRef
          pure $ all (`elem` completed) names
        seen <- IORef [[payload]] -> IO [[payload]]
forall a. IORef a -> IO a
readIORef IORef [[payload]]
seenRef
        let occurrences payload
name = [[payload]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (([payload] -> Bool) -> [[payload]] -> [[payload]]
forall a. (a -> Bool) -> [a] -> [a]
filter (payload
name payload -> [payload] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) [[payload]]
seen)
        occurrences (mkSimple "G1-1") `shouldBe` 1
        occurrences (mkSimple "G1-2") `shouldSatisfy` (>= 2)
        occurrences (mkSimple "G1-3") `shouldSatisfy` (>= 2)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"failRetryAfter and nackAfter park their jobs 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
      let batchHandler :: NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = NonEmpty (JobRead payload) -> (JobRead payload -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (JobRead payload)
jobs ((JobRead payload -> m ()) -> m ())
-> (JobRead payload -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \JobRead payload
job ->
            if 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
mkSimple Text
"cb-retry-after"
              then BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NominalDiffTime -> Text -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NominalDiffTime -> Text -> m ()
failRetryAfter BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job NominalDiffTime
3600 Text
"slow down"
              else BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NominalDiffTime -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NominalDiffTime -> m ()
nackAfter BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job NominalDiffTime
3600
      Just retried <- 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 (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
"cba") (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
mkSimple Text
"cb-retry-after"))
      Just nacked <- runM env $ HL.insertJob (setGroupKey (Just "cba") $ defaultJob (mkSimple "cb-nack-after"))
      config <- mkBatchedConfig 1 10 batchHandler
      before' <- getCurrentTime
      let fetch JobRead payload
job = 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 (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job))
          parkedPast JobRead payload
job = Bool -> (ClaimTime -> Bool) -> Maybe ClaimTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ClaimTime -> ClaimTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime -> ClaimTime -> ClaimTime
addUTCTime NominalDiffTime
3500 ClaimTime
before') (JobRead payload -> Maybe ClaimTime
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> Maybe ClaimTime
notVisibleUntil JobRead payload
job)
          settled = do
            Just retriedRow <- JobRead payload -> IO (Maybe (JobRead payload))
fetch JobRead payload
retried
            Just nackedRow <- fetch nacked
            pure
              (isNothing (claimedBy retriedRow) && isNothing (claimedBy nackedRow) && parkedPast retriedRow && parkedPast nackedRow)

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.1, backoffStrategy = Constant 0, jitter = NoJitter}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 IO Bool
settled

      Just retriedRow <- fetch retried
      Just nackedRow <- fetch nacked
      (attempts retriedRow, lastError retriedRow) `shouldBe` (1, Just "slow down")
      (attempts nackedRow, lastError nackedRow) `shouldBe` (0, Nothing)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"throwNack in single-job mode reprocesses without recording a failure" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      config <- mkConfig $ \JobRead payload
_job -> do
        call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
        when (call == 1) throwNack
      void $ runM env $ HL.insertJob (defaultJob (mkSimple "tn-single"))

      withAsync
        (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1, visibilityTimeout = 2, jobHeartbeatInterval = 1})
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
callsRef
          dlq <- env -> IO [DLQJob payload]
dlqAll env
env
          filter (== mkSimple "tn-single") (map (payload . DLQ.jobSnapshot) dlq) `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"calls heartbeat 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
      heartbeatJobsRef <- [Int64] -> IO (IORef [Int64])
forall a. a -> IO (IORef a)
newIORef []
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobHeartbeat = \JobRead payload
job ClaimTime
_currentTime ClaimTime
_startTime ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int64] -> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int64]
heartbeatJobsRef (([Int64] -> ([Int64], ())) -> IO ())
-> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int64]
jobs -> (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
jobs, ())
              }
      let batchHandler t (JobRead payload)
jobs BatchCallbacks m payload result
cbs = do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
batchHeartbeatHandlerMicros
            (JobRead payload -> m ()) -> t (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload result -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload result
cbs) t (JobRead payload)
jobs
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            ]
      insertedJobs <- runM env $ HL.insertJobsBatch jobs
      let jobIds = (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]
insertedJobs
      config <- mkBatchedConfig 1 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {observabilityHooks = hooks, pollInterval = 0.050, jobHeartbeatInterval = 1}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        let countFor :: Int64 -> IO Int
countFor Int64
jid = [Int64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int64] -> Int) -> ([Int64] -> [Int64]) -> [Int64] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> Bool) -> [Int64] -> [Int64]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
jid) ([Int64] -> Int) -> IO [Int64] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Int64] -> IO [Int64]
forall a. IORef a -> IO a
readIORef IORef [Int64]
heartbeatJobsRef
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          job1Count <- Int64 -> IO Int
countFor ([Int64] -> Int64
forall a. HasCallStack => [a] -> a
head [Int64]
jobIds)
          job2Count <- countFor (jobIds !! 1)
          pure (job1Count >= 2 && job2Count >= 2)
        job1Before <- Int64 -> IO Int
countFor ([Int64] -> Int64
forall a. HasCallStack => [a] -> a
head [Int64]
jobIds)
        job2Before <- countFor (jobIds !! 1)
        waitUntil 3_000 $ do
          job1After <- countFor (head jobIds)
          job2After <- countFor (jobIds !! 1)
          pure (job1After > job1Before && job2After > job2Before)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a throw fails only the jobs not yet completed" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      failuresRef <- [Int64] -> IO (IORef [Int64])
forall a. a -> IO (IORef a)
newIORef ([] :: [Int64])
      successRef <- newIORef ([] :: [Int64])
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobFailure = \JobRead payload
job Text
_ ClaimTime
_ ClaimTime
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int64] -> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int64]
failuresRef (([Int64] -> ([Int64], ())) -> IO ())
-> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int64]
seen -> (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
seen, ())
              , onJobSuccess = \JobRead payload
job ClaimTime
_ ClaimTime
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int64] -> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int64]
successRef (([Int64] -> ([Int64], ())) -> IO ())
-> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int64]
seen -> (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
seen, ())
              }
      let batchHandler t (JobRead payload)
jobs BatchCallbacks m payload result
cbs = do
            (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload result -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload result
cbs) (Int -> [JobRead payload] -> [JobRead payload]
forall a. Int -> [a] -> [a]
take Int
2 (t (JobRead payload) -> [JobRead payload]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (JobRead payload)
jobs))
            Text -> m b
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwRetryable Text
"Third job failed"
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            , 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
"g1") (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
mkSimple Text
"G1-3")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050, observabilityHooks = hooks, jitter = NoJitter}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> ([Int64] -> Int) -> [Int64] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int64] -> Bool) -> IO [Int64] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Int64] -> IO [Int64]
forall a. IORef a -> IO a
readIORef IORef [Int64]
failuresRef
        failures <- IORef [Int64] -> IO [Int64]
forall a. IORef a -> IO a
readIORef IORef [Int64]
failuresRef
        length failures `shouldBe` 1
        successes <- readIORef successRef
        length successes `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"completing every job in a batch removes them 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
      processedRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            (JobRead payload -> m ()) -> NonEmpty (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs) NonEmpty (JobRead payload)
jobs
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> (Bool -> (Bool, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
processedRef ((Bool -> (Bool, ())) -> IO ()) -> (Bool -> (Bool, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
_ -> (Bool
True, ())
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
processedRef
        processed <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
processedRef
        processed `shouldBe` True
        remainingJobs <- runM env (HL.claimNextVisibleJobs 10 60) :: IO [JobRead payload]
        length remainingJobs `shouldBe` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ackAll bulk-acks the batch and fires onJobSuccess for each" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      successRef <- [Int64] -> IO (IORef [Int64])
forall a. a -> IO (IORef a)
newIORef ([] :: [Int64])
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
job ClaimTime
_ ClaimTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int64] -> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int64]
successRef (([Int64] -> ([Int64], ())) -> IO ())
-> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int64]
seen -> (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
seen, ())
              }
      let batchHandler t (JobRead payload)
jobs BatchCallbacks m payload result
cbs = BatchCallbacks m payload result -> [JobRead payload] -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> [JobRead payload] -> m ()
ackAll BatchCallbacks m payload result
cbs (t (JobRead payload) -> [JobRead payload]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (JobRead payload)
jobs)
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            , 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
"g1") (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
mkSimple Text
"G1-3")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050, observabilityHooks = hooks}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3) (Int -> Bool) -> ([Int64] -> Int) -> [Int64] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int64] -> Bool) -> IO [Int64] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Int64] -> IO [Int64]
forall a. IORef a -> IO a
readIORef IORef [Int64]
successRef
        successes <- IORef [Int64] -> IO [Int64]
forall a. IORef a -> IO a
readIORef IORef [Int64]
successRef
        length successes `shouldBe` 3
        runM env (HL.countJobs @payload) `shouldReturn` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"failPermanent callback DLQs one job while the rest complete" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      successRef <- [payload] -> IO (IORef [payload])
forall a. a -> IO (IORef a)
newIORef ([] :: [payload])
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
job ClaimTime
_ ClaimTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
successRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              }
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs =
            (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
              (\JobRead payload
job -> if 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
mkSimple Text
"fp-bad" then BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> Text -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> Text -> m ()
failPermanent BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job Text
"bad input" else BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job)
              (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
      let 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
"fp") (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
mkSimple Text
"fp-good1")
            , 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
"fp") (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
mkSimple Text
"fp-bad")
            , 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
"fp") (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
mkSimple Text
"fp-good2")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05, observabilityHooks = hooks}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool) -> ([payload] -> Int) -> [payload] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([payload] -> Bool) -> IO [payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
successRef
        dlq <- env -> IO [DLQJob payload]
dlqAll env
env
        filter (== mkSimple "fp-bad") (map (payload . DLQ.jobSnapshot) dlq) `shouldBe` [mkSimple "fp-bad"]
        successes <- readIORef successRef
        successes `shouldMatchList` [mkSimple "fp-good1", mkSimple "fp-good2"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"failRetry callback retries a job and DLQs it at its maxAttempts" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
callsRef
            (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\JobRead payload
job -> BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> Text -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> Text -> m ()
failRetry BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job Text
"transient") (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
      let jobs = [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
"fr") (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
mkSimple Text
"fr-job")]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05, jitter = NoJitter}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          dlq <- env -> IO [DLQJob payload]
dlqAll env
env
          pure (any ((== mkSimple "fr-job") . payload . DLQ.jobSnapshot) dlq)
        dlq <- env -> IO [DLQJob payload]
dlqAll env
env
        fmap (attempts . DLQ.jobSnapshot) (find ((== mkSimple "fr-job") . payload . DLQ.jobSnapshot) dlq) `shouldBe` Just 2
        calls <- readIORef callsRef
        calls `shouldBe` 2

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"nack callback leaves a job to be reprocessed with no failure" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            if call == 1 then traverse_ (nack cbs) (toList jobs) else traverse_ (ack cbs) (toList jobs)
      let 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
"nk") (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
mkSimple Text
"nk-job")]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync
        (runM env $ runWorkerPool config {pollInterval = 0.1, visibilityTimeout = 2, jobHeartbeatInterval = 1})
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
callsRef
          dlq <- env -> IO [DLQJob payload]
dlqAll env
env
          filter (== mkSimple "nk-job") (map (payload . DLQ.jobSnapshot) dlq) `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"nack hands back the attempt the claim consumed" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      seenAttemptsRef <- newIORef (Nothing :: Maybe Int)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            let (firstJob :| _) = jobs
            if call == 1
              then traverse_ (nack cbs) (toList jobs)
              else do
                liftIO $ writeIORef seenAttemptsRef (Just (fromIntegral (attempts firstJob)))
                traverse_ (ack cbs) (toList jobs)
      let 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
"nka") (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
mkSimple Text
"nk-attempts")]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync
        (runM env $ runWorkerPool config {pollInterval = 0.1, visibilityTimeout = 2, jobHeartbeatInterval = 1})
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
callsRef
          -- The claim on call 1 set attempts to 1. The nack gave that attempt
          -- back. The reclaim on call 2 sees attempts == 1 again.
          seen <- IORef (Maybe Int) -> IO (Maybe Int)
forall a. IORef a -> IO a
readIORef IORef (Maybe Int)
seenAttemptsRef
          seen `shouldBe` Just 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"nack does not fire onJobSuccess" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      successRef <- [Int64] -> IO (IORef [Int64])
forall a. a -> IO (IORef a)
newIORef ([] :: [Int64])
      callsRef <- newIORef (0 :: Int)
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
job ClaimTime
_ ClaimTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int64] -> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int64]
successRef (([Int64] -> ([Int64], ())) -> IO ())
-> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int64]
seen -> (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
seen, ())
              }
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            if call == 1 then traverse_ (nack cbs) (toList jobs) else traverse_ (ack cbs) (toList jobs)
      let 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
"nks") (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
mkSimple Text
"nk-success")]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync
        ( runM env $
            runWorkerPool config {pollInterval = 0.1, visibilityTimeout = 2, jobHeartbeatInterval = 1, observabilityHooks = hooks}
        )
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
callsRef
          Int -> IO ()
threadDelay Int
settleMicros
          successes <- IORef [Int64] -> IO [Int64]
forall a. IORef a -> IO a
readIORef IORef [Int64]
successRef
          -- The nack (call 1) fires no success hook. Only the ack (call 2) does.
          length successes `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a nacked job leaves its batch siblings running past the next heartbeat" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      successRef <- [payload] -> IO (IORef [payload])
forall a. a -> IO (IORef a)
newIORef ([] :: [payload])
      callsRef <- newIORef (0 :: Int)
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
job ClaimTime
_ ClaimTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
successRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              }
      let isNacked 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
mkSimple Text
"hb-nacked"
          batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
callsRef
            (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
nack BatchCallbacks m payload (Maybe [Text])
cbs) ((JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter JobRead payload -> Bool
isNacked (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs))
            -- Outlast a heartbeat tick. The tick reads the nack's given-back attempt as a steal.
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
heartbeatTickMicros
            (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs) ((JobRead payload -> Bool) -> [JobRead payload] -> [JobRead payload]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (JobRead payload -> Bool) -> JobRead payload -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead payload -> Bool
isNacked) (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs))
      let 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
"hb") (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
mkSimple Text
"hb-nacked")
            , 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
"hb") (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
mkSimple Text
"hb-kept1")
            , 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
"hb") (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
mkSimple Text
"hb-kept2")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler
      let batchedConfig =
            WorkerConfig m payload
config
              { pollInterval = 0.05
              , visibilityTimeout = 10
              , jobHeartbeatInterval = 0.5
              , observabilityHooks = hooks
              }

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> ([payload] -> Int) -> [payload] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([payload] -> Bool) -> IO [payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
successRef
        successes <- IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
successRef
        successes `shouldMatchList` [mkSimple "hb-kept1", mkSimple "hb-kept2"]
        -- One call finished the batch. A second means the heartbeat killed the first.
        readIORef callsRef `shouldReturn` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keeps a bulk-acked batch successful across a heartbeat tick" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Window 1. ackAll deletes every row at once. A tick during the success
      -- hooks finds them gone.
      successRef <- [payload] -> IO (IORef [payload])
forall a. a -> IO (IORef a)
newIORef ([] :: [payload])
      unavailableRef <- newIORef ([] :: [payload])
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
job ClaimTime
_ ClaimTime
_ -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
                  Int -> IO ()
threadDelay Int
slowSuccessHookMicros
                  IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
successRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              , onJobUnavailable = \JobRead payload
job Text
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
unavailableRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              }
          batchHandler t (JobRead payload)
jobs BatchCallbacks m payload result
cbs = BatchCallbacks m payload result -> [JobRead payload] -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> [JobRead payload] -> m ()
ackAll BatchCallbacks m payload result
cbs (t (JobRead payload) -> [JobRead payload]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (JobRead payload)
jobs)
      let 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
"hbg") (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
mkSimple Text
"hbg-1")
            , 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
"hbg") (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
mkSimple Text
"hbg-2")
            , 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
"hbg") (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
mkSimple Text
"hbg-3")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync
        ( runM env $
            runWorkerPool
              config
                { pollInterval = 0.05
                , visibilityTimeout = 10
                , jobHeartbeatInterval = 0.2
                , observabilityHooks = hooks
                }
        )
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3) (Int -> Bool) -> ([payload] -> Int) -> [payload] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([payload] -> Bool) -> IO [payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
successRef
          Int -> IO ()
threadDelay Int
settleMicros
          IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
successRef IO [payload] -> ([payload] -> 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
>>= ([payload] -> [payload] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldMatchList` (Text -> payload) -> [Text] -> [payload]
forall a b. (a -> b) -> [a] -> [b]
map Text -> payload
mkSimple [Text
"hbg-1", Text
"hbg-2", Text
"hbg-3"])
          IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
unavailableRef IO [payload] -> [payload] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keeps an acked job successful when a sibling is force-cancelled" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Window 1b.
      successRef <- [payload] -> IO (IORef [payload])
forall a. a -> IO (IORef a)
newIORef ([] :: [payload])
      unavailableRef <- newIORef ([] :: [payload])
      cancelledRef <- newIORef ([] :: [payload])
      ackedRef <- newIORef False
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
job ClaimTime
_ ClaimTime
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
successRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              , onJobUnavailable = \JobRead payload
job Text
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
unavailableRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              , onJobCancelled = \JobRead payload
job Text
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
cancelledRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              }
          batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            (JobRead payload -> m ()) -> Maybe (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs) ((JobRead payload -> Bool)
-> NonEmpty (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
mkSimple Text
"fca-done") (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)
jobs)
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> (Bool -> (Bool, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
ackedRef ((Bool, ()) -> Bool -> (Bool, ())
forall a b. a -> b -> a
const (Bool
True, ()))
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
longHandlerMicros
      let 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
"fca") (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
mkSimple Text
"fca-done")
            , 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
"fca") (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
mkSimple Text
"fca-cancelled")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync
        ( runM env $
            runWorkerPool
              config
                { pollInterval = 0.05
                , visibilityTimeout = 10
                , jobHeartbeatInterval = 0.2
                , observabilityHooks = hooks
                }
        )
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ackedRef
          remaining <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (m [JobRead payload] -> IO [JobRead payload])
-> m [JobRead payload] -> IO [JobRead payload]
forall a b. (a -> b) -> a -> b
$ forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [JobRead payload]
HL.listJobs @payload Int
100 Int
0
          Just victim <- pure (find ((== mkSimple "fca-cancelled") . payload) remaining)
          void $ runM env (HL.forceCancelJob @payload (primaryKey victim))
          waitUntil 15_000 $ (== 1) . length <$> readIORef cancelledRef
          threadDelay settleMicros

      readIORef successRef >>= (`shouldBe` [mkSimple "fca-done"])
      readIORef cancelledRef >>= (`shouldBe` [mkSimple "fca-cancelled"])
      readIORef unavailableRef >>= (`shouldBe` [])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keeps a retried job's failure its own when a sibling is force-cancelled" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      -- Window 2b.
      retriedRef <- [payload] -> IO (IORef [payload])
forall a. a -> IO (IORef a)
newIORef ([] :: [payload])
      unavailableRef <- newIORef ([] :: [payload])
      cancelledRef <- newIORef ([] :: [payload])
      failedRef <- newIORef False
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobRetry = \JobRead payload
job NominalDiffTime
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
retriedRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              , onJobUnavailable = \JobRead payload
job Text
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
unavailableRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              , onJobCancelled = \JobRead payload
job Text
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
cancelledRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              }
          batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            (JobRead payload -> m ()) -> Maybe (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
              (\JobRead payload
job -> BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> Text -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> Text -> m ()
failRetry BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job Text
"transient")
              ((JobRead payload -> Bool)
-> NonEmpty (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
mkSimple Text
"fcr-retried") (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)
jobs)
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> (Bool -> (Bool, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
failedRef ((Bool, ()) -> Bool -> (Bool, ())
forall a b. a -> b -> a
const (Bool
True, ()))
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
longHandlerMicros
      let 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
"fcr") (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
mkSimple Text
"fcr-retried")
            , 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
"fcr") (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
mkSimple Text
"fcr-cancelled")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync
        ( runM env $
            runWorkerPool
              config
                { pollInterval = 0.05
                , visibilityTimeout = 10
                , jobHeartbeatInterval = 0.2
                , observabilityHooks = hooks
                , -- Parks the retry past the test.
                  backoffStrategy = Constant 60
                , jitter = NoJitter
                }
        )
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
failedRef
          remaining <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (m [JobRead payload] -> IO [JobRead payload])
-> m [JobRead payload] -> IO [JobRead payload]
forall a b. (a -> b) -> a -> b
$ forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [JobRead payload]
HL.listJobs @payload Int
100 Int
0
          Just victim <- pure (find ((== mkSimple "fcr-cancelled") . payload) remaining)
          void $ runM env (HL.forceCancelJob @payload (primaryKey victim))
          waitUntil 15_000 $ (== 1) . length <$> readIORef cancelledRef
          threadDelay settleMicros

      readIORef retriedRef >>= (`shouldBe` [mkSimple "fcr-retried"])
      readIORef cancelledRef >>= (`shouldBe` [mkSimple "fcr-cancelled"])
      -- The retry is written and recorded. The finalizer has nothing to re-settle.
      readIORef unavailableRef >>= (`shouldBe` [])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports a nack the claim no longer covers" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      unavailableRef <- [payload] -> IO (IORef [payload])
forall a. a -> IO (IORef a)
newIORef ([] :: [payload])
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobUnavailable = \JobRead payload
job Text
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
unavailableRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              }
          batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            -- Lapse the lease and let the next claim take the token. The nack then
            -- matches no row.
            (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (m Int64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Int64 -> m ())
-> (JobRead payload -> m Int64) -> JobRead payload -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> JobRead payload -> m Int64
forall payload (m :: * -> *).
MonadArbiter m =>
NominalDiffTime -> JobRead payload -> m Int64
HL.setVisibilityTimeout NominalDiffTime
0) (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            m [JobRead payload] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs @payload Int
10 NominalDiffTime
60)
            (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
nack BatchCallbacks m payload (Maybe [Text])
cbs) (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
      let 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
"nkg") (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
mkSimple Text
"nk-gone")]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync
        ( runM env $
            runWorkerPool config {pollInterval = 0.1, visibilityTimeout = 10, jobHeartbeatInterval = 1, observabilityHooks = hooks}
        )
        $ \Async ()
_ ->
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text -> payload
mkSimple Text
"nk-gone" payload -> [payload] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([payload] -> Bool) -> IO [payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
unavailableRef

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a thrown JobGoneException skips retry and leaves the job to reprocess" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            if call == 1
              then throwJobGone "stolen mid-batch"
              else traverse_ (ack cbs) (toList jobs)
      let 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
"st") (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
mkSimple Text
"stolen-job")]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync
        (runM env $ runWorkerPool config {pollInterval = 0.1, visibilityTimeout = 2, jobHeartbeatInterval = 1})
        $ \Async ()
_ -> do
          -- The steal skips retry. The job reprocesses and the second pass acks
          -- it. It never lands in the DLQ.
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
callsRef
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
          dlq <- env -> IO [DLQJob payload]
dlqAll env
env
          filter (== mkSimple "stolen-job") (map (payload . DLQ.jobSnapshot) dlq) `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an outer rollback after ack reprocesses the job" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            if call == 1
              then withDbTransaction $ do
                traverse_ (ack cbs) (toList jobs)
                throwRetryable "rolling back the ack"
              else traverse_ (ack cbs) (toList jobs)
      let jobs = [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
5) (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
"sp") (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
mkSimple Text
"sp-job")]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync
        (runM env $ runWorkerPool config {pollInterval = 0.1, visibilityTimeout = 2, jobHeartbeatInterval = 1, jitter = NoJitter})
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
callsRef
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reprocesses a rolled-back bulk ack and reports each savepoint release" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      callsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      successesRef <- newIORef (0 :: Int)
      batchSizesRef <- newIORef ([] :: [Int])
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobSuccess = \JobRead payload
_ ClaimTime
_ ClaimTime
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
successesRef
              }
          batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            call <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, Int)) -> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
callsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            liftIO $ atomicModifyIORef' batchSizesRef (\[Int]
sizes -> (NonEmpty (JobRead payload) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (JobRead payload)
jobs Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
sizes, ()))
            if call == 1
              then withDbTransaction $ do
                ackAllWith cbs [(job, Just ["rolled back"]) | job <- toList jobs]
                throwRetryable "rolling back the batch"
              else ackAllWith cbs [(job, Just ["committed"]) | job <- toList jobs]
      let archivedJob Text
name = 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) (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
"sp-bulk") (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
mkSimple Text
name)
      runM env $ traverse_ (void . HL.insertJob . archivedJob) ["sp-bulk-1", "sp-bulk-2"]
      config <- mkBatchedConfig 1 2 batchHandler

      withAsync
        ( runM env $
            runWorkerPool
              config
                { pollInterval = 0.1
                , visibilityTimeout = 2
                , jobHeartbeatInterval = 1
                , jitter = NoJitter
                , observabilityHooks = hooks
                }
        )
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
callsRef
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
successesRef

      arch <- archived env
      let resultFor Text
name = ArchiveJob payload -> Maybe Value
forall payload. ArchiveJob payload -> Maybe Value
Archive.archivedResult (ArchiveJob payload -> Maybe Value)
-> Maybe (ArchiveJob payload) -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ArchiveJob payload -> Bool)
-> [ArchiveJob payload] -> Maybe (ArchiveJob 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
mkSimple Text
name) (payload -> Bool)
-> (ArchiveJob payload -> payload) -> ArchiveJob 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)
-> (ArchiveJob payload -> JobRead payload)
-> ArchiveJob payload
-> payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveJob payload -> JobRead payload
forall payload. ArchiveJob payload -> JobSnapshot payload
Archive.jobSnapshot) [ArchiveJob payload]
arch
      resultFor "sp-bulk-1" `shouldBe` Just (toJSON ["committed" :: Text])
      resultFor "sp-bulk-2" `shouldBe` Just (toJSON ["committed" :: Text])
      readIORef batchSizesRef `shouldReturn` [2, 2]
      readIORef successesRef `shouldReturn` 4

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelTree callback deletes 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
      Right (root :| _) <-
        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
mkSimple Text
"ct-root")
            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
mkSimple Text
"ct-c1") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"ct-c2")])
      let rootId = JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
root
      let batchHandler t (JobRead payload)
jobs BatchCallbacks f payload result
cbs = (JobRead payload -> f ()) -> [JobRead payload] -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\JobRead payload
job -> BatchCallbacks f payload result -> JobRead payload -> Text -> f ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> Text -> m ()
cancelTree BatchCallbacks f payload result
cbs JobRead payload
job Text
"abort") (t (JobRead payload) -> [JobRead payload]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (JobRead payload)
jobs)
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          mJob <- 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
$ forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.getJobById @payload Int64
rootId
          pure (isNothing mJob)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports a sibling the batch's own cancelTree deleted as cancelled" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      cancelledRef <- [payload] -> IO (IORef [payload])
forall a. a -> IO (IORef a)
newIORef ([] :: [payload])
      unavailableRef <- newIORef ([] :: [payload])
      batchSizesRef <- newIORef ([] :: [Int])
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobUnavailable = \JobRead payload
job Text
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
unavailableRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              , onJobCancelled = \JobRead payload
job Text
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [payload] -> ([payload] -> ([payload], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [payload]
cancelledRef (([payload] -> ([payload], ())) -> IO ())
-> ([payload] -> ([payload], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[payload]
seen -> (JobRead payload -> payload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
payload JobRead payload
job payload -> [payload] -> [payload]
forall a. a -> [a] -> [a]
: [payload]
seen, ())
              }
          named Text
name = (JobRead payload -> Bool)
-> NonEmpty (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
mkSimple 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)
          batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int] -> ([Int] -> ([Int], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int]
batchSizesRef (\[Int]
sizes -> (NonEmpty (JobRead payload) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (JobRead payload)
jobs Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
sizes, ()))
            (JobRead payload -> m ()) -> Maybe (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\JobRead payload
job -> BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> Text -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> Text -> m ()
cancelTree BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job Text
"abort") (Text -> NonEmpty (JobRead payload) -> Maybe (JobRead payload)
named Text
"cts-c1" NonEmpty (JobRead payload)
jobs)
            (JobRead payload -> m ()) -> Maybe (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs) (Text -> NonEmpty (JobRead payload) -> Maybe (JobRead payload)
named Text
"cts-c2" NonEmpty (JobRead payload)
jobs)
          child Text
name = 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
"cts") (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
mkSimple Text
name)
      Right _ <-
        runM env
          $ HL.insertJobTree
          $ defaultJob (mkSimple "cts-root") <~~ (child "cts-c1" :| [child "cts-c2"])
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05, observabilityHooks = hooks}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          cancelled <- IORef [payload] -> IO [payload]
forall a. IORef a -> IO a
readIORef IORef [payload]
cancelledRef
          unavailable <- readIORef unavailableRef
          pure (length cancelled + length unavailable >= 2)

      readIORef batchSizesRef `shouldReturn` [2]
      readIORef unavailableRef `shouldReturn` []
      readIORef cancelledRef >>= (`shouldMatchList` [mkSimple "cts-c1", mkSimple "cts-c2"])

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelBranch callback deletes the job's branch" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      Right (root :| _) <-
        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
mkSimple Text
"cb-root")
            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
mkSimple Text
"cb-c1") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"cb-c2")])
      let rootId = JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
root
      let batchHandler t (JobRead payload)
jobs BatchCallbacks f payload result
cbs = (JobRead payload -> f ()) -> [JobRead payload] -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\JobRead payload
job -> BatchCallbacks f payload result -> JobRead payload -> Text -> f ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> Text -> m ()
cancelBranch BatchCallbacks f payload result
cbs JobRead payload
job Text
"branch failed") (t (JobRead payload) -> [JobRead payload]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (JobRead payload)
jobs)
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          mJob <- 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
$ forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.getJobById @payload Int64
rootId
          pure (isNothing mJob)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"uncompleted jobs remain in the queue after the handler returns" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      processedRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs ([JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs))
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> (Bool -> (Bool, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
processedRef ((Bool -> (Bool, ())) -> IO ()) -> (Bool -> (Bool, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
_ -> (Bool
True, ())
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 1 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
processedRef

      readIORef processedRef >>= (`shouldBe` True)
      runM env (HL.countJobs @payload) `shouldReturn` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ungrouped jobs are batched together (not as singletons)" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      batchSizesRef <- [Int] -> IO (IORef [Int])
forall a. a -> IO (IORef a)
newIORef []
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            let batchSize :: Int
batchSize = NonEmpty (JobRead payload) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (JobRead payload)
jobs
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int] -> ([Int] -> ([Int], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int]
batchSizesRef (([Int] -> ([Int], ())) -> IO ())
-> ([Int] -> ([Int], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Int]
sizes -> (Int
batchSize Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
sizes, ())
            (JobRead payload -> m ()) -> NonEmpty (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs) NonEmpty (JobRead payload)
jobs
      let jobs =
            [ payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"Ungrouped-1")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"Ungrouped-2")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"Ungrouped-3")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 3 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> ([Int] -> Int) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Bool) -> IO [Int] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Int] -> IO [Int]
forall a. IORef a -> IO a
readIORef IORef [Int]
batchSizesRef
        batchSizes <- IORef [Int] -> IO [Int]
forall a. IORef a -> IO a
readIORef IORef [Int]
batchSizesRef
        length batchSizes `shouldBe` 1
        batchSizes `shouldMatchList` [3]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"mixed grouped and ungrouped jobs are batched correctly" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      batchPayloadsRef <- [[payload]] -> IO (IORef [[payload]])
forall a. a -> IO (IORef a)
newIORef []
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = do
            let payloads :: [payload]
payloads = (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 (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [[payload]] -> ([[payload]] -> ([[payload]], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [[payload]]
batchPayloadsRef (([[payload]] -> ([[payload]], ())) -> IO ())
-> ([[payload]] -> ([[payload]], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[[payload]]
batches -> ([payload]
payloads [payload] -> [[payload]] -> [[payload]]
forall a. a -> [a] -> [a]
: [[payload]]
batches, ())
            (JobRead payload -> m ()) -> NonEmpty (JobRead payload) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs) NonEmpty (JobRead payload)
jobs
      let 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
"g1") (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
mkSimple Text
"G1-1")
            , 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
"g1") (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
mkSimple Text
"G1-2")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"Ungrouped-1")
            , payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"Ungrouped-2")
            , 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
"g2") (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
mkSimple Text
"G2-1")
            ]
      runM env $ traverse_ HL.insertJob jobs
      config <- mkBatchedConfig 4 10 batchHandler
      let batchedConfig = WorkerConfig m payload
config {pollInterval = 0.050}
      threadDelay beforeStartMicros

      withAsync (runM env $ runWorkerPool batchedConfig) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3) (Int -> Bool) -> ([[payload]] -> Int) -> [[payload]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[payload]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[payload]] -> Bool) -> IO [[payload]] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [[payload]] -> IO [[payload]]
forall a. IORef a -> IO a
readIORef IORef [[payload]]
batchPayloadsRef
        batches <- IORef [[payload]] -> IO [[payload]]
forall a. IORef a -> IO a
readIORef IORef [[payload]]
batchPayloadsRef
        length batches `shouldBe` 3
        let batchSizes = ([payload] -> Int) -> [[payload]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map [payload] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[payload]]
batches
        batchSizes `shouldMatchList` [2, 2, 1]
        let g1Batch = ([payload] -> Bool) -> [[payload]] -> [[payload]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\[payload]
batch -> Text -> payload
mkSimple Text
"G1-1" payload -> [payload] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [payload]
batch) [[payload]]
batches
        length g1Batch `shouldBe` 1
        head g1Batch `shouldMatchList` [mkSimple "G1-1", mkSimple "G1-2"]

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Spawned Children" (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
"spawn suspends the job and wakes it once its children are done" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      roundsRef <- [Bool] -> IO (IORef [Bool])
forall a. a -> IO (IORef a)
newIORef ([] :: [Bool])
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job = do
                IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Bool] -> ([Bool] -> ([Bool], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Bool]
roundsRef (\[Bool]
rs -> ([Bool]
rs [Bool] -> [Bool] -> [Bool]
forall a. Semigroup a => a -> a -> a
<> [JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job], ()))
                if JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job Bool -> Bool -> Bool
|| 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
mkSimple Text
"sp1-root"
                  then BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
                  else
                    BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (NonEmpty (JobWrite payload) -> m ())
-> NonEmpty (JobWrite payload) -> m ()
forall a b. (a -> b) -> a -> b
$
                      payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp1-c1") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp1-c2")]
      runM env $ void $ HL.insertJob (defaultJob (mkSimple "sp1-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      rounds <- readIORef roundsRef
      length rounds `shouldBe` 4
      length (filter id rounds) `shouldBe` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a spawn round hands back the attempt its claim consumed" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      seenRef <- Maybe Int32 -> IO (IORef (Maybe Int32))
forall a. a -> IO (IORef a)
newIORef (Maybe Int32
forall a. Maybe a
Nothing :: Maybe Int32)
      failedRef <- newIORef False
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs 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
mkSimple Text
"sp2-child" = do
                    parent <- (Int64 -> m (Maybe (JobRead payload)))
-> Maybe Int64 -> m (Maybe (Maybe (JobRead payload)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.getJobById @payload) (JobRead payload -> Maybe Int64
forall payload q insertedAt adm.
Job payload Int64 q insertedAt adm -> Maybe Int64
parentId JobRead payload
job)
                    liftIO $ writeIORef seenRef (fmap attempts (join parent))
                    ack cbs job
                | Bool
otherwise = do
                    failedOnce <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
failedRef (\Bool
done -> (Bool
True, Bool
done))
                    if failedOnce
                      then spawn cbs job (defaultJob (mkSimple "sp2-child") :| [])
                      else failRetry cbs job "sp2 first round"
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 4) $ defaultJob (mkSimple "sp2-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05, backoffStrategy = Constant 0, jitter = NoJitter}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      readIORef seenRef `shouldReturn` Just 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a finalizer round that spawns again unfolds a recursion" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      seenRef <- [Text] -> IO (IORef [Text])
forall a. a -> IO (IORef a)
newIORef ([] :: [Text])
      let chain = [Text
"sp3-0", Text
"sp3-1", Text
"sp3-2", Text
"sp3-3"]
          nameOf JobRead payload
job = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"?" ((Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Text
name -> 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
mkSimple Text
name) [Text]
chain)
          childOf Text
name = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name ([Text] -> [Text] -> [(Text, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 [Text]
chain) [Text]
chain)
          batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job = do
                let name :: Text
name = JobRead payload -> Text
nameOf JobRead payload
job
                IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Text] -> ([Text] -> ([Text], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Text]
seenRef (\[Text]
names -> ([Text]
names [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
name], ()))
                case (JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job, Text -> Maybe Text
childOf Text
name) of
                  (Bool
False, Just Text
kid) -> BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
kid) JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                  (Bool, Maybe Text)
_ -> BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
      runM env $ void $ HL.insertJob (defaultJob (mkSimple "sp3-3"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      seen <- readIORef seenRef
      seen `shouldBe` ["sp3-3", "sp3-2", "sp3-1", "sp3-0", "sp3-1", "sp3-2", "sp3-3"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"drains a group whose head spawns children into it" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let inGroup :: JobWrite payload -> JobWrite payload
inGroup = 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
"spg")
          batchHandler :: NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job Bool -> Bool -> Bool
|| 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
mkSimple Text
"sp5-head" = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
                | Bool
otherwise =
                    BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (NonEmpty (JobWrite payload) -> m ())
-> NonEmpty (JobWrite payload) -> m ()
forall a b. (a -> b) -> a -> b
$
                      JobWrite payload -> JobWrite payload
forall {payload}. JobWrite payload -> JobWrite payload
inGroup (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp5-c1")) JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite payload -> JobWrite payload
forall {payload}. JobWrite payload -> JobWrite payload
inGroup (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp5-c2"))]
      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 -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
          (m (Maybe (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (JobRead payload)) -> m ())
-> (Text -> m (Maybe (JobRead payload))) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)))
-> (Text -> JobWrite payload)
-> Text
-> m (Maybe (JobRead payload))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobWrite payload -> JobWrite payload
forall {payload}. JobWrite payload -> JobWrite payload
inGroup (JobWrite payload -> JobWrite payload)
-> (Text -> JobWrite payload) -> Text -> JobWrite payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (payload -> JobWrite payload)
-> (Text -> payload) -> Text -> JobWrite payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> payload
mkSimple)
          [Text
"sp5-head", Text
"sp5-sib1", Text
"sp5-sib2"]
      config <- Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks m payload (ResultOf m payload) -> m ())
-> IO (WorkerConfig m payload)
mkBatchedConfig Int
1 Int
10 NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
NonEmpty (JobRead payload)
-> BatchCallbacks m payload (ResultOf m payload) -> m ()
batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ -> do
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
        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 (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (JobWrite payload -> JobWrite payload
forall {payload}. JobWrite payload -> JobWrite payload
inGroup (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp5-after")))
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a nack after a spawn hands back nothing further" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      seenRef <- Maybe Int32 -> IO (IORef (Maybe Int32))
forall a. a -> IO (IORef a)
newIORef (Maybe Int32
forall a. Maybe a
Nothing :: Maybe Int32)
      failedRef <- newIORef False
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs 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
mkSimple Text
"sp7-child" = do
                    parent <- (Int64 -> m (Maybe (JobRead payload)))
-> Maybe Int64 -> m (Maybe (Maybe (JobRead payload)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.getJobById @payload) (JobRead payload -> Maybe Int64
forall payload q insertedAt adm.
Job payload Int64 q insertedAt adm -> Maybe Int64
parentId JobRead payload
job)
                    liftIO $ writeIORef seenRef (fmap attempts (join parent))
                    ack cbs job
                | Bool
otherwise = do
                    failedOnce <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
failedRef (\Bool
done -> (Bool
True, Bool
done))
                    if failedOnce
                      then do
                        spawn cbs job (defaultJob (mkSimple "sp7-child") :| [])
                        nack cbs job
                      else failRetry cbs job "sp7 first round"
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 4) $ defaultJob (mkSimple "sp7-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05, backoffStrategy = Constant 0, jitter = NoJitter}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      readIORef seenRef `shouldReturn` Just 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a spawned child in the DLQ still wakes the finalizer" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      finalizedRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
finalizedRef Bool
True)
                | 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
mkSimple Text
"sp4-child" = BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> Text -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> Text -> m ()
failPermanent BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job Text
"child gave up"
                | Bool
otherwise = BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp4-child") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 2) $ defaultJob (mkSimple "sp4-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
15_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
finalizedRef
      dlq <- dlqAll env
      map (payload . DLQ.jobSnapshot) dlq `shouldBe` [mkSimple "sp4-child"]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a DLQ move reads the rollup state the spawn wrote, not the claim's" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      spawnedRef <- Maybe Int64 -> IO (IORef (Maybe Int64))
forall a. a -> IO (IORef a)
newIORef (Maybe Int64
forall a. Maybe a
Nothing :: Maybe Int64)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs 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
mkSimple Text
"sp16-child" = do
                    parent <- IO (Maybe Int64) -> m (Maybe Int64)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Int64) -> IO (Maybe Int64)
forall a. IORef a -> IO a
readIORef IORef (Maybe Int64)
spawnedRef)
                    for_ parent $ \Int64
pid -> m Int64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall payload (m :: * -> *).
MonadArbiter m =>
Text -> JobRead payload -> m Int64
HL.moveToDLQ @payload Text
"operator pulled the tree" (JobRead payload -> m Int64) -> m (JobRead payload) -> m Int64
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int64 -> m (JobRead payload)
needJob Int64
pid)
                    ack cbs job
                | Bool
otherwise = do
                    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Int64) -> Maybe Int64 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Int64)
spawnedRef (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
job))
                    BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp16-child") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
              needJob :: Int64 -> m (JobRead payload)
needJob Int64
pid = do
                found <- forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.getJobById @payload Int64
pid
                maybe (error "sp16 parent vanished") pure found
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 5) $ defaultJob (mkSimple "sp16-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      dlq <- dlqAll env
      map (payload . DLQ.jobSnapshot) dlq
        `shouldMatchList` [mkSimple "sp16-root", mkSimple "sp16-child"]
      runM env $ void $ HL.deleteDLQJobsBatch @payload (map DLQ.dlqPrimaryKey dlq)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a permanent failure after a spawn leaves the finalizer standing" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      roundsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
roundsRef) m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs 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
mkSimple Text
"sp8-child" = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
                | Bool
otherwise = do
                    BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp8-child") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                    BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> Text -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> Text -> m ()
failPermanent BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job Text
"the handler changed its mind"
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 5) $ defaultJob (mkSimple "sp8-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      readIORef roundsRef `shouldReturn` 1
      dlq <- dlqAll env
      map (payload . DLQ.jobSnapshot) dlq `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an ack or a second spawn after a spawn is ignored" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      roundsRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
roundsRef) m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs 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
mkSimple Text
"sp11-child" = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
                | Bool
otherwise = do
                    BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp11-child") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                    BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp11-extra") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                    BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 5) $ defaultJob (mkSimple "sp11-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      readIORef roundsRef `shouldReturn` 1

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a dedup conflict on one child commits nothing and spares its batch siblings" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      siblingRef <- [Int32] -> IO (IORef [Int32])
forall a. a -> IO (IORef a)
newIORef ([] :: [Int32])
      later <- addUTCTime 3600 <$> getCurrentTime
      let inGroup = 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
"sp12g")
          taken =
            Maybe ClaimTime -> JobWrite payload -> JobWrite payload
forall payload.
Maybe ClaimTime -> JobWrite payload -> JobWrite payload
setNotVisibleUntil (ClaimTime -> Maybe ClaimTime
forall a. a -> Maybe a
Just ClaimTime
later)
              (JobWrite payload -> JobWrite payload)
-> (JobWrite payload -> JobWrite payload)
-> JobWrite payload
-> JobWrite payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
"sp12-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
mkSimple Text
"sp12-c2")
          kids =
            payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp12-c1")
              JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [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
"sp12-key")) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp12-c2"))]
          batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs 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
mkSimple Text
"sp12-sib" = do
                    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int32] -> ([Int32] -> ([Int32], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int32]
siblingRef (\[Int32]
seen -> ([Int32]
seen [Int32] -> [Int32] -> [Int32]
forall a. Semigroup a => a -> a -> a
<> [JobRead payload -> Int32
forall payload q insertedAt adm.
Job payload Int64 q insertedAt adm -> Int32
attempts JobRead payload
job], ()))
                    BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
                | Bool
otherwise = BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job NonEmpty (JobWrite payload)
kids
      runM env $ do
        void $ HL.insertJob taken
        void $ HL.insertJob (setMaxAttempts (Just 1) $ inGroup $ defaultJob (mkSimple "sp12-spawner"))
        void $ HL.insertJob (setMaxAttempts (Just 2) $ inGroup $ defaultJob (mkSimple "sp12-sib"))
      config <- mkBatchedConfig 1 2 batchHandler

      let settled = do
            dlq <- env -> IO [DLQJob payload]
dlqAll env
env
            jobs <- runM env (HL.listJobs 10 0) :: IO [JobRead payload]
            pure (not (null dlq) && all (isNothing . claimedBy) [job | job <- jobs, payload job == mkSimple "sp12-sib"])
      dlq <-
        withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 IO Bool
settled
          env -> IO [DLQJob payload]
dlqAll env
env
      map (payload . DLQ.jobSnapshot) dlq `shouldBe` [mkSimple "sp12-spawner"]
      remaining <- runM env (HL.listJobs 10 0) :: IO [JobRead payload]
      let byName Text
name = [JobRead payload
job | JobRead payload
job <- [JobRead payload]
remaining, 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
mkSimple Text
name]
      map attempts (byName "sp12-sib") `shouldBe` [0]
      byName "sp12-c1" `shouldBe` []
      map payload remaining `shouldMatchList` [mkSimple "sp12-c2", mkSimple "sp12-sib"]
      readIORef siblingRef `shouldReturn` []
      runM env $ void $ HL.cancelJobsBatch @payload (map primaryKey remaining)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a later round does not see an earlier round's dead-lettered child" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      sizesRef <- [Int] -> IO (IORef [Int])
forall a. a -> IO (IORef a)
newIORef ([] :: [Int])
      roundKindsRef <- newIORef ([] :: [[Either Text (ResultOf m payload)]])
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each 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
mkSimple Text
"sp13-c1" = BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> Text -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> Text -> m ()
failPermanent BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job Text
"c1 gave up"
                | 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
mkSimple Text
"sp13-c2" = BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> Maybe [Text] -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> result -> m ()
ackWith BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job ([Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"c2 done"])
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = do
                    (seen, _) <- JobRead payload
-> m (Map Int64 (Either Text (ResultOf m payload)), Map Int64 Text)
forall (m :: * -> *) payload.
(FromJSON (ResultOf m payload), MonadArbiter m) =>
JobRead payload
-> m (Map Int64 (Either Text (ResultOf m payload)), Map Int64 Text)
childResults JobRead payload
job
                    liftIO $ atomicModifyIORef' roundKindsRef (\[[Either Text (Maybe [Text])]]
ks -> ([[Either Text (Maybe [Text])]]
ks [[Either Text (Maybe [Text])]]
-> [[Either Text (Maybe [Text])]] -> [[Either Text (Maybe [Text])]]
forall a. Semigroup a => a -> a -> a
<> [Map Int64 (Either Text (Maybe [Text]))
-> [Either Text (Maybe [Text])]
forall k a. Map k a -> [a]
Map.elems Map Int64 (Either Text (Maybe [Text]))
seen], ()))
                    rounds <-
                      liftIO $ atomicModifyIORef' sizesRef (\[Int]
sizes -> ([Int]
sizes [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Map Int64 (Either Text (Maybe [Text])) -> Int
forall k a. Map k a -> Int
Map.size Map Int64 (Either Text (Maybe [Text]))
seen], [Int]
sizes))
                    if null rounds
                      then spawn cbs job (defaultJob (mkSimple "sp13-c2") :| [])
                      else ack cbs job
                | Bool
otherwise = BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp13-c1") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 5) $ defaultJob (mkSimple "sp13-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      readIORef sizesRef `shouldReturn` [1, 1]
      rounds <- readIORef roundKindsRef
      rounds `shouldBe` [[Left "c1 gave up"], [Right (Just ["c2 done"])]]

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cancelJob refuses a job that spawned children" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      spawnedRef <- Maybe Int64 -> IO (IORef (Maybe Int64))
forall a. a -> IO (IORef a)
newIORef (Maybe Int64
forall a. Maybe a
Nothing :: Maybe Int64)
      cancelledRef <- newIORef (Nothing :: Maybe Int64)
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs 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
mkSimple Text
"sp14-child" = do
                    parent <- IO (Maybe Int64) -> m (Maybe Int64)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Int64) -> IO (Maybe Int64)
forall a. IORef a -> IO a
readIORef IORef (Maybe Int64)
spawnedRef)
                    for_ parent $ \Int64
pid -> do
                      refused <- forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.cancelJob @payload Int64
pid
                      liftIO (writeIORef cancelledRef (Just refused))
                    ack cbs job
                | Bool
otherwise = do
                    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Int64) -> Maybe Int64 -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Int64)
spawnedRef (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
job))
                    BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp14-child") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 5) $ defaultJob (mkSimple "sp14-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      readIORef cancelledRef `shouldReturn` Just 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a replace-dedup insert does not move a child out of its tree" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let child :: JobWrite payload
child = 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
"sp15-key")) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp15-child"))
      inserted <-
        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 (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp15-root") JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ (JobWrite payload
child JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| []))
      childId <- case inserted of
        Right (JobRead payload
_ :| [JobRead payload
kid]) -> Int64 -> IO Int64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
kid)
        Either Text (NonEmpty (JobRead payload))
other -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String
"unexpected tree insert: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Either Text (NonEmpty Int64) -> String
forall a. Show a => a -> String
show ((NonEmpty (JobRead payload) -> NonEmpty Int64)
-> Either Text (NonEmpty (JobRead payload))
-> Either Text (NonEmpty Int64)
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((JobRead payload -> Int64)
-> NonEmpty (JobRead payload) -> NonEmpty Int64
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey) Either Text (NonEmpty (JobRead payload))
other)) IO () -> IO Int64 -> IO Int64
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int64 -> IO Int64
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
0
      runM env $ void $ HL.insertJob (setDedupKey (Just (ReplaceDuplicate "sp15-key")) (defaultJob (mkSimple "sp15-thief")))
      stillMine <- runM env (HL.getJobById @payload childId)
      fmap parentId stillMine `shouldSatisfy` maybe False isJust
      for_ (stillMine >>= parentId) $ \Int64
rootId -> 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 Int64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Int64 -> m ()) -> m Int64 -> m ()
forall a b. (a -> b) -> a -> b
$ forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.cancelJobCascade @payload Int64
rootId
      runM env (HL.countJobs @payload) `shouldReturn` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a bulk ack after a spawn stores no result" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      seenRef <- Maybe [Either Text (Maybe [Text])]
-> IO (IORef (Maybe [Either Text (Maybe [Text])]))
forall a. a -> IO (IORef a)
newIORef (Maybe [Either Text (Maybe [Text])]
Maybe [Either Text (ResultOf m payload)]
forall a. Maybe a
Nothing :: Maybe [Either Text (ResultOf m payload)])
      let batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each 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
mkSimple Text
"sp17-root" = do
                    (seen, _) <- JobRead payload
-> m (Map Int64 (Either Text (ResultOf m payload)), Map Int64 Text)
forall (m :: * -> *) payload.
(FromJSON (ResultOf m payload), MonadArbiter m) =>
JobRead payload
-> m (Map Int64 (Either Text (ResultOf m payload)), Map Int64 Text)
childResults JobRead payload
job
                    liftIO $ writeIORef seenRef (Just (Map.elems seen))
                    ack cbs 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
mkSimple Text
"sp17-mid" =
                    if JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job
                      then BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
                      else do
                        BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp17-leaf") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [])
                        BatchCallbacks m payload (Maybe [Text])
-> [(JobRead payload, Maybe [Text])] -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> [(JobRead payload, result)] -> m ()
ackAllWith BatchCallbacks m payload (Maybe [Text])
cbs [(JobRead payload
job, [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"premature"])]
                | Bool
otherwise = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
      runM env
        $ void
        $ HL.insertJobTree
        $ setMaxAttempts (Just 5) (defaultJob (mkSimple "sp17-root"))
          <~~ (setMaxAttempts (Just 5) (defaultJob (mkSimple "sp17-mid")) :| [])
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      readIORef seenRef `shouldReturn` Just []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a DLQ move racing a spawn commit takes the new children with it" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      spawnHeld <- IO (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 5) (defaultJob (mkSimple "sp18-root")))
      claimed <- runM env (HL.claimNextVisibleJobs 1 60) :: IO [JobRead payload]
      let job = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
      concurrently_
        ( runM env $ withDbTransaction $ do
            void $ HL.spawnChildren job (defaultJob (mkSimple "sp18-child") :| [])
            void $ HL.ackJob job
            liftIO $ putMVar spawnHeld ()
            liftIO $ threadDelay spawnHoldMicros
        )
        ( takeMVar spawnHeld
            >> void (runM env (HL.moveToDLQ "operator pulled the tree" job))
        )
      dlq <- dlqAll env
      map (payload . DLQ.jobSnapshot) dlq
        `shouldMatchList` [mkSimple "sp18-root", mkSimple "sp18-child"]
      runM env (HL.countJobs @payload) `shouldReturn` 0
      runM env $ void $ HL.deleteDLQJobsBatch @payload (map DLQ.dlqPrimaryKey dlq)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refuses a spawn on a job this worker no longer holds" ((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 (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 (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (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
5) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp19-root")))
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]
      let job = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
      runM env $ withDbTransaction $ do
        void $ HL.spawnChildren job (defaultJob (mkSimple "sp19-child") :| [])
        void $ HL.ackJob job
      suspended <- runM env (HL.getJobById @payload (primaryKey job))
      late <-
        traverse (\JobRead payload
held -> IO () -> IO (Either JobGoneException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m (NonEmpty (JobRead payload)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobRead payload
-> NonEmpty (JobWrite payload) -> m (NonEmpty (JobRead payload))
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload
-> NonEmpty (JobWrite payload) -> m (NonEmpty (JobRead payload))
HL.spawnChildren JobRead payload
held (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp19-late") JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| []))))) suspended
      case late of
        Just (Left (JobGoneException Text
_ [Int64]
ids)) -> [Int64]
ids [Int64] -> [Int64] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job]
        Maybe (Either JobGoneException ())
_ -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"a spawn on a suspended job was not refused as gone"
      runM env $ void $ HL.cancelJobCascade @payload (primaryKey job)
      runM env (HL.countJobs @payload) `shouldReturn` 0

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a scoped failure naming no job of the batch fails the batch" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      let stranger :: Int64
stranger = Int64
0
          batchHandler :: NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
batchHandler NonEmpty (JobRead payload)
_jobs BatchCallbacks m payload (Maybe [Text])
_cbs =
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ JobException -> [Int64] -> IO ()
forall (m :: * -> *) a. MonadIO m => JobException -> [Int64] -> m a
throwScopedFailure (JobPermanentException -> JobException
Permanent (Text -> JobPermanentException
JobPermanentException Text
"names another batch")) [Int64
stranger]
      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 (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (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
mkSimple Text
"sp20-root"))
      config <- Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks m payload (ResultOf m payload) -> m ())
-> IO (WorkerConfig m payload)
mkBatchedConfig Int
1 Int
10 NonEmpty (JobRead payload)
-> BatchCallbacks m payload (Maybe [Text]) -> m ()
NonEmpty (JobRead payload)
-> BatchCallbacks m payload (ResultOf m payload) -> m ()
batchHandler

      dlq <-
        withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool)
-> ([DLQJob payload] -> Bool) -> [DLQJob payload] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DLQJob payload] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([DLQJob payload] -> Bool) -> IO [DLQJob payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> IO [DLQJob payload]
dlqAll env
env
          env -> IO [DLQJob payload]
dlqAll env
env
      map (payload . DLQ.jobSnapshot) dlq `shouldBe` [mkSimple "sp20-root"]
      runM env $ void $ HL.deleteDLQJobsBatch @payload (map DLQ.dlqPrimaryKey dlq)

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"children of one spawn that share a dedup key collapse into one" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      childrenRef <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
      let kids =
            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
"sp21-key")) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp21-c1"))
              JobWrite payload
-> [JobWrite payload] -> NonEmpty (JobWrite payload)
forall a. a -> [a] -> NonEmpty a
:| [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
"sp21-key")) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp21-c2"))]
          batchHandler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
cbs = (JobRead payload -> m ()) -> [JobRead payload] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ JobRead payload -> m ()
each (NonEmpty (JobRead payload) -> [JobRead payload]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (JobRead payload)
jobs)
            where
              each :: JobRead payload -> m ()
each JobRead payload
job
                | JobRead payload -> Bool
forall p q t adm. Job p Int64 q t adm -> Bool
isRollup JobRead payload
job = BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs 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
mkSimple Text
"sp21-root" = BatchCallbacks m payload (Maybe [Text])
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result
-> JobRead payload -> NonEmpty (JobWrite payload) -> m ()
spawn BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job NonEmpty (JobWrite payload)
kids
                | Bool
otherwise = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
childrenRef) m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BatchCallbacks m payload (Maybe [Text]) -> JobRead payload -> m ()
forall (m :: * -> *) payload result.
BatchCallbacks m payload result -> JobRead payload -> m ()
ack BatchCallbacks m payload (Maybe [Text])
cbs JobRead payload
job
      runM env $ void $ HL.insertJob (setMaxAttempts (Just 2) $ defaultJob (mkSimple "sp21-root"))
      config <- mkBatchedConfig 1 10 batchHandler

      withAsync (runM env $ runWorkerPool config {pollInterval = 0.05}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
20_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0) (Int64 -> Bool) -> IO Int64 -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)
      readIORef childrenRef `shouldReturn` 1
      dlq <- dlqAll env
      map (payload . DLQ.jobSnapshot) dlq `shouldBe` []

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"refuses a second spawn on a job whose round is uncommitted" ((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 (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 (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (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
5) (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"sp22-root")))
      claimed <- env -> m [JobRead payload] -> IO [JobRead payload]
forall a. env -> m a -> IO a
runM env
env (Int -> NominalDiffTime -> m [JobRead payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60) :: IO [JobRead payload]
      let job = [JobRead payload] -> JobRead payload
forall a. HasCallStack => [a] -> a
head [JobRead payload]
claimed
      again <-
        try $ runM env $ withDbTransaction $ do
          void $ HL.spawnChildren job (defaultJob (mkSimple "sp22-first") :| [])
          void $ HL.spawnChildren job (defaultJob (mkSimple "sp22-second") :| [])
      case again of
        Left (JobScopedFailure (Retryable JobRetryableException
_) [Int64]
ids) -> [Int64]
ids [Int64] -> [Int64] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job]
        Either JobScopedFailure ()
_ -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"a second spawn before the ack was not refused"
      runM env (HL.countJobs @payload) `shouldReturn` 1
      runM env $ void $ HL.cancelJobCascade @payload (primaryKey job)
      runM env (HL.countJobs @payload) `shouldReturn` 0

  String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Tree and Branch Cancel" (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
"throwTreeCancel deletes the entire tree (not DLQ'd)" ((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
        (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ m (Either Text (NonEmpty (JobRead payload))) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
        (m (Either Text (NonEmpty (JobRead payload))) -> m ())
-> m (Either Text (NonEmpty (JobRead payload))) -> m ()
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
mkSimple Text
"tc-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
mkSimple Text
"tc-mid"))
              (JobWrite payload -> JobTree payload
forall payload. JobWrite payload -> JobTree payload
JT.leaf (payload -> JobWrite payload
forall payload. payload -> JobWrite payload
defaultJob (Text -> payload
mkSimple Text
"tc-leaf1")) 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
mkSimple Text
"tc-leaf2"))])
              JobTree payload -> [JobTree payload] -> NonEmpty (JobTree payload)
forall a. a -> [a] -> NonEmpty a
:| []
          )
      config <- (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig ((JobRead payload -> m ()) -> IO (WorkerConfig m payload))
-> (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
forall a b. (a -> b) -> a -> b
$ \JobRead payload
job ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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
mkSimple Text
"tc-leaf1") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwTreeCancel Text
"abort everything")

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ [JobRead payload] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([JobRead payload] -> Bool) -> IO [JobRead payload] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
100 Int
0)

      let treePayloads =
            [ Text -> payload
mkSimple Text
"tc-root"
            , Text -> payload
mkSimple Text
"tc-mid"
            , Text -> payload
mkSimple Text
"tc-leaf1"
            , Text -> payload
mkSimple Text
"tc-leaf2"
            ]
      jobs <- runM env $ HL.listJobs @payload 100 0
      traverse_ (\payload
treePayload -> (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]
jobs [payload] -> [payload] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldNotContain` [payload
treePayload]) treePayloads
      dlqJobs <- dlqAll env
      traverse_ (\payload
treePayload -> (DLQJob payload -> payload) -> [DLQJob 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 -> 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) [DLQJob payload]
dlqJobs [payload] -> [payload] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldNotContain` [payload
treePayload]) treePayloads

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports each job of a force-cancelled batch exactly once" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      cancelledRef <- [Int64] -> IO (IORef [Int64])
forall a. a -> IO (IORef a)
newIORef ([] :: [Int64])
      startedRef <- newIORef (0 :: Int)
      let hooks =
            ObservabilityHooks m payload
forall (m :: * -> *) payload.
Applicative m =>
ObservabilityHooks m payload
defaultObservabilityHooks
              { onJobCancelled = \JobRead payload
job Text
_ ->
                  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef [Int64] -> ([Int64] -> ([Int64], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Int64]
cancelledRef (\[Int64]
seen -> (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
job Int64 -> [Int64] -> [Int64]
forall a. a -> [a] -> [a]
: [Int64]
seen, ()))
              }
          handler NonEmpty (JobRead payload)
jobs BatchCallbacks m payload (Maybe [Text])
_cbs = do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
startedRef (\Int
_ -> (NonEmpty (JobRead payload) -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty (JobRead payload)
jobs, ()))
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
longHandlerMicros
      Right (parent :| children) <-
        runM env
          $ HL.insertJobTree
          $ JT.rollup
            (defaultJob (mkSimple "fc-parent"))
            (JT.leaf (defaultJob (mkSimple "fc-1")) :| [JT.leaf (defaultJob (mkSimple "fc-2"))])
      config <- mkBatchedConfig 1 10 handler

      withAsync
        (runM env $ runWorkerPool config {pollInterval = 0.1, jobHeartbeatInterval = 0.2, observabilityHooks = hooks})
        $ \Async ()
_ -> do
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
startedRef
          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 (forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.forceCancelJob @payload (JobRead payload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead payload
parent))
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Int -> Bool) -> ([Int64] -> Int) -> [Int64] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int64] -> Bool) -> IO [Int64] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [Int64] -> IO [Int64]
forall a. IORef a -> IO a
readIORef IORef [Int64]
cancelledRef
          Int -> IO ()
threadDelay Int
settleMicros

      cancelled <- readIORef cancelledRef
      cancelled `shouldMatchList` map primaryKey children

    String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"throwBranchCancel deletes branch but resumes grandparent" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
      rootProcessedRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
      runM env
        $ void
        $ HL.insertJobTree
        $ JT.rollup
          (defaultJob (mkSimple "bc-root"))
          ( JT.rollup
              (defaultJob (mkSimple "bc-mid"))
              (JT.leaf (defaultJob (mkSimple "bc-leaf1")) :| [JT.leaf (defaultJob (mkSimple "bc-leaf2"))])
              :| []
          )
      config <- mkConfig $ \JobRead payload
job ->
        if 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
mkSimple Text
"bc-leaf1"
          then IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
throwBranchCancel Text
"abort this branch")
          else Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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
mkSimple Text
"bc-root") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
              IORef Bool -> (Bool -> (Bool, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
rootProcessedRef ((Bool -> (Bool, ())) -> IO ()) -> (Bool -> (Bool, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$
                \Bool
_ -> (Bool
True, ())

      withAsync (runM env $ runWorkerPool config {workerCount = 1, pollInterval = 0.1}) $ \Async ()
_ ->
        HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
rootProcessedRef

      readIORef rootProcessedRef `shouldReturn` True
      dlqJobs <- dlqAll env
      let allPayloads = [Text -> payload
mkSimple Text
"bc-root", Text -> payload
mkSimple Text
"bc-mid", Text -> payload
mkSimple Text
"bc-leaf1", Text -> payload
mkSimple Text
"bc-leaf2"]
      traverse_ (\payload
treePayload -> (DLQJob payload -> payload) -> [DLQJob 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 -> 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) [DLQJob payload]
dlqJobs [payload] -> [payload] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldNotContain` [payload
treePayload]) allPayloads
  where
    mkConfig :: (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
    mkConfig :: (JobRead payload -> m ()) -> IO (WorkerConfig m payload)
mkConfig JobRead payload -> m ()
action = Int
-> JobHandler m payload (ResultOf m payload)
-> IO (WorkerConfig m payload)
forall (n :: * -> *) (m :: * -> *) payload.
(MonadArbiter n, MonadIO m) =>
Int
-> JobHandler n payload (ResultOf n payload)
-> m (WorkerConfig n payload)
transactionalWorkerConfig Int
10 ((JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler (\JobRead payload
job -> JobRead payload -> m ()
action JobRead payload
job m () -> m (Maybe [Text]) -> m (Maybe [Text])
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe [Text] -> m (Maybe [Text])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Text]
forall a. Maybe a
Nothing :: Maybe [Text])))
    archived :: env -> IO [Archive.ArchiveJob payload]
    archived :: env -> IO [ArchiveJob payload]
archived env
env = env -> m [ArchiveJob payload] -> IO [ArchiveJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [ArchiveJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs Int
100 Int
0)
    archivedNamed :: env -> Text -> IO (Maybe (Archive.ArchiveJob payload))
    archivedNamed :: env -> Text -> IO (Maybe (ArchiveJob payload))
archivedNamed env
env Text
name = (ArchiveJob payload -> Bool)
-> [ArchiveJob payload] -> Maybe (ArchiveJob 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
mkSimple Text
name) (payload -> Bool)
-> (ArchiveJob payload -> payload) -> ArchiveJob 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)
-> (ArchiveJob payload -> JobRead payload)
-> ArchiveJob payload
-> payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArchiveJob payload -> JobRead payload
forall payload. ArchiveJob payload -> JobSnapshot payload
Archive.jobSnapshot) ([ArchiveJob payload] -> Maybe (ArchiveJob payload))
-> IO [ArchiveJob payload] -> IO (Maybe (ArchiveJob payload))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> env -> IO [ArchiveJob payload]
archived env
env
    dlqAll :: env -> IO [DLQ.DLQJob payload]
    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
100 Int
0)
    mkBatchedConfig
      :: Int
      -> Int
      -> (NonEmpty (JobRead payload) -> BatchCallbacks m payload (ResultOf m payload) -> m ())
      -> IO (WorkerConfig m payload)
    mkBatchedConfig :: Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks m payload (ResultOf m payload) -> m ())
-> IO (WorkerConfig m payload)
mkBatchedConfig = Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks m payload (ResultOf m payload) -> m ())
-> IO (WorkerConfig m payload)
forall (n :: * -> *) (m :: * -> *) payload.
(MonadArbiter n, MonadIO m) =>
Int
-> Int
-> (NonEmpty (JobRead payload)
    -> BatchCallbacks n payload (ResultOf n payload) -> n ())
-> m (WorkerConfig n payload)
batchedWorkerConfig

-- | Env-owned LISTEN hub suite. A poll-only test runs jobs with the listener removed.
-- The queue under test declares @()@ as its result type.
-- The queue table needs notify triggers and 'mkEnv' must give an env with a shared listener.
-- It terminates other connections on the database whose LISTEN query names the schema.
listenerSpec
  :: forall payload m env
   . ( QueueOperation m payload
     , RegistryAdmissionPolicies (RegistryOf m)
     , RegistryTables (RegistryOf m)
     , ResultOf m payload ~ ()
     )
  => TestBackend payload m env
  -> Spec
listenerSpec :: forall payload (m :: * -> *) env.
(QueueOperation m payload,
 RegistryAdmissionPolicies (RegistryOf m),
 RegistryTables (RegistryOf m), ResultOf m payload ~ ()) =>
TestBackend payload m env -> Spec
listenerSpec TestBackend {Text
schema :: Text
schema :: forall payload (m :: * -> *) env. TestBackend payload m env -> Text
schema, ByteString
connStr :: ByteString
connStr :: forall payload (m :: * -> *) env.
TestBackend payload m env -> ByteString
connStr, Text -> payload
mkSimple :: forall payload (m :: * -> *) env.
TestBackend payload m env -> Text -> payload
mkSimple :: Text -> payload
mkSimple, IO env
mkEnv :: forall payload (m :: * -> *) env.
TestBackend payload m env -> IO env
mkEnv :: IO env
mkEnv, env -> env
pollOnly :: env -> env
pollOnly :: forall payload (m :: * -> *) env.
TestBackend payload m env -> env -> env
pollOnly, (JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler :: forall payload (m :: * -> *) env.
TestBackend payload m env
-> (JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler :: (JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler, forall a. env -> m a -> IO a
runM :: forall payload (m :: * -> *) env.
TestBackend payload m env -> forall a. env -> m a -> IO a
runM :: forall a. env -> m a -> IO a
runM} =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"listener" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    IO env -> SpecWith env -> Spec
forall a. IO a -> SpecWith a -> Spec
before IO env
mkEnv (SpecWith env -> Spec) -> SpecWith env -> Spec
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
"wakes the dispatcher on NOTIFY under a high poll interval" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
        ref <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
        config :: WorkerConfig m payload <- runM env $ transactionalWorkerConfig 1 (mkHandler (bumping ref))
        let workerConfig = WorkerConfig m payload
config {workerCount = 1, pollInterval = 300, jitter = NoJitter}
        withAsync (runM env $ runWorkerPool workerConfig) $ \Async ()
_ -> do
          Int -> IO ()
threadDelay Int
listenerStartMicros
          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 (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (JobWrite payload -> m (Maybe (JobRead payload)))
-> JobWrite payload -> m (Maybe (JobRead 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
"g1") (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
mkSimple Text
"notify")
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
          IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
1)

      String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-subscribes after a reconnect under a high poll interval" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
        ref <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
        config :: WorkerConfig m payload <- runM env $ transactionalWorkerConfig 1 (mkHandler (bumping ref))
        let workerConfig = WorkerConfig m payload
config {workerCount = 1, pollInterval = 300, jitter = NoJitter}
        withAsync (runM env $ runWorkerPool workerConfig) $ \Async ()
_ -> do
          Int -> IO ()
threadDelay Int
listenerStartMicros
          ByteString -> Text -> IO ()
terminateBackendsMatching ByteString
connStr (Text
"LISTEN%" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%")
          Int -> IO ()
threadDelay Int
reconnectMicros
          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 (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (JobWrite payload -> m (Maybe (JobRead payload)))
-> JobWrite payload -> m (Maybe (JobRead 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
"g1") (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
mkSimple Text
"after-reconnect")
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
8_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
          IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
1)

      String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"shares one listener connection across registrants on the same env" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env ->
        IO (Maybe Listener) -> (Listener -> IO ()) -> IO ()
withSharedListener (env -> m (Maybe Listener) -> IO (Maybe Listener)
forall a. env -> m a -> IO a
runM env
env m (Maybe Listener)
forall (m :: * -> *). MonadArbiter m => m (Maybe Listener)
getListener) ((Listener -> IO ()) -> IO ()) -> (Listener -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Listener
listener -> do
          let chanA :: ByteString
chanA = Text -> ByteString
TE.encodeUtf8 (Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_dedup_a")
              chanB :: ByteString
chanB = Text -> ByteString
TE.encodeUtf8 (Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_dedup_b")
          Listener
-> HubLog
-> [(ByteString, Notification -> IO ())]
-> (STM Bool -> IO ())
-> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Listener
-> HubLog
-> [(ByteString, Notification -> m ())]
-> (STM Bool -> m a)
-> m a
Listen.withChannels Listener
listener HubLog
quietHubLog [(ByteString
chanA, Notification -> IO ()
ignoreNotif)] ((STM Bool -> IO ()) -> IO ()) -> (STM Bool -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \STM Bool
readyA ->
            Listener
-> HubLog
-> [(ByteString, Notification -> IO ())]
-> (STM Bool -> IO ())
-> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Listener
-> HubLog
-> [(ByteString, Notification -> m ())]
-> (STM Bool -> m a)
-> m a
Listen.withChannels Listener
listener HubLog
quietHubLog [(ByteString
chanB, Notification -> IO ()
ignoreNotif)] ((STM Bool -> IO ()) -> IO ()) -> (STM Bool -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \STM Bool
readyB -> do
              HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM Bool
readyA)
              HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM Bool
readyB)
              ByteString -> Text -> IO Int
listenerConnectionCount ByteString
connStr Text
schema IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
1)

      String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keeps a shared channel live after an overlapping registrant leaves" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env ->
        IO (Maybe Listener) -> (Listener -> IO ()) -> IO ()
withSharedListener (env -> m (Maybe Listener) -> IO (Maybe Listener)
forall a. env -> m a -> IO a
runM env
env m (Maybe Listener)
forall (m :: * -> *). MonadArbiter m => m (Maybe Listener)
getListener) ((Listener -> IO ()) -> IO ()) -> (Listener -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Listener
listener -> do
          ref <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
          let sharedName = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_shrink_shared"
              extraName = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_shrink_extra"
              sharedChan = Text -> ByteString
TE.encodeUtf8 Text
sharedName
              extraChan = Text -> ByteString
TE.encodeUtf8 Text
extraName
          Listen.withChannels listener quietHubLog [(sharedChan, bumpNotif ref)] $ \STM Bool
readyOuter -> do
            HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM Bool
readyOuter)
            -- The inner registrant adds an extra channel, then leaves, shrinking the
            -- desired set back to the shared channel and issuing an UNLISTEN.
            Listener
-> HubLog
-> [(ByteString, Notification -> IO ())]
-> (STM Bool -> IO ())
-> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
Listener
-> HubLog
-> [(ByteString, Notification -> m ())]
-> (STM Bool -> m a)
-> m a
Listen.withChannels Listener
listener HubLog
quietHubLog [(ByteString
sharedChan, Notification -> IO ()
ignoreNotif), (ByteString
extraChan, Notification -> IO ()
ignoreNotif)] ((STM Bool -> IO ()) -> IO ()) -> (STM Bool -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \STM Bool
readyInner ->
              HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM Bool
readyInner)
            ByteString -> Text -> IO ()
notifyChannel ByteString
connStr Text
sharedName
            HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
            IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
1)

      String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"isolates a throwing channel handler from the others" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env ->
        IO (Maybe Listener) -> (Listener -> IO ()) -> IO ()
withSharedListener (env -> m (Maybe Listener) -> IO (Maybe Listener)
forall a. env -> m a -> IO a
runM env
env m (Maybe Listener)
forall (m :: * -> *). MonadArbiter m => m (Maybe Listener)
getListener) ((Listener -> IO ()) -> IO ()) -> (Listener -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Listener
listener -> do
          good <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
          warned <- newIORef (0 :: Int)
          let hubLog = HubLog
quietHubLog {Listen.hubWarn = \Text
_ -> IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
warned}
              goodName = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_iso_good"
              badName = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_iso_bad"
              handlers =
                [ (Text -> ByteString
TE.encodeUtf8 Text
badName, \Notification
_ -> IOError -> IO ()
forall a. HasCallStack => IOError -> IO a
ioError (String -> IOError
userError String
"boom"))
                , (Text -> ByteString
TE.encodeUtf8 Text
goodName, IORef Int -> Notification -> IO ()
bumpNotif IORef Int
good)
                ]
          Listen.withChannels listener hubLog handlers $ \STM Bool
ready -> do
            HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM Bool
ready)
            ByteString -> Text -> IO ()
notifyChannel ByteString
connStr Text
badName
            HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
warned
            ByteString -> Text -> IO ()
notifyChannel ByteString
connStr Text
goodName
            HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
good
            IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
good IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
1)

    IO env -> SpecWith env -> Spec
forall a. IO a -> SpecWith a -> Spec
before (env -> env
pollOnly (env -> env) -> IO env -> IO env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO env
mkEnv) (SpecWith env -> Spec) -> SpecWith env -> Spec
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
"processes jobs poll-only when the listener is disabled" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
        ref <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
        config :: WorkerConfig m payload <- runM env $ transactionalWorkerConfig 1 (mkHandler (bumping ref))
        let workerConfig = WorkerConfig m payload
config {workerCount = 1, pollInterval = 0.2, jitter = NoJitter}
        withAsync (runM env $ runWorkerPool workerConfig) $ \Async ()
_ -> do
          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 (m (Maybe (JobRead payload)) -> m ())
-> m (Maybe (JobRead payload)) -> m ()
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 (JobWrite payload -> m (Maybe (JobRead payload)))
-> JobWrite payload -> m (Maybe (JobRead 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
"g1") (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
mkSimple Text
"poll")
          HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
10_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref
          IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
ref IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
1)

-- | Run against the env's shared listener, failing when the env is poll-only.
withSharedListener :: IO (Maybe Listen.Listener) -> (Listen.Listener -> IO ()) -> IO ()
withSharedListener :: IO (Maybe Listener) -> (Listener -> IO ()) -> IO ()
withSharedListener IO (Maybe Listener)
getShared Listener -> IO ()
continue =
  IO (Maybe Listener)
getShared IO (Maybe Listener) -> (Maybe Listener -> 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
>>= IO () -> (Listener -> IO ()) -> Maybe Listener -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"expected a shared listener, got poll-only") Listener -> IO ()
continue

-- | Channel handler that ignores the notification.
ignoreNotif :: Listen.Notification -> IO ()
ignoreNotif :: Notification -> IO ()
ignoreNotif = IO () -> Notification -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Channel handler that bumps a counter.
bumpNotif :: IORef Int -> Listen.Notification -> IO ()
bumpNotif :: IORef Int -> Notification -> IO ()
bumpNotif IORef Int
ref = IO () -> Notification -> IO ()
forall a b. a -> b -> a
const (IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
ref)

-- | Job action that bumps a counter.
bumping :: (MonadIO m) => IORef Int -> JobRead p -> m ()
bumping :: forall (m :: * -> *) p. MonadIO m => IORef Int -> JobRead p -> m ()
bumping IORef Int
ref JobRead p
_job = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
ref)

-- | Env-owned LISTEN hub suite for two queues sharing one env, one worker pool per
-- queue. Checks that a shared hub wakes each pool for its own queue only. The backend's queue is
-- queue A. Queue A gets its notify trigger from 'Arbiter.Test.Setup.setupOnce' with
-- notify on. Queue B gets its notify trigger from 'Arbiter.Test.Setup.addQueueTable'
-- with notify on. 'mkFreshEnv' must give an env with a listener.
multiQueueListenerSpec
  :: forall payloadA payloadB m env
   . ( QueueOperation m payloadA
     , QueueOperation m payloadB
     , RegistryAdmissionPolicies (RegistryOf m)
     , RegistryTables (RegistryOf m)
     , ResultOf m payloadA ~ ()
     , ResultOf m payloadB ~ ()
     )
  => TestBackend payloadA m env
  -> Text
  -- ^ Queue B table name, also its LISTEN channel prefix.
  -> (Text -> payloadB)
  -- ^ Construct a queue B payload.
  -> ((JobRead payloadB -> m ()) -> JobHandler m payloadB ())
  -- ^ Adapt a queue B job action into the backend's handler shape.
  -> Spec
multiQueueListenerSpec :: forall payloadA payloadB (m :: * -> *) env.
(QueueOperation m payloadA, QueueOperation m payloadB,
 RegistryAdmissionPolicies (RegistryOf m),
 RegistryTables (RegistryOf m), ResultOf m payloadA ~ (),
 ResultOf m payloadB ~ ()) =>
TestBackend payloadA m env
-> Text
-> (Text -> payloadB)
-> ((JobRead payloadB -> m ()) -> JobHandler m payloadB ())
-> Spec
multiQueueListenerSpec TestBackend {table :: forall payload (m :: * -> *) env. TestBackend payload m env -> Text
table = Text
tableA, ByteString
connStr :: forall payload (m :: * -> *) env.
TestBackend payload m env -> ByteString
connStr :: ByteString
connStr, mkSimple :: forall payload (m :: * -> *) env.
TestBackend payload m env -> Text -> payload
mkSimple = Text -> payloadA
mkPayloadA, IO env
mkFreshEnv :: forall payload (m :: * -> *) env.
TestBackend payload m env -> IO env
mkFreshEnv :: IO env
mkFreshEnv, env -> IO ()
destroyEnv :: env -> IO ()
destroyEnv :: forall payload (m :: * -> *) env.
TestBackend payload m env -> env -> IO ()
destroyEnv, (JobRead payloadA -> m (ResultOf m payloadA))
-> JobHandler m payloadA (ResultOf m payloadA)
mkHandler :: forall payload (m :: * -> *) env.
TestBackend payload m env
-> (JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler :: (JobRead payloadA -> m (ResultOf m payloadA))
-> JobHandler m payloadA (ResultOf m payloadA)
mkHandler, forall a. env -> m a -> IO a
runM :: forall payload (m :: * -> *) env.
TestBackend payload m env -> forall a. env -> m a -> IO a
runM :: forall a. env -> m a -> IO a
runM} Text
tableB Text -> payloadB
mkPayloadB (JobRead payloadB -> m ()) -> JobHandler m payloadB ()
mkHandlerB =
  ((env -> IO ()) -> IO ()) -> SpecWith env -> Spec
forall a. (ActionWith a -> IO ()) -> SpecWith a -> Spec
around (IO env -> (env -> IO ()) -> (env -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO env
mkFreshEnv env -> IO ()
destroyEnv) (SpecWith env -> Spec) -> SpecWith env -> Spec
forall a b. (a -> b) -> a -> b
$
    String -> SpecWith env -> SpecWith env
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"multi-queue listener" (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
"wakes each pool only for its own queue's jobs under a high poll interval" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env -> do
        refA <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
        refB <- newIORef (0 :: Int)
        cfgA :: WorkerConfig m payloadA <-
          runM env $ transactionalWorkerConfig 1 (mkHandler (bumping refA :: JobRead payloadA -> m ()))
        cfgB :: WorkerConfig m payloadB <-
          runM env $ transactionalWorkerConfig 1 (mkHandlerB (bumping refB :: JobRead payloadB -> m ()))
        let poolA = WorkerConfig m payloadA
cfgA {workerCount = 1, pollInterval = 300, jitter = NoJitter}
            poolB = WorkerConfig m payloadB
cfgB {workerCount = 1, pollInterval = 300, jitter = NoJitter}
        withAsync (runM env $ runWorkerPool poolA) $ \Async ()
_ ->
          IO () -> (Async () -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync (env -> m () -> IO ()
forall a. env -> m a -> IO a
runM env
env (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ WorkerConfig m payloadB -> m ()
forall payload (m :: * -> *).
(RegistryAdmissionPolicies (RegistryOf m),
 EncodeJobResult (ResultOf m payload), QueueOperation m payload,
 RegistryTables (RegistryOf m)) =>
WorkerConfig m payload -> m ()
runWorkerPool WorkerConfig m payloadB
poolB) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
_ -> do
            Int -> IO ()
threadDelay Int
listenerStartMicros
            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 payloadA)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (JobRead payloadA)) -> m ())
-> m (Maybe (JobRead payloadA)) -> m ()
forall a b. (a -> b) -> a -> b
$ JobWrite payloadA -> m (Maybe (JobRead payloadA))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payloadA -> JobWrite payloadA
forall payload. payload -> JobWrite payload
defaultJob (Text -> payloadA
mkPayloadA Text
"a1"))
            HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
refA
            Int -> IO ()
threadDelay Int
strayWakeMicros
            IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
refB IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
0)

            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 payloadB)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (JobRead payloadB)) -> m ())
-> m (Maybe (JobRead payloadB)) -> m ()
forall a b. (a -> b) -> a -> b
$ JobWrite payloadB -> m (Maybe (JobRead payloadB))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (payloadB -> JobWrite payloadB
forall payload. payload -> JobWrite payload
defaultJob (Text -> payloadB
mkPayloadB Text
"b1"))
            HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
refB
            Int -> IO ()
threadDelay Int
strayWakeMicros
            IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
refA IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
1)

      String -> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"routes a NOTIFY only to the owning queue's channel handler" ((env -> IO ()) -> SpecWith (Arg (env -> IO ())))
-> (env -> IO ()) -> SpecWith (Arg (env -> IO ()))
forall a b. (a -> b) -> a -> b
$ \env
env ->
        IO (Maybe Listener) -> (Listener -> IO ()) -> IO ()
withSharedListener (env -> m (Maybe Listener) -> IO (Maybe Listener)
forall a. env -> m a -> IO a
runM env
env m (Maybe Listener)
forall (m :: * -> *). MonadArbiter m => m (Maybe Listener)
getListener) ((Listener -> IO ()) -> IO ()) -> (Listener -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Listener
listener -> do
          refA <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
          refB <- newIORef (0 :: Int)
          let chanA = Text -> ByteString
TE.encodeUtf8 (Text -> Text
Schema.notificationChannelForTable Text
tableA)
              chanB = Text -> ByteString
TE.encodeUtf8 (Text -> Text
Schema.notificationChannelForTable Text
tableB)
              handlers =
                [ (ByteString
chanA, IORef Int -> Notification -> IO ()
bumpNotif IORef Int
refA)
                , (ByteString
chanB, IORef Int -> Notification -> IO ()
bumpNotif IORef Int
refB)
                ]
          Listen.withChannels listener quietHubLog handlers $ \STM Bool
ready -> do
            HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM Bool
ready)
            ByteString -> Text -> IO ()
notifyChannel ByteString
connStr (Text -> Text
Schema.notificationChannelForTable Text
tableA)
            HasCallStack => Int -> IO Bool -> IO ()
Int -> IO Bool -> IO ()
waitUntil Int
5_000 (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> IO Int -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
refA
            Int -> IO ()
threadDelay Int
strayWakeMicros
            IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
refA IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
1)
            IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
refB IO Int -> (Int -> 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
>>= (Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
0)

-- | Issue a raw @NOTIFY@ on a channel over a throwaway connection.
notifyChannel :: ByteString -> Text -> IO ()
notifyChannel :: ByteString -> Text -> IO ()
notifyChannel ByteString
connStr Text
chan =
  ByteString -> (Connection -> IO ()) -> IO ()
forall a. ByteString -> (Connection -> IO a) -> IO a
withConn ByteString
connStr ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
    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
$ Connection -> Query -> Only Identifier -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
PG.execute Connection
conn Query
"NOTIFY ?" (Identifier -> Only Identifier
forall a. a -> Only a
Only (Text -> Identifier
Identifier Text
chan))