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

-- | Parameterized worker-pool test suite, instantiated for each 'Arbiter.Core.MonadArbiter.MonadArbiter' backend.
module Arbiter.Worker.TestKit
  ( workerSpec
  , listenerSpec
  , multiQueueListenerSpec
  ) where

import Arbiter.Core.Exceptions
  ( throwBranchCancel
  , throwJobGone
  , throwNack
  , throwPermanent
  , throwRetryable
  , throwTreeCancel
  )
import Arbiter.Core.FailureGate qualified as FailureGate
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.Schema qualified as Schema
import Arbiter.Core.Job.Types
  ( JobRead
  , ObservabilityHooks (..)
  , attempts
  , dayRetention
  , defaultJob
  , defaultObservabilityHooks
  , groupKey
  , jobKind
  , kindOf
  , parentId
  , payload
  , payloadKeys
  , primaryKey
  , setArchiveFor
  , setGroupKey
  , setMaxAttempts
  )
import Arbiter.Core.JobTree ((<~~))
import Arbiter.Core.JobTree qualified as JT
import Arbiter.Core.Listen qualified as Listen
import Arbiter.Core.MonadArbiter (JobHandler, RegistryOf, ResultOf, getListener, withDbTransaction)
import Arbiter.Core.QueueRegistry (RegistryTables)
import Arbiter.Worker (runWorkerPool)
import Arbiter.Worker.BackoffStrategy (BackoffStrategy (Constant), Jitter (NoJitter))
import Arbiter.Worker.Config
  ( BatchCallbacks
  , WorkerConfig (..)
  , ack
  , ackAll
  , ackAllWith
  , ackWith
  , cancelBranch
  , cancelTree
  , defaultBatchedWorkerConfig
  , failPermanent
  , failRetry
  , nack
  , transactionalWorkerConfig
  )
import Control.Concurrent (threadDelay)
import Control.Monad (unless, void, when)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (toJSON)
import Data.ByteString (ByteString)
import Data.Foldable (toList, traverse_)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
import Data.Int (Int64)
import Data.List (find, partition)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (isJust, isNothing, listToMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Database.PostgreSQL.Simple (Only (..), close, connectPostgreSQL)
import Database.PostgreSQL.Simple qualified as PG
import Database.PostgreSQL.Simple.Types (Identifier (..))
import Test.Hspec
import UnliftIO (atomically, bracket)
import UnliftIO.Async (withAsync)

-- | Build a worker-pool test suite for the given 'Arbiter.Core.MonadArbiter.MonadArbiter' runner.
--
-- @mkSimple@/@mkFailing@ construct the backend's payload, @mkHandler@ adapts a
-- plain job action into the backend's 'JobHandler' shape (some backends pass a
-- connection, others do not), and @runM@ runs a backend action in 'IO'.
--
-- 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
     )
  => (Text -> payload)
  -- ^ Construct a simple task payload
  -> (Int -> payload)
  -- ^ Construct a failing task payload
  -> ((JobRead payload -> m (ResultOf m payload)) -> JobHandler m payload (ResultOf m payload))
  -- ^ Adapt a job action into the backend's handler shape
  -> (forall a. env -> m a -> IO a)
  -- ^ Runner function (e.g. runSimpleDb env or runOrvilleTest env)
  -> SpecWith env
workerSpec :: forall payload (m :: * -> *) env.
(Eq payload, QueueOperation m payload,
 RegistryAdmissionPolicies (RegistryOf m),
 RegistryTables (RegistryOf m), ResultOf m payload ~ Maybe [Text],
 Show payload) =>
(Text -> payload)
-> (Int -> payload)
-> ((JobRead payload -> m (ResultOf m payload))
    -> JobHandler m payload (ResultOf m payload))
-> (forall a. env -> m a -> IO a)
-> SpecWith env
workerSpec Text -> payload
mkSimple Int -> payload
mkFailing (JobRead payload -> m (ResultOf m payload))
-> JobHandler m payload (ResultOf m payload)
mkHandler forall a. env -> m a -> IO a
runM = 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.
JobRecord 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 500_000
        liftIO $ atomicModifyIORef' activeRef $ \Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, ())
        liftIO $ atomicModifyIORef' completedRef $ \Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ())
      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)
      -- mkFailing 3 marks a job that throws on its 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 -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
          pure (length dlqJobs == 1)
        dlqJobs <- env -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
        length dlqJobs `shouldBe` 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
$ do
          arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (any ((== mkSimple "arch-done") . payload . Archive.jobSnapshot) arch)
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        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
$ do
          arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (any ((== mkSimple "arch-byid") . payload . Archive.jobSnapshot) arch)
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        let jid = JobRead payload -> Int64
forall payload key q insertedAt adm.
JobRecord 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.getArchivedJobById @payload jid
        fmap (payload . Archive.jobSnapshot) found `shouldBe` Just (mkSimple "arch-byid")
        miss <- runM env $ HL.getArchivedJobById @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.listArchivedJobsByGroupKey @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.listArchivedJobsByGroupKey @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
300_000
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        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
$ do
            arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
            pure (any ((== mkSimple "arch-purge") . payload . Archive.jobSnapshot) 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 -> 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
            pure (not (any ((== mkSimple "arch-purge") . payload . Archive.jobSnapshot) arch))

    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.
JobRecord 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 -> 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (countReJob arch == 1)
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        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 <- runM env $ HL.listArchiveJobs @payload 100 0
          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
$ do
          arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (any ((== mkSimple "purge-one") . payload . Archive.jobSnapshot) arch)
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        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 <- runM env $ HL.listArchiveJobs @payload 100 0
        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 -> 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (length arch == 2)
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        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 <- runM env $ HL.listArchiveJobs @payload 100 0
        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 -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
          pure (any ((== mkSimple "dlq-arch") . payload . DLQ.jobSnapshot) dlq)
        dlq <- env -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
        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 $ do
          arch <- runM env $ HL.listArchiveJobs @payload 100 0
          pure (any ((== mkSimple "dlq-arch") . payload . Archive.jobSnapshot) 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
$ do
          arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (any ((== mkSimple "null-result") . payload . Archive.jobSnapshot) arch)
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        let mine = (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
"null-result") (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.
JobRecord 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
        (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
$ do
          arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (any ((== mkSimple "just-result") . payload . Archive.jobSnapshot) arch)
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        let mine = (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
"just-result") (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.
JobRecord 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
        (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
300_000
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        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
$ do
          arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (any ((== mkSimple "arch-child") . payload . Archive.jobSnapshot) arch)
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        let childRow = (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
"arch-child") (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.
JobRecord 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
        (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
$ do
          arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (any ((== mkSimple "arch-attempts") . payload . Archive.jobSnapshot) arch)
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        let mine = (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
"arch-attempts") (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.
JobRecord 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
        -- 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.
JobRecord 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 -> 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (isJust (snap "pl-child" arch) && isJust (snap "pl-root" arch))
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        -- 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.
JobRecord 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 -> 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          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 -> 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
          pure (not (has "purge-expired" arch))
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        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
300_000
        arch <- 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 =>
Int -> Int -> m [ArchiveJob payload]
HL.listArchiveJobs @payload Int
100 Int
0
        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.
JobRecord 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
1_000_000
      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 -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
retryRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ()))
              , onJobFailedAndMovedToDLQ = \Text
_ JobRead payload
_ -> 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
dlqRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ()))
              }
      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 -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
attemptsRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ()))
        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 -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
          length dlqAfterFirst `shouldBe` 0

          waitUntil 10_000 $ (== 1) <$> readIORef dlqRef
          dlqJobs <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
          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 -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
retryCalls (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ()))
              , onJobFailedAndMovedToDLQ = \Text
_ JobRead payload
_ -> 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
dlqCalls (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ()))
              }
      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 <- runM env (HL.listDLQJobs 10 0) :: IO [DLQ.DLQJob payload]
        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
10_000_000

      withAsync
        ( runM env $
            runWorkerPool
              config
                { workerCount = workerCnt
                , visibilityTimeout = 3
                , jobHeartbeatInterval = 1
                , pollInterval = 0.1
                , jitter = NoJitter
                }
        )
        $ \Async ()
_ -> do
          Int -> IO ()
threadDelay Int
8_000_000
          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.
JobRecord 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 :: * -> *).
JobOperation m payload =>
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.
JobRecord 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
200_000

      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
"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.
JobRecord 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 <- runM env $ HL.listArchiveJobs @payload 100 0
      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.
JobRecord 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 -> 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 200_000
        liftIO $ atomicModifyIORef' orderRef $ \[payload]
order -> (JobRead payload -> payload
forall payload key q insertedAt adm.
JobRecord 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.
JobRecord 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.
JobRecord 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
200_000
      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.
JobRecord 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 -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
successRef (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ()))
              }
      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
200_000
        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 -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
heartbeatRef ((Int -> (Int, ())) -> IO ()) -> (Int -> (Int, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ())
              }
      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
3_000_000
      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.
JobRecord 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
"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 = \Text
errMsg 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, 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.
JobRecord 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.
JobRecord 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 100_000

      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.
JobRecord 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 100_000

      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 100_000

      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 100_000

      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 100_000

      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 -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
          pure (length dlqJobs == 2)
        dlqJobs <- env -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
        length dlqJobs `shouldBe` 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 100_000

      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 -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
          pure (length dlqJobs == 2)
        dlqJobs <- env -> m [DLQJob payload] -> IO [DLQJob payload]
forall a. env -> m a -> IO a
runM env
env (Int -> Int -> m [DLQJob payload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> Int -> m [DLQJob payload]
HL.listDLQJobs Int
10 Int
0) :: IO [DLQ.DLQJob payload]
        length dlqJobs `shouldBe` 2
        let dlqFor Text
name = [DLQJob payload] -> DLQJob payload
forall a. HasCallStack => [a] -> a
head ([DLQJob payload] -> DLQJob payload)
-> [DLQJob payload] -> DLQJob payload
forall a b. (a -> b) -> a -> b
$ (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter ((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.
JobRecord 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
        attempts (DLQ.jobSnapshot (dlqFor "G1-1")) `shouldBe` 2
        attempts (DLQ.jobSnapshot (dlqFor "G1-2")) `shouldBe` 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.
JobRecord 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.
JobRecord 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 100_000

      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
"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 -> 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) :: IO [DLQ.DLQJob payload]
          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.
JobRecord 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
6_000_000
            (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.
JobRecord 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 100_000

      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.
JobRecord 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.
JobRecord 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 100_000

      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 100_000

      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.
JobRecord 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 100_000

      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.
JobRecord 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.
JobRecord 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 -> 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) :: IO [DLQ.DLQJob payload]
        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 -> (Int -> (Int, ())) -> IO ()
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, ()))
            (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 -> 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) :: IO [DLQ.DLQJob payload]
          pure (any ((== mkSimple "fr-job") . payload . DLQ.jobSnapshot) dlq)
        dlq <- 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) :: IO [DLQ.DLQJob payload]
        let mine = (DLQJob payload -> Bool) -> [DLQJob payload] -> [DLQJob payload]
forall a. (a -> Bool) -> [a] -> [a]
filter ((payload -> payload -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> payload
mkSimple Text
"fr-job") (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.
JobRecord 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]
dlq
        attempts (DLQ.jobSnapshot (head mine)) `shouldBe` 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 -> 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) :: IO [DLQ.DLQJob payload]
          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.
JobRecord 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
300_000
          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.
JobRecord 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.
JobRecord 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 -> (Int -> (Int, ())) -> IO ()
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, ()))
            (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
1_500_000
            (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
400_000
                  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.
JobRecord 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.
JobRecord 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
300_000
          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.
JobRecord 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.
JobRecord 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.
JobRecord 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.
JobRecord 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
10_000_000
      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 300_000

      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.
JobRecord 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.
JobRecord 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.
JobRecord 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.
JobRecord 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
10_000_000
      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 300_000

      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.
JobRecord 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 :: * -> *).
JobOperation m payload =>
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 -> 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) :: IO [DLQ.DLQJob payload]
          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
"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.
JobRecord 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
"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.
JobRecord 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 100_000

      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 100_000

      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.
JobRecord 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 100_000

      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
"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.
JobRecord 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.
JobRecord 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 <- runM env $ HL.listDLQJobs @payload 100 0
      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.
JobRecord 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.
JobRecord 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
10_000_000
      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.
JobRecord 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
300_000

      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.
JobRecord 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.
JobRecord 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 <- runM env $ HL.listDLQJobs @payload 100 0
      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.
JobRecord 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])))
    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)
defaultBatchedWorkerConfig

-- | Env-owned LISTEN hub test suite, instantiated for each backend. Under a high
-- @pollInterval@ only the NOTIFY can wake the dispatcher in time. Completion
-- proves the listener fired.
listenerSpec
  :: forall payload m env
   . ( QueueOperation m payload
     , RegistryAdmissionPolicies (RegistryOf m)
     , RegistryTables (RegistryOf m)
     , ResultOf m payload ~ ()
     )
  => Text
  -- ^ Schema\/table name, also the LISTEN channel prefix
  -> ByteString
  -- ^ Connection string, for terminating the listener backend
  -> (Text -> payload)
  -- ^ Construct a task payload
  -> IO env
  -- ^ Create an env whose listener is enabled
  -> IO env
  -- ^ Create an env with the listener disabled (poll-only)
  -> (env -> IO ())
  -- ^ Release an env built by the actions above
  -> ((JobRead payload -> m ()) -> JobHandler m payload ())
  -- ^ Adapt a job action into the backend's handler shape
  -> (forall a. env -> m a -> IO a)
  -- ^ Runner function
  -> Spec
listenerSpec :: forall payload (m :: * -> *) env.
(QueueOperation m payload,
 RegistryAdmissionPolicies (RegistryOf m),
 RegistryTables (RegistryOf m), ResultOf m payload ~ ()) =>
Text
-> ByteString
-> (Text -> payload)
-> IO env
-> IO env
-> (env -> IO ())
-> ((JobRead payload -> m ()) -> JobHandler m payload ())
-> (forall a. env -> m a -> IO a)
-> Spec
listenerSpec Text
schema ByteString
connStr Text -> payload
mkPayload IO env
mkEnv IO env
mkEnvPollOnly env -> IO ()
destroyEnv (JobRead payload -> m ()) -> JobHandler m payload ()
mkHandler 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
    ((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
mkEnv env -> IO ()
destroyEnv) (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 (counting ref))
        let workerConfig = WorkerConfig m payload
config {workerCount = 1, pollInterval = 300, jitter = NoJitter}
        withAsync (runM env $ runWorkerPool workerConfig) $ \Async ()
_ -> do
          Int -> IO ()
threadDelay Int
1_000_000
          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
mkPayload 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 (counting ref))
        let workerConfig = WorkerConfig m payload
config {workerCount = 1, pollInterval = 300, jitter = NoJitter}
        withAsync (runM env $ runWorkerPool workerConfig) $ \Async ()
_ -> do
          Int -> IO ()
threadDelay Int
1_000_000
          ByteString -> Text -> IO ()
killListener ByteString
connStr Text
schema
          Int -> IO ()
threadDelay Int
3_000_000
          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
mkPayload 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 ->
        env -> (Listener -> IO ()) -> IO ()
withSharedListener env
env ((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 ->
        env -> (Listener -> IO ()) -> IO ()
withSharedListener env
env ((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 ->
        env -> (Listener -> IO ()) -> IO ()
withSharedListener env
env ((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 ()
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)

    ((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
mkEnvPollOnly env -> IO ()
destroyEnv) (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 (counting 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
mkPayload 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)
  where
    counting :: IORef Int -> JobRead payload -> m ()
    counting :: IORef Int -> JobRead payload -> m ()
counting IORef Int
ref JobRead payload
_job = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Int -> IO ()
bumpRef IORef Int
ref)
    withSharedListener :: env -> (Listener -> IO ()) -> IO ()
withSharedListener env
env Listener -> IO ()
continue = do
      mListener <- 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
      case mListener of
        Maybe Listener
Nothing -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"expected a shared listener, got poll-only"
        Just Listener
listener -> Listener -> IO ()
continue Listener
listener

-- | A hub logger that swallows warn and error output.
quietHubLog :: Listen.HubLog
quietHubLog :: HubLog
quietHubLog =
  Listen.HubLog
    { hubRecovered :: Text -> IO ()
Listen.hubRecovered = IO () -> Text -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    , hubWarn :: Text -> IO ()
Listen.hubWarn = IO () -> Text -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    , hubError :: Text -> IO ()
Listen.hubError = IO () -> Text -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    , hubRepeatInterval :: NominalDiffTime
Listen.hubRepeatInterval = NominalDiffTime
FailureGate.defaultFailureRepeatInterval
    }

-- | 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 ()
bumpRef IORef Int
ref)

bumpRef :: IORef Int -> IO ()
bumpRef :: IORef Int -> IO ()
bumpRef IORef Int
ref = IORef Int -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
ref (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ()))

-- | Count distinct backends holding a LISTEN on any of this schema's channels.
listenerConnectionCount :: ByteString -> Text -> IO Int
listenerConnectionCount :: ByteString -> Text -> IO Int
listenerConnectionCount ByteString
connStr Text
schema =
  IO Connection
-> (Connection -> IO ()) -> (Connection -> IO Int) -> IO Int
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (ByteString -> IO Connection
connectPostgreSQL ByteString
connStr) Connection -> IO ()
close ((Connection -> IO Int) -> IO Int)
-> (Connection -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    rows <-
      forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query @_ @(Only Int)
        Connection
conn
        Query
"SELECT count(DISTINCT pid)::int \
        \FROM pg_stat_activity \
        \WHERE datname = current_database() \
        \  AND query LIKE 'LISTEN%' \
        \  AND query LIKE ?"
        (Text -> Only Text
forall a. a -> Only a
Only (Text
"%" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"%" :: Text))
    pure (maybe 0 fromOnly (listToMaybe rows))

-- | Terminate the env's listener backend, forcing the hub to reconnect.
killListener :: ByteString -> Text -> IO ()
killListener :: ByteString -> Text -> IO ()
killListener ByteString
connStr Text
schema =
  IO Connection
-> (Connection -> IO ()) -> (Connection -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (ByteString -> IO Connection
connectPostgreSQL ByteString
connStr) Connection -> IO ()
close ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
    IO [Only Bool] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Only Bool] -> IO ()) -> IO [Only Bool] -> IO ()
forall a b. (a -> b) -> a -> b
$
      forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query @_ @(Only Bool)
        Connection
conn
        Query
"SELECT pg_terminate_backend(pid) \
        \FROM pg_stat_activity \
        \WHERE pid <> pg_backend_pid() \
        \  AND datname = current_database() \
        \  AND query LIKE ?"
        (Text -> Only Text
forall a. a -> Only a
Only (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
"%" :: Text))

-- | Env-owned LISTEN hub test suite for two queues sharing one env, one worker
-- pool per queue. Each queue's job-arrival channel is derived from its table
-- name. These check that a shared hub wakes each pool for its own queue only.
-- The registry must map @payloadA@ to the
-- @tableA@ queue and @payloadB@ to @tableB@.
multiQueueListenerSpec
  :: forall payloadA payloadB m env
   . ( QueueOperation m payloadA
     , QueueOperation m payloadB
     , RegistryAdmissionPolicies (RegistryOf m)
     , RegistryTables (RegistryOf m)
     , ResultOf m payloadA ~ ()
     , ResultOf m payloadB ~ ()
     )
  => Text
  -- ^ Queue A table name, also its LISTEN channel prefix
  -> Text
  -- ^ Queue B table name, also its LISTEN channel prefix
  -> ByteString
  -- ^ Connection string, for issuing a raw NOTIFY
  -> (Text -> payloadA)
  -- ^ Construct a queue A payload
  -> (Text -> payloadB)
  -- ^ Construct a queue B payload
  -> IO env
  -- ^ Create an env whose listener is enabled, with both queue tables set up
  -> (env -> IO ())
  -- ^ Release an env built by the action above
  -> (forall p. (JobRead p -> m ()) -> JobHandler m p ())
  -- ^ Adapt a job action into the backend's handler shape
  -> (forall a. env -> m a -> IO a)
  -- ^ Runner function
  -> 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 ~ ()) =>
Text
-> Text
-> ByteString
-> (Text -> payloadA)
-> (Text -> payloadB)
-> IO env
-> (env -> IO ())
-> (forall p. (JobRead p -> m ()) -> JobHandler m p ())
-> (forall a. env -> m a -> IO a)
-> Spec
multiQueueListenerSpec Text
tableA Text
tableB ByteString
connStr Text -> payloadA
mkPayloadA Text -> payloadB
mkPayloadB IO env
mkEnv env -> IO ()
destroyEnv forall p. (JobRead p -> m ()) -> JobHandler m p ()
mkHandler forall a. env -> m a -> IO a
runM =
  ((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
mkEnv 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 (mkHandler (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
1_000_000
            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
500_000
            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
500_000
            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 -> do
        mListener <- 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
        case mListener of
          Maybe Listener
Nothing -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"expected a shared listener, got poll-only"
          Just 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
500_000
              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)
  where
    bumping :: IORef Int -> JobRead p -> m ()
    bumping :: forall p. 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 ()
bumpRef IORef Int
ref)

-- | Issue a raw @NOTIFY@ on a channel over a throwaway connection.
notifyChannel :: ByteString -> Text -> IO ()
notifyChannel :: ByteString -> Text -> IO ()
notifyChannel ByteString
connStr Text
chan =
  IO Connection
-> (Connection -> IO ()) -> (Connection -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (ByteString -> IO Connection
connectPostgreSQL ByteString
connStr) Connection -> IO ()
close ((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))

-- | Poll every 100 ms until the predicate returns 'True'.
-- Fails with 'expectationFailure' after @timeoutMs@ milliseconds.
waitUntil :: (HasCallStack) => Int -> IO Bool -> IO ()
waitUntil :: HasCallStack => Int -> IO Bool -> IO ()
waitUntil Int
timeoutMs IO Bool
check = HasCallStack => Int -> IO ()
Int -> IO ()
go (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
timeoutMs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100))
  where
    go :: (HasCallStack) => Int -> IO ()
    go :: HasCallStack => Int -> IO ()
go Int
0 = HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
"waitUntil: timed out waiting for condition"
    go Int
remaining = do
      satisfied <- IO Bool
check
      unless satisfied $ do
        threadDelay 100_000
        go (remaining - 1)