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

-- | Hedgehog state-machine tests for the job engine against any 'MonadArbiter'
-- backend. A sequential property checks the engine invariants after each step.
-- A concurrent property runs parallel branches under the HOL detector.
module Arbiter.Test.StateMachine
  ( stateMachineSpec
  , ArbiterC
  , SMPayload (..)
  , installHolDetector
  , holViolations
  , removeHolDetector
  ) where

import Arbiter.Core.Concurrency.Schema (arbiterConcurrencyPoliciesTable, arbiterConcurrencyTable)
import Arbiter.Core.Concurrency.Spec
  ( HasConcurrency (..)
  , concurrencyBy
  , concurrencyByCase
  , concurrencyPolicy
  , noConcurrency
  )
import Arbiter.Core.Gates (arbiterGatesTable)
import Arbiter.Core.HighLevel qualified as HL
import Arbiter.Core.Job.Schema (jobQueueDLQTable, jobQueueGroupsTable, jobQueueTable)
import Arbiter.Core.Job.Schema.Groups (inFlightPredicate)
import Arbiter.Core.Job.Types
  ( DedupKey (..)
  , JobRead
  , JobWrite
  , attempts
  , defaultGroupedJob
  , defaultJob
  , defaultMaxAttempts
  , notVisibleUntil
  , primaryKey
  , priority
  , setDedupKey
  , setMaxAttempts
  , setNotVisibleUntil
  , setPayload
  , setPriority
  , suspended
  )
import Arbiter.Core.Job.Types qualified as Job
import Arbiter.Core.JobTree ((<~~))
import Arbiter.Core.MonadArbiter (MonadArbiter, RegistryOf, withDbTransaction)
import Arbiter.Core.Operations qualified as Ops
import Arbiter.Core.QueueRegistry (RegistryTables, TableForPayload)
import Arbiter.Core.RateLimit.Schema
  ( arbiterRateLimitPoliciesTable
  , arbiterRateLimitsTable
  , upsertRateLimitPolicyRowSQL
  )
import Arbiter.Core.RateLimit.Spec
  ( HasRateLimit (..)
  , RateLimitPolicy
  , limitBy
  , limitByCase
  , noLimit
  , tokenBucket
  )
import Arbiter.Core.SqlLiterals (defaultMaxAttemptsSQL)
import Barbies qualified as B
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, tryPutMVar)
import Control.Exception (SomeException, finally, throwIO)
import Control.Monad (replicateM_, void, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (FromJSON, ToJSON)
import Data.Foldable (traverse_)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Data.Int (Int32, Int64)
import Data.Kind (Type)
import Data.List (isInfixOf, sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes, fromJust, isJust, listToMaybe)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import Data.UUID.Types qualified as UUID
import Database.PostgreSQL.Simple (Only (..))
import Database.PostgreSQL.Simple qualified as PG
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol)
import Hedgehog
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import System.Timeout (timeout)
import Test.Hspec
import UnliftIO (MonadUnliftIO, tryAny)
import UnliftIO.Async (async, link, mapConcurrently, mapConcurrently_, wait, withAsync)

import Arbiter.Test.Poll (bumpRef)
import Arbiter.Test.Setup (execute_, seedConcurrencyPolicySQL, toQuery)

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

-- | Past the 1 s lease of the crashed workers.
crashedLeaseLapseMicros :: Int
crashedLeaseLapseMicros :: Int
crashedLeaseLapseMicros = Int
1_500_000

-- | Past a 1 s schedule delay.
pastScheduleMicros :: Int
pastScheduleMicros :: Int
pastScheduleMicros = Int
1_500_000

-- | A pause for the statement to park on the held lock.
parkMicros :: Int
parkMicros :: Int
parkMicros = Int
300_000

-- | A pause for the claim to lock its key before the holder reaches for it.
claimReachMicros :: Int
claimReachMicros :: Int
claimReachMicros = Int
600_000

-- | Constraints the runner of 'stateMachineSpec' must satisfy.
type ArbiterC m =
  ( KnownSymbol (TableForPayload SMPayload (RegistryOf m))
  , MonadArbiter m
  , MonadUnliftIO m
  , RegistryTables (RegistryOf m)
  )

-- ---------------------------------------------------------------------------
-- Model
-- ---------------------------------------------------------------------------

-- | Live main-queue jobs and DLQ jobs, each keyed by its id and carrying its
-- group. Generates valid command targets. The invariants are checked against
-- the database.
data Model (v :: Type -> Type) = Model
  { forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive :: Map (Var Int64 v) (Maybe Text)
  , forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mDlq :: Map (Var Int64 v) (Maybe Text)
  }

initialModel :: Model v
initialModel :: forall (v :: * -> *). Model v
initialModel = Map (Var Int64 v) (Maybe Text)
-> Map (Var Int64 v) (Maybe Text) -> Model v
forall (v :: * -> *).
Map (Var Int64 v) (Maybe Text)
-> Map (Var Int64 v) (Maybe Text) -> Model v
Model Map (Var Int64 v) (Maybe Text)
forall k a. Map k a
Map.empty Map (Var Int64 v) (Maybe Text)
forall k a. Map k a
Map.empty

-- ---------------------------------------------------------------------------
-- Raw SQL string builders (schema/table threaded in)
-- ---------------------------------------------------------------------------

-- | Qualified name of the head-of-line detector's violations table.
holViolTbl :: Text -> Text -> Text
holViolTbl :: Text -> Text -> Text
holViolTbl Text
schema Text
table = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_hol_violations"

-- | Names of the head-of-line detector's function and trigger.
holFn, holTrigger :: Text -> Text -> Text
holFn :: Text -> Text -> Text
holFn Text
schema Text
table = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".detect_hol_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_fn"
holTrigger :: Text -> Text -> Text
holTrigger Text
_ Text
table = Text
"detect_hol_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table

-- | DDL to install the gap-free HOL detector. A row trigger logs a violation
-- when a claim makes a job in-flight while another @attempts > 0@ job in its
-- group already is. Only a claim raises @attempts@. The @attempts > 0@ filter
-- excludes scheduled jobs.
holInstallSql :: Text -> Text -> [Text]
holInstallSql :: Text -> Text -> [Text]
holInstallSql Text
schema Text
table =
  [ Text
"SET client_min_messages TO warning"
  , Text
"CREATE TABLE IF NOT EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holViolTbl Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (group_key TEXT NOT NULL, job_id BIGINT NOT NULL)"
  , Text
"TRUNCATE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holViolTbl Text
schema Text
table
  , Text
"CREATE OR REPLACE FUNCTION "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holFn Text
schema Text
table
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"() RETURNS TRIGGER AS $t$ BEGIN IF NEW.not_visible_until > NOW()"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AND NOT NEW.suspended AND NEW.attempts > OLD.attempts AND NEW.group_key IS NOT NULL"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AND EXISTS (SELECT 1 FROM "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE group_key = NEW.group_key AND id <> NEW.id"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AND not_visible_until > NOW() AND NOT suspended AND attempts > 0)"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" THEN INSERT INTO "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holViolTbl Text
schema Text
table
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (group_key, job_id) VALUES (NEW.group_key, NEW.id); END IF; RETURN NULL; END; $t$ LANGUAGE plpgsql"
  , Text
"DROP TRIGGER IF EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holTrigger Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
  , Text
"CREATE TRIGGER "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holTrigger Text
schema Text
table
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AFTER UPDATE ON "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" FOR EACH ROW EXECUTE FUNCTION "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holFn Text
schema Text
table
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"()"
  ]
  where
    tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table

-- | DDL to remove the HOL detector trigger, function, and violations table.
holRemoveSql :: Text -> Text -> [Text]
holRemoveSql :: Text -> Text -> [Text]
holRemoveSql Text
schema Text
table =
  [ Text
"SET client_min_messages TO warning"
  , Text
"DROP TRIGGER IF EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holTrigger Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table
  , Text
"DROP FUNCTION IF EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holFn Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"()"
  , Text
"DROP TABLE IF EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holViolTbl Text
schema Text
table
  ]

-- ---------------------------------------------------------------------------
-- Invariant checks (queried from the database after each command)
-- ---------------------------------------------------------------------------

-- Per-step check. The HOL detector is read after a parallel run.
checkInvariants
  :: (MonadIO m, MonadTest m)
  => Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> m ()
checkInvariants :: forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariants = String
-> Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
String
-> Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariantsL String
"?"

checkInvariantsL
  :: (MonadIO m, MonadTest m)
  => String
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> m ()
checkInvariantsL :: forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
String
-> Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariantsL String
lbl Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = do
  violations <-
    IO [String] -> m [String]
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (IO [String] -> m [String]) -> IO [String] -> m [String]
forall a b. (a -> b) -> a -> b
$
      [[String]] -> [String]
forall a. Monoid a => [a] -> a
mconcat
        ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO [String]] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
          [ Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
exactViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
          , Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
orphanViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
          , Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
driftViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
          , Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
claimViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
          ]
  map (("[after " <> lbl <> "] ") <>) violations === []

-- | First @id@ of a query, or Nothing if it returns no rows.
firstId :: (forall a. (PG.Connection -> IO a) -> IO a) -> Text -> IO (Maybe Int64)
firstId :: (forall a. (Connection -> IO a) -> IO a)
-> Text -> IO (Maybe Int64)
firstId forall a. (Connection -> IO a) -> IO a
withConn Text
sql = (Connection -> IO (Maybe Int64)) -> IO (Maybe Int64)
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO (Maybe Int64)) -> IO (Maybe Int64))
-> (Connection -> IO (Maybe Int64)) -> IO (Maybe Int64)
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
  [Int64] -> Maybe Int64
forall a. [a] -> Maybe a
listToMaybe ([Int64] -> Maybe Int64)
-> ([Only Int64] -> [Int64]) -> [Only Int64] -> Maybe Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Only Int64 -> Int64) -> [Only Int64] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Only Int64 -> Int64
forall a. Only a -> a
fromOnly ([Only Int64] -> Maybe Int64)
-> IO [Only Int64] -> IO (Maybe Int64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> IO [Only Int64]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (Text -> Query
toQuery Text
sql)

-- | A scalar @count(*)@ query through the raw-connection accessor.
countQuery :: (forall a. (PG.Connection -> IO a) -> IO a) -> Text -> IO Int64
countQuery :: (forall a. (Connection -> IO a) -> IO a) -> Text -> IO Int64
countQuery forall a. (Connection -> IO a) -> IO a
withConn Text
sql = (Connection -> IO Int64) -> IO Int64
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO Int64) -> IO Int64)
-> (Connection -> IO Int64) -> IO Int64
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  [Only count] <- Connection -> Query -> IO [Only Int64]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (Text -> Query
toQuery Text
sql)
  pure count

-- | Lock one count row @FOR UPDATE@, like a claimer holding the key.
lockConcurrencyKey :: PG.Connection -> Text -> Text -> IO ()
lockConcurrencyKey :: Connection -> Text -> Text -> IO ()
lockConcurrencyKey Connection
conn Text
concTbl Text
key =
  IO [Only Int64] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
    ( Connection -> Query -> IO [Only Int64]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_
        Connection
conn
        (Text -> Query
toQuery (Text
"SELECT 1 FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
concTbl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE concurrency_key = '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' FOR UPDATE"))
        :: IO [Only Int64]
    )

truncateHol :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO ()
truncateHol :: Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
truncateHol Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
  Connection -> Text -> IO ()
execute_ Connection
conn (Text
"TRUNCATE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holViolTbl Text
schema Text
table)

queryViolations :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO [String]
queryViolations :: Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
queryViolations Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  [[String]] -> [String]
forall a. Monoid a => [a] -> a
mconcat
    ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO [String]] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
      [ Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
exactViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
      , Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
driftViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
      , Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
claimViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
      ]

-- | Claim bookkeeping that must hold between statements:
--
--   * a suspended job names no holder
--   * each concurrency key's stored @in_flight@ equals a recount of claimed rows
claimViolations :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO [String]
claimViolations :: Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
claimViolations Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = (Connection -> IO [String]) -> IO [String]
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO [String]) -> IO [String])
-> (Connection -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  held <- Connection -> Query -> IO [Only Int64]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (Text -> Query
toQuery Text
heldSql)
  counts <- PG.query_ conn (toQuery countSql)
  pure $
    ["suspended job " <> show (jid :: Int64) <> " still names a holder" | Only jid <- held]
      <> [ "concurrency key " <> T.unpack key <> " stores in_flight " <> show stored <> ", recount " <> show live
         | (key, stored, live) <- counts :: [(Text, Int64, Int64)]
         ]
  where
    tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table
    concTbl :: Text
concTbl = Text -> Text
arbiterConcurrencyTable Text
schema
    heldSql :: Text
heldSql = Text
"SELECT id FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE suspended AND claimed_by IS NOT NULL"
    countSql :: Text
countSql =
      Text
"SELECT COALESCE(stored.concurrency_key, live.concurrency_key), COALESCE(stored.in_flight, 0)::bigint, COALESCE(live.claimed, 0)::bigint"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" FROM (SELECT concurrency_key, in_flight FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
concTbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE in_flight > 0) stored FULL OUTER JOIN (SELECT concurrency_key, COUNT(*) AS claimed FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE concurrency_key IS NOT NULL AND claimed_by IS NOT NULL GROUP BY concurrency_key) live"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ON stored.concurrency_key = live.concurrency_key"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE COALESCE(stored.in_flight, 0) <> COALESCE(live.claimed, 0)"

-- | Summary-drift oracle. Full-join the stored @_groups@ row against a fresh
-- recompute and report any column that disagrees.
driftViolations :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO [String]
driftViolations :: Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
driftViolations Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = (Connection -> IO [String]) -> IO [String]
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO [String]) -> IO [String])
-> (Connection -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  rows <- Connection -> Query -> IO [(Text, Text)]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (Text -> Query
toQuery Text
oracleSql)
  pure ["group " <> T.unpack groupName <> " summary drift: " <> T.unpack cols | (groupName, cols) <- rows]
  where
    tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table
    groupsTbl :: Text
groupsTbl = Text -> Text -> Text
jobQueueGroupsTable Text
schema Text
table
    -- NOW() is evaluated once per statement. The recompute filters mirror the
    -- trigger definitions. A past stored in_flight_until reads as free, as in the claim.
    oracleSql :: Text
oracleSql =
      Text
"SELECT group_name, drift FROM (SELECT COALESCE(summary.group_key, expected.group_key) AS group_name, concat_ws(', '"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", CASE WHEN summary.group_key IS NULL THEN 'missing summary row' END"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", CASE WHEN expected.group_key IS NULL THEN 'orphan summary row' END"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", CASE WHEN summary.min_priority IS DISTINCT FROM expected.min_priority THEN 'min_priority' END"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", CASE WHEN summary.min_id IS DISTINCT FROM expected.min_id THEN 'min_id' END"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", CASE WHEN summary.job_count IS DISTINCT FROM expected.job_count THEN 'job_count' END"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", CASE WHEN summary.ready_count IS DISTINCT FROM expected.ready_count THEN 'ready_count' END"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", CASE WHEN summary.next_due IS DISTINCT FROM expected.next_due THEN 'next_due' END"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", CASE WHEN summary.in_flight_until IS DISTINCT FROM expected.in_flight_until THEN 'in_flight_until' END"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") AS drift FROM (SELECT group_key, min_priority, min_id, job_count, ready_count, next_due"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", CASE WHEN in_flight_until > NOW() THEN in_flight_until END AS in_flight_until FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
groupsTbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE job_count > 0) summary FULL OUTER JOIN (SELECT group_key"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", MIN(priority)::int AS min_priority"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", (MIN(ARRAY[priority::bigint, id]))[2]::bigint AS min_id"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", COUNT(*)::bigint AS job_count"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", COUNT(*) FILTER (WHERE not_visible_until IS NULL AND NOT suspended AND cancel_requested_at IS NULL"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AND attempts < COALESCE(max_attempts, "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
defaultMaxAttemptsSQL
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))::bigint AS ready_count"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", MIN(not_visible_until) FILTER (WHERE not_visible_until IS NOT NULL AND NOT suspended AND cancel_requested_at IS NULL"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AND attempts < COALESCE(max_attempts, "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
defaultMaxAttemptsSQL
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")) AS next_due"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", MAX(not_visible_until) FILTER (WHERE "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
inFlightPredicate Text
""
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") AS in_flight_until FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE group_key IS NOT NULL GROUP BY group_key) expected ON summary.group_key = expected.group_key) compared WHERE drift <> ''"

-- | Exact invariant violations, safe to sample live during concurrent churn:
--
--   * serialization: more than one claimed in-flight job per group
--   * attempt bound: a live job past its limit
--   * dedup uniqueness: two live jobs sharing a @dedup_key@
--   * concurrency cap: more claimed jobs on a key than its effective cap
--   * rate-limit integrity: a bucket's tokens outside [0, max]
exactViolations :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO [String]
exactViolations :: Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
exactViolations Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = (Connection -> IO [String]) -> IO [String]
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO [String]) -> IO [String])
-> (Connection -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  serial <- Connection -> Query -> IO [Only Text]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (Text -> Query
toQuery Text
serialSql)
  over <- PG.query_ conn (toQuery overSql)
  dups <- PG.query_ conn (toQuery dupSql)
  conc <- PG.query_ conn (toQuery concSql)
  overSpent <- PG.query_ conn (toQuery rlSql)
  rlMax <- PG.query_ conn (toQuery rlMaxSql)
  serialMsgs <- traverse (diagnoseSerial conn) [groupName | Only groupName <- serial]
  pure $
    serialMsgs
      <> ["job " <> show (jid :: Int64) <> " exceeded its max_attempts" | Only jid <- over]
      <> ["duplicate live dedup_key " <> T.unpack key | Only key <- dups]
      <> ["concurrency cap exceeded for key " <> T.unpack key | Only key <- conc]
      <> ["rate-limit bucket " <> T.unpack key <> " over-spent (negative tokens)" | Only key <- overSpent]
      <> ["rate-limit bucket " <> T.unpack key <> " over-credited (tokens above max)" | Only key <- rlMax]
  where
    tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table
    concPolicies :: Text
concPolicies = Text -> Text
arbiterConcurrencyPoliciesTable Text
schema
    rlBuckets :: Text
rlBuckets = Text -> Text
arbiterRateLimitsTable Text
schema
    rlPolicies :: Text
rlPolicies = Text -> Text
arbiterRateLimitPoliciesTable Text
schema
    groupsTbl :: Text
groupsTbl = Text -> Text -> Text
jobQueueGroupsTable Text
schema Text
table
    dma :: Text
dma = String -> Text
T.pack (Int32 -> String
forall a. Show a => a -> String
show Int32
defaultMaxAttempts)
    -- On a serialization violation, dump the offending group's jobs and summary
    -- row. Timestamps are ms relative to NOW.
    diagnoseSerial :: Connection -> Text -> IO String
diagnoseSerial Connection
conn Text
groupName = do
      jobs <- Connection
-> Query
-> Only Text
-> IO
     [(Int64, Int32, Maybe Int32, Bool, Maybe Int64, Maybe Text,
       Maybe Int64, Maybe Int64)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
conn (Text -> Query
toQuery Text
jobsSql) (Text -> Only Text
forall a. a -> Only a
Only Text
groupName)
      summ <- PG.query conn (toQuery summSql) (Only groupName)
      let jobStr (Int64
jid, Int32
att, Maybe Int32
maxAtts, Bool
susp, Maybe Int64
nvu, Maybe Text
dedup, Maybe Int64
upd, Maybe Int64
att_ms) =
            String
"{id="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show (Int64
jid :: Int64)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" att="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int32 -> String
forall a. Show a => a -> String
show (Int32
att :: Int32)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" max="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Int32 -> String
forall a. Show a => a -> String
show (Maybe Int32
maxAtts :: Maybe Int32)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" susp="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall a. Show a => a -> String
show (Bool
susp :: Bool)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" nvu_ms="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Int64 -> String
forall a. Show a => a -> String
show (Maybe Int64
nvu :: Maybe Int64)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" dk="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> String
forall a. Show a => a -> String
show (Maybe Text
dedup :: Maybe Text)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" upd_ago="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Int64 -> String
forall a. Show a => a -> String
show (Maybe Int64
upd :: Maybe Int64)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" att_ago="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Int64 -> String
forall a. Show a => a -> String
show (Maybe Int64
att_ms :: Maybe Int64)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}"
          summStr (Int64
jobCount, Int64
readyCount, Maybe Int64
inFlightUntil, Maybe Int64
nextDue) =
            String
"jc="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show (Int64
jobCount :: Int64)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" rc="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int64 -> String
forall a. Show a => a -> String
show (Int64
readyCount :: Int64)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ifu_ms="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Int64 -> String
forall a. Show a => a -> String
show (Maybe Int64
inFlightUntil :: Maybe Int64)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" nd_ms="
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe Int64 -> String
forall a. Show a => a -> String
show (Maybe Int64
nextDue :: Maybe Int64)
      pure $
        "multiple in-flight in group "
          <> T.unpack groupName
          <> " | summary["
          <> maybe "MISSING" summStr (listToMaybe summ)
          <> "]"
          <> " | jobs "
          <> unwords (map jobStr jobs)
    jobsSql :: Text
jobsSql =
      Text
"SELECT id, attempts, max_attempts, suspended,"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" round(extract(epoch FROM (not_visible_until - NOW())) * 1000)::bigint,"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" dedup_key,"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" round(extract(epoch FROM (NOW() - updated_at)) * 1000)::bigint,"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" round(extract(epoch FROM (NOW() - last_attempted_at)) * 1000)::bigint"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE group_key = ? ORDER BY id"
    summSql :: Text
summSql =
      Text
"SELECT job_count, ready_count,"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" round(extract(epoch FROM (in_flight_until - NOW())) * 1000)::bigint,"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" round(extract(epoch FROM (next_due - NOW())) * 1000)::bigint"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
groupsTbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE group_key = ?"
    serialSql :: Text
serialSql =
      Text
"SELECT group_key FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE group_key IS NOT NULL AND not_visible_until > NOW()"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AND NOT suspended AND claimed_by IS NOT NULL"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" GROUP BY group_key HAVING COUNT(*) > 1"
    overSql :: Text
overSql =
      Text
"SELECT id FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE attempts > COALESCE(max_attempts, "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dma
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    dupSql :: Text
dupSql =
      Text
"SELECT dedup_key FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE dedup_key IS NOT NULL GROUP BY dedup_key HAVING COUNT(*) > 1"
    -- More claimed jobs on a key than its effective cap. The effective cap is the
    -- policy override, else the policy default.
    concSql :: Text
concSql =
      Text
"SELECT job.concurrency_key FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" job LEFT JOIN "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
concPolicies
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" policy ON policy.prefix_id = job.concurrency_prefix"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE job.concurrency_key IS NOT NULL"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" GROUP BY job.concurrency_key, policy.override_limit, policy.default_limit"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" HAVING COUNT(*) FILTER (WHERE job.claimed_by IS NOT NULL)"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" > COALESCE(policy.override_limit, policy.default_limit)"
    -- Negative tokens mean the gate over-spent. The epsilon tolerates float rounding.
    rlSql :: Text
rlSql = Text
"SELECT rate_limit_key FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rlBuckets Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE tokens < -0.001"
    -- Tokens above the effective max mean a refill, top-up, or seed skipped the cap.
    rlMaxSql :: Text
rlMaxSql =
      Text
"SELECT bucket.rate_limit_key FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rlBuckets
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bucket JOIN "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rlPolicies
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" policy ON policy.prefix_id = bucket.policy_prefix"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE bucket.tokens > COALESCE(policy.override_max_tokens, policy.default_max_tokens) + 0.001"

-- | A live child whose parent has left the main queue. This is a per-step check
-- for the sequential property. Under concurrency a parent can be acked between
-- the DLQ retry's refuse-check and a child's re-insert, which leaves a benign
-- orphan.
orphanViolations :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO [String]
orphanViolations :: Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
orphanViolations Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = (Connection -> IO [String]) -> IO [String]
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO [String]) -> IO [String])
-> (Connection -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  orphans <- Connection -> Query -> IO [Only Int64]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (Text -> Query
toQuery Text
orphanSql)
  pure ["orphaned child " <> show (jid :: Int64) <> " (parent gone)" | Only jid <- orphans]
  where
    tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table
    orphanSql :: Text
orphanSql =
      Text
"SELECT child.id FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" child WHERE child.parent_id IS NOT NULL AND NOT EXISTS"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (SELECT 1 FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" parent WHERE parent.id = child.parent_id)"

-- ---------------------------------------------------------------------------
-- Commands
-- ---------------------------------------------------------------------------

-- | Worker id for the generated claim paths.
smWorker :: UUID.UUID
smWorker :: UUID
smWorker = Word32 -> Word32 -> Word32 -> Word32 -> UUID
UUID.fromWords Word32
0 Word32
0 Word32
0 Word32
7

-- | Per-job rate-limit key and concurrency policy a generated insert can carry.
data Extras = Extras (Maybe Text) (Maybe Text)
  deriving stock (Extras -> Extras -> Bool
(Extras -> Extras -> Bool)
-> (Extras -> Extras -> Bool) -> Eq Extras
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Extras -> Extras -> Bool
== :: Extras -> Extras -> Bool
$c/= :: Extras -> Extras -> Bool
/= :: Extras -> Extras -> Bool
Eq, Int -> Extras -> String -> String
[Extras] -> String -> String
Extras -> String
(Int -> Extras -> String -> String)
-> (Extras -> String)
-> ([Extras] -> String -> String)
-> Show Extras
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Extras -> String -> String
showsPrec :: Int -> Extras -> String -> String
$cshow :: Extras -> String
show :: Extras -> String
$cshowList :: [Extras] -> String -> String
showList :: [Extras] -> String -> String
Show)

-- | Seeded policies with a fixed limit.
smConcSlots :: [(Text, Int32)]
smConcSlots :: [(Text, Int32)]
smConcSlots = [(Text
"cap-a", Int32
1), (Text
"cap-b", Int32
2), (Text
"cap-c", Int32
3)]

-- | One suffix per policy. Each policy drives a single count-row key.
smConcSuffix :: Text
smConcSuffix :: Text
smConcSuffix = Text
"s"

smRateKeys :: [Text]
smRateKeys :: [Text]
smRateKeys = [Text
"rk-1", Text
"rk-2"]

genExtras :: (MonadGen g) => g Extras
genExtras :: forall (g :: * -> *). MonadGen g => g Extras
genExtras = Maybe Text -> Maybe Text -> Extras
Extras (Maybe Text -> Maybe Text -> Extras)
-> g (Maybe Text) -> g (Maybe Text -> Extras)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g Text -> g (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe ([Text] -> g Text
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element (((Text, Int32) -> Text) -> [(Text, Int32)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Int32) -> Text
forall a b. (a, b) -> a
fst [(Text, Int32)]
smConcSlots)) g (Maybe Text -> Extras) -> g (Maybe Text) -> g Extras
forall a b. g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> g Text -> g (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe ([Text] -> g Text
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element [Text]
smRateKeys)

applyExtras :: Extras -> JobWrite SMPayload -> JobWrite SMPayload
applyExtras :: Extras -> JobWrite SMPayload -> JobWrite SMPayload
applyExtras (Extras Maybe Text
concSlot Maybe Text
rateKey) JobWrite SMPayload
job = SMPayload -> JobWrite SMPayload -> JobWrite SMPayload
forall payload' payload.
payload' -> JobWrite payload -> JobWrite payload'
setPayload ((JobWrite SMPayload -> SMPayload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
Job.payload JobWrite SMPayload
job) {smConcSlot = concSlot, smRateKey = rateKey}) JobWrite SMPayload
job

-- | A payload carrying optional concurrency and rate-limit keys.
data SMPayload = SMPayload
  { SMPayload -> Text
smMessage :: Text
  -- ^ Free text.
  , SMPayload -> Maybe Text
smConcSlot :: Maybe Text
  -- ^ Concurrency policy: @cap-a@ (limit 1), @cap-b@ (limit 2) or @cap-c@ (limit 3). Other values take no slot.
  , SMPayload -> Maybe Text
smRateKey :: Maybe Text
  -- ^ Rate-limit key: @rk-1@ or @rk-2@ on the @smrl@ bucket. Other values take no token.
  }
  deriving stock (SMPayload -> SMPayload -> Bool
(SMPayload -> SMPayload -> Bool)
-> (SMPayload -> SMPayload -> Bool) -> Eq SMPayload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMPayload -> SMPayload -> Bool
== :: SMPayload -> SMPayload -> Bool
$c/= :: SMPayload -> SMPayload -> Bool
/= :: SMPayload -> SMPayload -> Bool
Eq, (forall x. SMPayload -> Rep SMPayload x)
-> (forall x. Rep SMPayload x -> SMPayload) -> Generic SMPayload
forall x. Rep SMPayload x -> SMPayload
forall x. SMPayload -> Rep SMPayload x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SMPayload -> Rep SMPayload x
from :: forall x. SMPayload -> Rep SMPayload x
$cto :: forall x. Rep SMPayload x -> SMPayload
to :: forall x. Rep SMPayload x -> SMPayload
Generic, Int -> SMPayload -> String -> String
[SMPayload] -> String -> String
SMPayload -> String
(Int -> SMPayload -> String -> String)
-> (SMPayload -> String)
-> ([SMPayload] -> String -> String)
-> Show SMPayload
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SMPayload -> String -> String
showsPrec :: Int -> SMPayload -> String -> String
$cshow :: SMPayload -> String
show :: SMPayload -> String
$cshowList :: [SMPayload] -> String -> String
showList :: [SMPayload] -> String -> String
Show)
  deriving anyclass (Maybe SMPayload
Value -> Parser [SMPayload]
Value -> Parser SMPayload
(Value -> Parser SMPayload)
-> (Value -> Parser [SMPayload])
-> Maybe SMPayload
-> FromJSON SMPayload
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser SMPayload
parseJSON :: Value -> Parser SMPayload
$cparseJSONList :: Value -> Parser [SMPayload]
parseJSONList :: Value -> Parser [SMPayload]
$comittedField :: Maybe SMPayload
omittedField :: Maybe SMPayload
FromJSON, [SMPayload] -> Value
[SMPayload] -> Encoding
SMPayload -> Bool
SMPayload -> Value
SMPayload -> Encoding
(SMPayload -> Value)
-> (SMPayload -> Encoding)
-> ([SMPayload] -> Value)
-> ([SMPayload] -> Encoding)
-> (SMPayload -> Bool)
-> ToJSON SMPayload
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SMPayload -> Value
toJSON :: SMPayload -> Value
$ctoEncoding :: SMPayload -> Encoding
toEncoding :: SMPayload -> Encoding
$ctoJSONList :: [SMPayload] -> Value
toJSONList :: [SMPayload] -> Value
$ctoEncodingList :: [SMPayload] -> Encoding
toEncodingList :: [SMPayload] -> Encoding
$comitField :: SMPayload -> Bool
omitField :: SMPayload -> Bool
ToJSON)

smPayload :: Text -> SMPayload
smPayload :: Text -> SMPayload
smPayload Text
text = Text -> Maybe Text -> Maybe Text -> SMPayload
SMPayload Text
text Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing

data SMSlot = SlotNone | SlotA | SlotB | SlotC
  deriving stock (SMSlot
SMSlot -> SMSlot -> Bounded SMSlot
forall a. a -> a -> Bounded a
$cminBound :: SMSlot
minBound :: SMSlot
$cmaxBound :: SMSlot
maxBound :: SMSlot
Bounded, Int -> SMSlot
SMSlot -> Int
SMSlot -> [SMSlot]
SMSlot -> SMSlot
SMSlot -> SMSlot -> [SMSlot]
SMSlot -> SMSlot -> SMSlot -> [SMSlot]
(SMSlot -> SMSlot)
-> (SMSlot -> SMSlot)
-> (Int -> SMSlot)
-> (SMSlot -> Int)
-> (SMSlot -> [SMSlot])
-> (SMSlot -> SMSlot -> [SMSlot])
-> (SMSlot -> SMSlot -> [SMSlot])
-> (SMSlot -> SMSlot -> SMSlot -> [SMSlot])
-> Enum SMSlot
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SMSlot -> SMSlot
succ :: SMSlot -> SMSlot
$cpred :: SMSlot -> SMSlot
pred :: SMSlot -> SMSlot
$ctoEnum :: Int -> SMSlot
toEnum :: Int -> SMSlot
$cfromEnum :: SMSlot -> Int
fromEnum :: SMSlot -> Int
$cenumFrom :: SMSlot -> [SMSlot]
enumFrom :: SMSlot -> [SMSlot]
$cenumFromThen :: SMSlot -> SMSlot -> [SMSlot]
enumFromThen :: SMSlot -> SMSlot -> [SMSlot]
$cenumFromTo :: SMSlot -> SMSlot -> [SMSlot]
enumFromTo :: SMSlot -> SMSlot -> [SMSlot]
$cenumFromThenTo :: SMSlot -> SMSlot -> SMSlot -> [SMSlot]
enumFromThenTo :: SMSlot -> SMSlot -> SMSlot -> [SMSlot]
Enum, SMSlot -> SMSlot -> Bool
(SMSlot -> SMSlot -> Bool)
-> (SMSlot -> SMSlot -> Bool) -> Eq SMSlot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMSlot -> SMSlot -> Bool
== :: SMSlot -> SMSlot -> Bool
$c/= :: SMSlot -> SMSlot -> Bool
/= :: SMSlot -> SMSlot -> Bool
Eq)

instance HasConcurrency SMPayload where
  concurrencyFor :: ConcurrencyFor SMPayload
concurrencyFor = (SMPayload -> SMSlot)
-> (SMSlot -> ConcurrencyFor SMPayload) -> ConcurrencyFor SMPayload
forall k payload.
(Bounded k, Enum k, Eq k) =>
(payload -> k)
-> (k -> ConcurrencyFor payload) -> ConcurrencyFor payload
concurrencyByCase SMPayload -> SMSlot
slotTag SMSlot -> ConcurrencyFor SMPayload
forall {payload}. SMSlot -> ConcurrencyFor payload
slotSel
    where
      slotTag :: SMPayload -> SMSlot
slotTag SMPayload
payload = case SMPayload -> Maybe Text
smConcSlot SMPayload
payload of
        Just Text
"cap-a" -> SMSlot
SlotA
        Just Text
"cap-b" -> SMSlot
SlotB
        Just Text
"cap-c" -> SMSlot
SlotC
        Maybe Text
_ -> SMSlot
SlotNone
      slotSel :: SMSlot -> ConcurrencyFor payload
slotSel SMSlot
SlotNone = ConcurrencyFor payload
forall payload. ConcurrencyFor payload
noConcurrency
      slotSel SMSlot
SlotA = ConcurrencyPolicy -> (payload -> Text) -> ConcurrencyFor payload
forall payload.
ConcurrencyPolicy -> (payload -> Text) -> ConcurrencyFor payload
concurrencyBy (Text -> Int32 -> ConcurrencyPolicy
concurrencyPolicy Text
"cap-a" Int32
1) (Text -> payload -> Text
forall a b. a -> b -> a
const Text
smConcSuffix)
      slotSel SMSlot
SlotB = ConcurrencyPolicy -> (payload -> Text) -> ConcurrencyFor payload
forall payload.
ConcurrencyPolicy -> (payload -> Text) -> ConcurrencyFor payload
concurrencyBy (Text -> Int32 -> ConcurrencyPolicy
concurrencyPolicy Text
"cap-b" Int32
2) (Text -> payload -> Text
forall a b. a -> b -> a
const Text
smConcSuffix)
      slotSel SMSlot
SlotC = ConcurrencyPolicy -> (payload -> Text) -> ConcurrencyFor payload
forall payload.
ConcurrencyPolicy -> (payload -> Text) -> ConcurrencyFor payload
concurrencyBy (Text -> Int32 -> ConcurrencyPolicy
concurrencyPolicy Text
"cap-c" Int32
3) (Text -> payload -> Text
forall a b. a -> b -> a
const Text
smConcSuffix)

data SMRate = RateNone | RateK1 | RateK2
  deriving stock (SMRate
SMRate -> SMRate -> Bounded SMRate
forall a. a -> a -> Bounded a
$cminBound :: SMRate
minBound :: SMRate
$cmaxBound :: SMRate
maxBound :: SMRate
Bounded, Int -> SMRate
SMRate -> Int
SMRate -> [SMRate]
SMRate -> SMRate
SMRate -> SMRate -> [SMRate]
SMRate -> SMRate -> SMRate -> [SMRate]
(SMRate -> SMRate)
-> (SMRate -> SMRate)
-> (Int -> SMRate)
-> (SMRate -> Int)
-> (SMRate -> [SMRate])
-> (SMRate -> SMRate -> [SMRate])
-> (SMRate -> SMRate -> [SMRate])
-> (SMRate -> SMRate -> SMRate -> [SMRate])
-> Enum SMRate
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SMRate -> SMRate
succ :: SMRate -> SMRate
$cpred :: SMRate -> SMRate
pred :: SMRate -> SMRate
$ctoEnum :: Int -> SMRate
toEnum :: Int -> SMRate
$cfromEnum :: SMRate -> Int
fromEnum :: SMRate -> Int
$cenumFrom :: SMRate -> [SMRate]
enumFrom :: SMRate -> [SMRate]
$cenumFromThen :: SMRate -> SMRate -> [SMRate]
enumFromThen :: SMRate -> SMRate -> [SMRate]
$cenumFromTo :: SMRate -> SMRate -> [SMRate]
enumFromTo :: SMRate -> SMRate -> [SMRate]
$cenumFromThenTo :: SMRate -> SMRate -> SMRate -> [SMRate]
enumFromThenTo :: SMRate -> SMRate -> SMRate -> [SMRate]
Enum, SMRate -> SMRate -> Bool
(SMRate -> SMRate -> Bool)
-> (SMRate -> SMRate -> Bool) -> Eq SMRate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMRate -> SMRate -> Bool
== :: SMRate -> SMRate -> Bool
$c/= :: SMRate -> SMRate -> Bool
/= :: SMRate -> SMRate -> Bool
Eq)

-- | A binding bucket. Capacity 3 with negligible refill over a test run.
smBucket :: RateLimitPolicy
smBucket :: RateLimitPolicy
smBucket = Text -> Double -> NominalDiffTime -> RateLimitPolicy
tokenBucket Text
"smrl" Double
3 NominalDiffTime
60

instance HasRateLimit SMPayload where
  rateLimitFor :: RateLimitFor SMPayload
rateLimitFor = (SMPayload -> SMRate)
-> (SMRate -> RateLimitFor SMPayload) -> RateLimitFor SMPayload
forall k payload.
(Bounded k, Enum k, Eq k) =>
(payload -> k)
-> (k -> RateLimitFor payload) -> RateLimitFor payload
limitByCase SMPayload -> SMRate
rateTag SMRate -> RateLimitFor SMPayload
forall {payload}. SMRate -> RateLimitFor payload
rateSel
    where
      rateTag :: SMPayload -> SMRate
rateTag SMPayload
payload = case SMPayload -> Maybe Text
smRateKey SMPayload
payload of
        Just Text
"rk-1" -> SMRate
RateK1
        Just Text
"rk-2" -> SMRate
RateK2
        Maybe Text
_ -> SMRate
RateNone
      rateSel :: SMRate -> RateLimitFor payload
rateSel SMRate
RateNone = RateLimitFor payload
forall payload. RateLimitFor payload
noLimit
      rateSel SMRate
RateK1 = RateLimitPolicy -> (payload -> Text) -> RateLimitFor payload
forall payload.
RateLimitPolicy -> (payload -> Text) -> RateLimitFor payload
limitBy RateLimitPolicy
smBucket (Text -> payload -> Text
forall a b. a -> b -> a
const Text
"rk-1")
      rateSel SMRate
RateK2 = RateLimitPolicy -> (payload -> Text) -> RateLimitFor payload
forall payload.
RateLimitPolicy -> (payload -> Text) -> RateLimitFor payload
limitBy RateLimitPolicy
smBucket (Text -> payload -> Text
forall a b. a -> b -> a
const Text
"rk-2")

-- | Seed the concurrency policies. Idempotent.
seedConcurrencyPolicies :: Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO ()
seedConcurrencyPolicies :: Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
seedConcurrencyPolicies Text
schema forall a. (Connection -> IO a) -> IO a
withConn = (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
  ((Text, Int32) -> IO ()) -> [(Text, Int32)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
    (\(Text
policy, Int32
limit) -> (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Connection -> Text -> IO ()
execute_ Connection
conn) (Text -> Text -> Int32 -> [Text]
seedConcurrencyPolicySQL Text
schema Text
policy Int32
limit))
    [(Text, Int32)]
smConcSlots

-- | Seed the rate-limit policy. Idempotent.
seedRateLimitPolicies :: Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO ()
seedRateLimitPolicies :: Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
seedRateLimitPolicies Text
schema forall a. (Connection -> IO a) -> IO a
withConn = (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
  Connection -> Text -> IO ()
execute_ Connection
conn (Text -> RateLimitPolicy -> Text
upsertRateLimitPolicyRowSQL Text
schema RateLimitPolicy
smBucket)

-- | Reset the tables, then re-seed both admission policies.
resetSeeded :: IO () -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO ()
resetSeeded :: IO () -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
resetSeeded IO ()
reset Text
schema forall a. (Connection -> IO a) -> IO a
withConn = do
  IO ()
reset
  Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
seedConcurrencyPolicies Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
seedRateLimitPolicies Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn

-- | @Insert group delay priority maxAttempts extras@. Insert a job at a varying
-- priority into an optional group, optionally scheduled into the future. A low
-- @maxAttempts@ lets short claim sequences drive jobs to exhaustion.
data Insert (v :: Type -> Type) = Insert (Maybe Text) (Maybe Int) Int (Maybe Int) Extras
  deriving stock (Insert v -> Insert v -> Bool
(Insert v -> Insert v -> Bool)
-> (Insert v -> Insert v -> Bool) -> Eq (Insert v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). Insert v -> Insert v -> Bool
$c== :: forall (v :: * -> *). Insert v -> Insert v -> Bool
== :: Insert v -> Insert v -> Bool
$c/= :: forall (v :: * -> *). Insert v -> Insert v -> Bool
/= :: Insert v -> Insert v -> Bool
Eq, (forall x. Insert v -> Rep (Insert v) x)
-> (forall x. Rep (Insert v) x -> Insert v) -> Generic (Insert v)
forall x. Rep (Insert v) x -> Insert v
forall x. Insert v -> Rep (Insert v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (Insert v) x -> Insert v
forall (v :: * -> *) x. Insert v -> Rep (Insert v) x
$cfrom :: forall (v :: * -> *) x. Insert v -> Rep (Insert v) x
from :: forall x. Insert v -> Rep (Insert v) x
$cto :: forall (v :: * -> *) x. Rep (Insert v) x -> Insert v
to :: forall x. Rep (Insert v) x -> Insert v
Generic, Int -> Insert v -> String -> String
[Insert v] -> String -> String
Insert v -> String
(Int -> Insert v -> String -> String)
-> (Insert v -> String)
-> ([Insert v] -> String -> String)
-> Show (Insert v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *). Int -> Insert v -> String -> String
forall (v :: * -> *). [Insert v] -> String -> String
forall (v :: * -> *). Insert v -> String
$cshowsPrec :: forall (v :: * -> *). Int -> Insert v -> String -> String
showsPrec :: Int -> Insert v -> String -> String
$cshow :: forall (v :: * -> *). Insert v -> String
show :: Insert v -> String
$cshowList :: forall (v :: * -> *). [Insert v] -> String -> String
showList :: [Insert v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> Insert f -> Insert g)
-> FunctorB Insert
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Insert f -> Insert g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Insert f -> Insert g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Insert f -> Insert g
B.FunctorB, FunctorB Insert
FunctorB Insert =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> Insert f -> e (Insert g))
-> TraversableB Insert
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Insert f -> e (Insert g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Insert f -> e (Insert g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Insert f -> e (Insert g)
B.TraversableB)

cInsert
  :: forall gen m sm
   . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cInsert :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cInsert forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (Insert Symbolic)))
-> (Insert Concrete -> m Int64)
-> [Callback Insert Int64 Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command
    ( \Model Symbolic
_ ->
        gen (Insert Symbolic) -> Maybe (gen (Insert Symbolic))
forall a. a -> Maybe a
Just (gen (Insert Symbolic) -> Maybe (gen (Insert Symbolic)))
-> gen (Insert Symbolic) -> Maybe (gen (Insert Symbolic))
forall a b. (a -> b) -> a -> b
$
          Maybe Text
-> Maybe Int -> Int -> Maybe Int -> Extras -> Insert Symbolic
forall (v :: * -> *).
Maybe Text -> Maybe Int -> Int -> Maybe Int -> Extras -> Insert v
Insert
            (Maybe Text
 -> Maybe Int -> Int -> Maybe Int -> Extras -> Insert Symbolic)
-> gen (Maybe Text)
-> gen (Maybe Int -> Int -> Maybe Int -> Extras -> Insert Symbolic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> gen Text -> gen (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe ([Text] -> gen Text
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element [Text
"g1", Text
"g2", Text
"g3"])
            gen (Maybe Int -> Int -> Maybe Int -> Extras -> Insert Symbolic)
-> gen (Maybe Int)
-> gen (Int -> Maybe Int -> Extras -> Insert Symbolic)
forall a b. gen (a -> b) -> gen a -> gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> gen Int -> gen (Maybe Int)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Range Int -> gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
30 Int
120))
            gen (Int -> Maybe Int -> Extras -> Insert Symbolic)
-> gen Int -> gen (Maybe Int -> Extras -> Insert Symbolic)
forall a b. gen (a -> b) -> gen a -> gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
5)
            gen (Maybe Int -> Extras -> Insert Symbolic)
-> gen (Maybe Int) -> gen (Extras -> Insert Symbolic)
forall a b. gen (a -> b) -> gen a -> gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> gen Int -> gen (Maybe Int)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Range Int -> gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
3))
            gen (Extras -> Insert Symbolic)
-> gen Extras -> gen (Insert Symbolic)
forall a b. gen (a -> b) -> gen a -> gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> gen Extras
forall (g :: * -> *). MonadGen g => g Extras
genExtras
    )
    ( \(Insert Maybe Text
group Maybe Int
delay Int
prio Maybe Int
maxAtts Extras
extras) -> do
        jid <- IO Int64 -> m Int64
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm Int64 -> IO Int64
forall a. sm a -> IO a
run ((JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert (Extras -> JobWrite SMPayload -> JobWrite SMPayload
applyExtras Extras
extras) Maybe Text
group Maybe Int
delay Int
prio Maybe Int
maxAtts))
        checkInvariants schema table withConn
        pure jid
    )
    [(forall (v :: * -> *).
 Ord1 v =>
 Model v -> Insert v -> Var Int64 v -> Model v)
-> Callback Insert Int64 Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(forall (v :: * -> *).
 Ord1 v =>
 state v -> input v -> Var output v -> state v)
-> Callback input output state
Update ((forall (v :: * -> *).
  Ord1 v =>
  Model v -> Insert v -> Var Int64 v -> Model v)
 -> Callback Insert Int64 Model)
-> (forall (v :: * -> *).
    Ord1 v =>
    Model v -> Insert v -> Var Int64 v -> Model v)
-> Callback Insert Int64 Model
forall a b. (a -> b) -> a -> b
$ \Model v
model (Insert Maybe Text
group Maybe Int
_ Int
_ Maybe Int
_ Extras
_) Var Int64 v
output -> Model v
model {mLive = Map.insert output group (mLive model)}]

mkInsert
  :: forall sm
   . (ArbiterC sm)
  => (JobWrite SMPayload -> JobWrite SMPayload)
  -> Maybe Text
  -> Maybe Int
  -> Int
  -> Maybe Int
  -> sm Int64
mkInsert :: forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert JobWrite SMPayload -> JobWrite SMPayload
deco Maybe Text
group Maybe Int
delay Int
prio Maybe Int
maxAtts = do
  nvu <- (Int -> sm UTCTime) -> Maybe Int -> sm (Maybe UTCTime)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (\Int
secs -> IO UTCTime -> sm UTCTime
forall a. IO a -> sm a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
secs) (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime)) Maybe Int
delay
  let job =
        Maybe Int32 -> JobWrite SMPayload -> JobWrite SMPayload
forall payload. Maybe Int32 -> JobWrite payload -> JobWrite payload
setMaxAttempts (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Maybe Int -> Maybe Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
maxAtts)
          (JobWrite SMPayload -> JobWrite SMPayload)
-> JobWrite SMPayload -> JobWrite SMPayload
forall a b. (a -> b) -> a -> b
$ Int32 -> JobWrite SMPayload -> JobWrite SMPayload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prio)
          (JobWrite SMPayload -> JobWrite SMPayload)
-> JobWrite SMPayload -> JobWrite SMPayload
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> JobWrite SMPayload -> JobWrite SMPayload
forall payload.
Maybe UTCTime -> JobWrite payload -> JobWrite payload
setNotVisibleUntil Maybe UTCTime
nvu
          (JobWrite SMPayload -> JobWrite SMPayload)
-> JobWrite SMPayload -> JobWrite SMPayload
forall a b. (a -> b) -> a -> b
$ JobWrite SMPayload
-> (Text -> JobWrite SMPayload) -> Maybe Text -> JobWrite SMPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SMPayload -> JobWrite SMPayload
forall payload. payload -> JobWrite payload
defaultJob SMPayload
payload) (Text -> SMPayload -> JobWrite SMPayload
forall payload. Text -> payload -> JobWrite payload
`defaultGroupedJob` SMPayload
payload) Maybe Text
group
  inserted <- HL.insertJob (deco job)
  pure (primaryKey (fromJust inserted))
  where
    payload :: SMPayload
payload = Text -> SMPayload
smPayload Text
"sm"

data Crash (v :: Type -> Type) = Crash
  deriving stock (Crash v -> Crash v -> Bool
(Crash v -> Crash v -> Bool)
-> (Crash v -> Crash v -> Bool) -> Eq (Crash v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). Crash v -> Crash v -> Bool
$c== :: forall (v :: * -> *). Crash v -> Crash v -> Bool
== :: Crash v -> Crash v -> Bool
$c/= :: forall (v :: * -> *). Crash v -> Crash v -> Bool
/= :: Crash v -> Crash v -> Bool
Eq, (forall x. Crash v -> Rep (Crash v) x)
-> (forall x. Rep (Crash v) x -> Crash v) -> Generic (Crash v)
forall x. Rep (Crash v) x -> Crash v
forall x. Crash v -> Rep (Crash v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (Crash v) x -> Crash v
forall (v :: * -> *) x. Crash v -> Rep (Crash v) x
$cfrom :: forall (v :: * -> *) x. Crash v -> Rep (Crash v) x
from :: forall x. Crash v -> Rep (Crash v) x
$cto :: forall (v :: * -> *) x. Rep (Crash v) x -> Crash v
to :: forall x. Rep (Crash v) x -> Crash v
Generic, Int -> Crash v -> String -> String
[Crash v] -> String -> String
Crash v -> String
(Int -> Crash v -> String -> String)
-> (Crash v -> String)
-> ([Crash v] -> String -> String)
-> Show (Crash v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *). Int -> Crash v -> String -> String
forall (v :: * -> *). [Crash v] -> String -> String
forall (v :: * -> *). Crash v -> String
$cshowsPrec :: forall (v :: * -> *). Int -> Crash v -> String -> String
showsPrec :: Int -> Crash v -> String -> String
$cshow :: forall (v :: * -> *). Crash v -> String
show :: Crash v -> String
$cshowList :: forall (v :: * -> *). [Crash v] -> String -> String
showList :: [Crash v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> Crash f -> Crash g)
-> FunctorB Crash
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Crash f -> Crash g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Crash f -> Crash g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Crash f -> Crash g
B.FunctorB, FunctorB Crash
FunctorB Crash =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> Crash f -> e (Crash g))
-> TraversableB Crash
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Crash f -> e (Crash g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Crash f -> e (Crash g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Crash f -> e (Crash g)
B.TraversableB)

-- | Every live lease lapses, as when every worker dies. Each row keeps its holder.
cCrash
  :: forall gen m
   . (MonadGen gen, MonadIO m, MonadTest m)
  => Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cCrash :: forall (gen :: * -> *) (m :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cCrash Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (Crash Symbolic)))
-> (Crash Concrete -> m ())
-> [Callback Crash () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command
    (\Model Symbolic
_ -> gen (Crash Symbolic) -> Maybe (gen (Crash Symbolic))
forall a. a -> Maybe a
Just (Crash Symbolic -> gen (Crash Symbolic)
forall a. a -> gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Crash Symbolic
forall (v :: * -> *). Crash v
Crash))
    ( \Crash Concrete
Crash -> do
        IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
lapseLeases Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn)
        String
-> Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
String
-> Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariantsL String
"Crash" Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    )
    []

-- | Backdate every live lease, leaving each row's holder in place.
lapseLeases :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO ()
lapseLeases :: Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
lapseLeases Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
  Connection -> Text -> IO ()
execute_ Connection
conn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
    Text
"UPDATE "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" SET not_visible_until = NOW() - interval '1 second'"
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE claimed_by IS NOT NULL AND NOT suspended AND not_visible_until > NOW()"

data SuspendLapsed (v :: Type -> Type) = SuspendLapsed
  deriving stock (SuspendLapsed v -> SuspendLapsed v -> Bool
(SuspendLapsed v -> SuspendLapsed v -> Bool)
-> (SuspendLapsed v -> SuspendLapsed v -> Bool)
-> Eq (SuspendLapsed v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). SuspendLapsed v -> SuspendLapsed v -> Bool
$c== :: forall (v :: * -> *). SuspendLapsed v -> SuspendLapsed v -> Bool
== :: SuspendLapsed v -> SuspendLapsed v -> Bool
$c/= :: forall (v :: * -> *). SuspendLapsed v -> SuspendLapsed v -> Bool
/= :: SuspendLapsed v -> SuspendLapsed v -> Bool
Eq, (forall x. SuspendLapsed v -> Rep (SuspendLapsed v) x)
-> (forall x. Rep (SuspendLapsed v) x -> SuspendLapsed v)
-> Generic (SuspendLapsed v)
forall x. Rep (SuspendLapsed v) x -> SuspendLapsed v
forall x. SuspendLapsed v -> Rep (SuspendLapsed v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (SuspendLapsed v) x -> SuspendLapsed v
forall (v :: * -> *) x. SuspendLapsed v -> Rep (SuspendLapsed v) x
$cfrom :: forall (v :: * -> *) x. SuspendLapsed v -> Rep (SuspendLapsed v) x
from :: forall x. SuspendLapsed v -> Rep (SuspendLapsed v) x
$cto :: forall (v :: * -> *) x. Rep (SuspendLapsed v) x -> SuspendLapsed v
to :: forall x. Rep (SuspendLapsed v) x -> SuspendLapsed v
Generic, Int -> SuspendLapsed v -> String -> String
[SuspendLapsed v] -> String -> String
SuspendLapsed v -> String
(Int -> SuspendLapsed v -> String -> String)
-> (SuspendLapsed v -> String)
-> ([SuspendLapsed v] -> String -> String)
-> Show (SuspendLapsed v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *). Int -> SuspendLapsed v -> String -> String
forall (v :: * -> *). [SuspendLapsed v] -> String -> String
forall (v :: * -> *). SuspendLapsed v -> String
$cshowsPrec :: forall (v :: * -> *). Int -> SuspendLapsed v -> String -> String
showsPrec :: Int -> SuspendLapsed v -> String -> String
$cshow :: forall (v :: * -> *). SuspendLapsed v -> String
show :: SuspendLapsed v -> String
$cshowList :: forall (v :: * -> *). [SuspendLapsed v] -> String -> String
showList :: [SuspendLapsed v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> SuspendLapsed f -> SuspendLapsed g)
-> FunctorB SuspendLapsed
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> SuspendLapsed f -> SuspendLapsed g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> SuspendLapsed f -> SuspendLapsed g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> SuspendLapsed f -> SuspendLapsed g
B.FunctorB, FunctorB SuspendLapsed
FunctorB SuspendLapsed =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a))
 -> SuspendLapsed f -> e (SuspendLapsed g))
-> TraversableB SuspendLapsed
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a))
-> SuspendLapsed f -> e (SuspendLapsed g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a))
-> SuspendLapsed f -> e (SuspendLapsed g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a))
-> SuspendLapsed f -> e (SuspendLapsed g)
B.TraversableB)

-- | Claim, let every lease lapse, then suspend what was claimed. An admin pause of a job
-- whose worker died.
cSuspendLapsed
  :: forall gen m sm
   . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cSuspendLapsed :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cSuspendLapsed forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (SuspendLapsed Symbolic)))
-> (SuspendLapsed Concrete -> m ())
-> [Callback SuspendLapsed () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command
    (\Model Symbolic
_ -> gen (SuspendLapsed Symbolic)
-> Maybe (gen (SuspendLapsed Symbolic))
forall a. a -> Maybe a
Just (SuspendLapsed Symbolic -> gen (SuspendLapsed Symbolic)
forall a. a -> gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SuspendLapsed Symbolic
forall (v :: * -> *). SuspendLapsed v
SuspendLapsed))
    ( \SuspendLapsed Concrete
SuspendLapsed -> do
        ids <- IO [Int64] -> m [Int64]
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm [Int64] -> IO [Int64]
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => sm [Int64]
mkClaim @sm))
        evalIO (lapseLeases schema table withConn)
        evalIO (run (traverse_ (void . HL.suspendJob @SMPayload) ids))
        checkInvariantsL "SuspendLapsed" schema table withConn
    )
    []

data Claim (v :: Type -> Type) = Claim
  deriving stock (Claim v -> Claim v -> Bool
(Claim v -> Claim v -> Bool)
-> (Claim v -> Claim v -> Bool) -> Eq (Claim v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). Claim v -> Claim v -> Bool
$c== :: forall (v :: * -> *). Claim v -> Claim v -> Bool
== :: Claim v -> Claim v -> Bool
$c/= :: forall (v :: * -> *). Claim v -> Claim v -> Bool
/= :: Claim v -> Claim v -> Bool
Eq, (forall x. Claim v -> Rep (Claim v) x)
-> (forall x. Rep (Claim v) x -> Claim v) -> Generic (Claim v)
forall x. Rep (Claim v) x -> Claim v
forall x. Claim v -> Rep (Claim v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (Claim v) x -> Claim v
forall (v :: * -> *) x. Claim v -> Rep (Claim v) x
$cfrom :: forall (v :: * -> *) x. Claim v -> Rep (Claim v) x
from :: forall x. Claim v -> Rep (Claim v) x
$cto :: forall (v :: * -> *) x. Rep (Claim v) x -> Claim v
to :: forall x. Rep (Claim v) x -> Claim v
Generic, Int -> Claim v -> String -> String
[Claim v] -> String -> String
Claim v -> String
(Int -> Claim v -> String -> String)
-> (Claim v -> String)
-> ([Claim v] -> String -> String)
-> Show (Claim v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *). Int -> Claim v -> String -> String
forall (v :: * -> *). [Claim v] -> String -> String
forall (v :: * -> *). Claim v -> String
$cshowsPrec :: forall (v :: * -> *). Int -> Claim v -> String -> String
showsPrec :: Int -> Claim v -> String -> String
$cshow :: forall (v :: * -> *). Claim v -> String
show :: Claim v -> String
$cshowList :: forall (v :: * -> *). [Claim v] -> String -> String
showList :: [Claim v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> Claim f -> Claim g)
-> FunctorB Claim
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Claim f -> Claim g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Claim f -> Claim g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Claim f -> Claim g
B.FunctorB, FunctorB Claim
FunctorB Claim =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> Claim f -> e (Claim g))
-> TraversableB Claim
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Claim f -> e (Claim g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Claim f -> e (Claim g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Claim f -> e (Claim g)
B.TraversableB)

cClaim
  :: forall gen m sm
   . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cClaim :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cClaim forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (Claim Symbolic)))
-> (Claim Concrete -> m [Int64])
-> [Callback Claim [Int64] Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command
    (\Model Symbolic
_ -> gen (Claim Symbolic) -> Maybe (gen (Claim Symbolic))
forall a. a -> Maybe a
Just (Claim Symbolic -> gen (Claim Symbolic)
forall a. a -> gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Claim Symbolic
forall (v :: * -> *). Claim v
Claim))
    ( \Claim Concrete
Claim -> do
        ids <- IO [Int64] -> m [Int64]
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm [Int64] -> IO [Int64]
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => sm [Int64]
mkClaim @sm))
        -- Each claimed job is now a live in-flight row.
        live <- evalIO (traverse (isLiveInFlight schema table withConn) ids)
        assert (and live)
        checkInvariants schema table withConn
        pure ids
    )
    [ (Model Concrete
 -> Model Concrete -> Claim Concrete -> [Int64] -> Test ())
-> Callback Claim [Int64] Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(state Concrete
 -> state Concrete -> input Concrete -> output -> Test ())
-> Callback input output state
Ensure ((Model Concrete
  -> Model Concrete -> Claim Concrete -> [Int64] -> Test ())
 -> Callback Claim [Int64] Model)
-> (Model Concrete
    -> Model Concrete -> Claim Concrete -> [Int64] -> Test ())
-> Callback Claim [Int64] Model
forall a b. (a -> b) -> a -> b
$ \Model Concrete
_ Model Concrete
post Claim Concrete
Claim [Int64]
ids -> do
        -- Never claim more than the batch size.
        Bool -> Test ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert ([Int64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
ids Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
claimBatchSize)
        -- A claimed id is never a DLQ row. Untracked jobs are claimable and absent
        -- from the model.
        let dlqIds :: [Int64]
dlqIds = (Var Int64 Concrete -> Int64) -> [Var Int64 Concrete] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Var Int64 Concrete -> Int64
forall a. Var a Concrete -> a
concrete (Map (Var Int64 Concrete) (Maybe Text) -> [Var Int64 Concrete]
forall k a. Map k a -> [k]
Map.keys (Model Concrete -> Map (Var Int64 Concrete) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mDlq Model Concrete
post))
        (Int64 -> Bool) -> [Int64] -> [Int64]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int64 -> [Int64] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int64]
dlqIds) [Int64]
ids [Int64] -> [Int64] -> Test ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== []
    ]

claimBatchSize :: Int
claimBatchSize :: Int
claimBatchSize = Int
3

mkClaim :: forall sm. (ArbiterC sm) => sm [Int64]
mkClaim :: forall (sm :: * -> *). ArbiterC sm => sm [Int64]
mkClaim = do
  jobs <- Int -> NominalDiffTime -> UUID -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> UUID -> m [JobRead payload]
HL.claimNextVisibleJobsAs Int
claimBatchSize NominalDiffTime
60 UUID
smWorker :: sm [JobRead SMPayload]
  pure (map primaryKey jobs)

-- | True if the id names a live row that is currently in flight.
isLiveInFlight :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> Int64 -> IO Bool
isLiveInFlight :: Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Int64
-> IO Bool
isLiveInFlight Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn Int64
jid = (Connection -> IO Bool) -> IO Bool
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO Bool) -> IO Bool)
-> (Connection -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  rows <-
    Connection -> Query -> Only Int64 -> IO [Only Int64]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
conn (Text -> Query
toQuery Text
sql) (Int64 -> Only Int64
forall a. a -> Only a
Only Int64
jid)
  pure $ case rows of
    Only Int64
count : [Only Int64]
_ -> (Int64
count :: Int64) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0
    [Only Int64]
_ -> Bool
False
  where
    sql :: Text
sql =
      Text
"SELECT count(*) FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = ? AND not_visible_until > NOW() AND NOT suspended AND attempts > 0"

-- | @(leased, suspended, nvu)@ for one row.
leaseState
  :: Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Int64
  -> IO (Bool, Bool, Maybe UTCTime)
leaseState :: Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Int64
-> IO (Bool, Bool, Maybe UTCTime)
leaseState Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn Int64
jid = (Connection -> IO (Bool, Bool, Maybe UTCTime))
-> IO (Bool, Bool, Maybe UTCTime)
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO (Bool, Bool, Maybe UTCTime))
 -> IO (Bool, Bool, Maybe UTCTime))
-> (Connection -> IO (Bool, Bool, Maybe UTCTime))
-> IO (Bool, Bool, Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  rows <- Connection
-> Query -> Only Int64 -> IO [(Bool, Bool, Maybe UTCTime)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
conn (Text -> Query
toQuery Text
sql) (Int64 -> Only Int64
forall a. a -> Only a
Only Int64
jid)
  pure $ case rows of
    (Bool, Bool, Maybe UTCTime)
row : [(Bool, Bool, Maybe UTCTime)]
_ -> (Bool, Bool, Maybe UTCTime)
row
    [(Bool, Bool, Maybe UTCTime)]
_ -> (Bool
False, Bool
False, Maybe UTCTime
forall a. Maybe a
Nothing)
  where
    sql :: Text
sql =
      Text
"SELECT claimed_by IS NOT NULL AND NOT suspended AND not_visible_until IS NOT NULL AND not_visible_until > NOW(), suspended, not_visible_until FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = ?"

-- | True if a row with this id is present in the main table.
rowExists :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> Int64 -> IO Bool
rowExists :: Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Int64
-> IO Bool
rowExists Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn Int64
jid = (Connection -> IO Bool) -> IO Bool
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO Bool) -> IO Bool)
-> (Connection -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  rows <- Connection -> Query -> Only Int64 -> IO [Only Int64]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
conn (Text -> Query
toQuery Text
sql) (Int64 -> Only Int64
forall a. a -> Only a
Only Int64
jid)
  pure $ case rows of
    Only Int64
count : [Only Int64]
_ -> (Int64
count :: Int64) Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0
    [Only Int64]
_ -> Bool
False
  where
    sql :: Text
sql = Text
"SELECT count(*) FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = ?"

-- | A reference to an existing live job, shared by every id-targeted command.
newtype JobRef (v :: Type -> Type) = JobRef (Var Int64 v)
  deriving stock (JobRef v -> JobRef v -> Bool
(JobRef v -> JobRef v -> Bool)
-> (JobRef v -> JobRef v -> Bool) -> Eq (JobRef v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). Eq1 v => JobRef v -> JobRef v -> Bool
$c== :: forall (v :: * -> *). Eq1 v => JobRef v -> JobRef v -> Bool
== :: JobRef v -> JobRef v -> Bool
$c/= :: forall (v :: * -> *). Eq1 v => JobRef v -> JobRef v -> Bool
/= :: JobRef v -> JobRef v -> Bool
Eq, (forall x. JobRef v -> Rep (JobRef v) x)
-> (forall x. Rep (JobRef v) x -> JobRef v) -> Generic (JobRef v)
forall x. Rep (JobRef v) x -> JobRef v
forall x. JobRef v -> Rep (JobRef v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (JobRef v) x -> JobRef v
forall (v :: * -> *) x. JobRef v -> Rep (JobRef v) x
$cfrom :: forall (v :: * -> *) x. JobRef v -> Rep (JobRef v) x
from :: forall x. JobRef v -> Rep (JobRef v) x
$cto :: forall (v :: * -> *) x. Rep (JobRef v) x -> JobRef v
to :: forall x. Rep (JobRef v) x -> JobRef v
Generic, Int -> JobRef v -> String -> String
[JobRef v] -> String -> String
JobRef v -> String
(Int -> JobRef v -> String -> String)
-> (JobRef v -> String)
-> ([JobRef v] -> String -> String)
-> Show (JobRef v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *).
Show1 v =>
Int -> JobRef v -> String -> String
forall (v :: * -> *). Show1 v => [JobRef v] -> String -> String
forall (v :: * -> *). Show1 v => JobRef v -> String
$cshowsPrec :: forall (v :: * -> *).
Show1 v =>
Int -> JobRef v -> String -> String
showsPrec :: Int -> JobRef v -> String -> String
$cshow :: forall (v :: * -> *). Show1 v => JobRef v -> String
show :: JobRef v -> String
$cshowList :: forall (v :: * -> *). Show1 v => [JobRef v] -> String -> String
showList :: [JobRef v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> JobRef f -> JobRef g)
-> FunctorB JobRef
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> JobRef f -> JobRef g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> JobRef f -> JobRef g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> JobRef f -> JobRef g
B.FunctorB, FunctorB JobRef
FunctorB JobRef =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> JobRef f -> e (JobRef g))
-> TraversableB JobRef
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> JobRef f -> e (JobRef g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> JobRef f -> e (JobRef g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> JobRef f -> e (JobRef g)
B.TraversableB)

-- | @Retry job backoff@. A zero backoff returns the job to the claim pool at once.
data Retry (v :: Type -> Type) = Retry (Var Int64 v) NominalDiffTime
  deriving stock (Retry v -> Retry v -> Bool
(Retry v -> Retry v -> Bool)
-> (Retry v -> Retry v -> Bool) -> Eq (Retry v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). Eq1 v => Retry v -> Retry v -> Bool
$c== :: forall (v :: * -> *). Eq1 v => Retry v -> Retry v -> Bool
== :: Retry v -> Retry v -> Bool
$c/= :: forall (v :: * -> *). Eq1 v => Retry v -> Retry v -> Bool
/= :: Retry v -> Retry v -> Bool
Eq, (forall x. Retry v -> Rep (Retry v) x)
-> (forall x. Rep (Retry v) x -> Retry v) -> Generic (Retry v)
forall x. Rep (Retry v) x -> Retry v
forall x. Retry v -> Rep (Retry v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (Retry v) x -> Retry v
forall (v :: * -> *) x. Retry v -> Rep (Retry v) x
$cfrom :: forall (v :: * -> *) x. Retry v -> Rep (Retry v) x
from :: forall x. Retry v -> Rep (Retry v) x
$cto :: forall (v :: * -> *) x. Rep (Retry v) x -> Retry v
to :: forall x. Rep (Retry v) x -> Retry v
Generic, Int -> Retry v -> String -> String
[Retry v] -> String -> String
Retry v -> String
(Int -> Retry v -> String -> String)
-> (Retry v -> String)
-> ([Retry v] -> String -> String)
-> Show (Retry v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *). Show1 v => Int -> Retry v -> String -> String
forall (v :: * -> *). Show1 v => [Retry v] -> String -> String
forall (v :: * -> *). Show1 v => Retry v -> String
$cshowsPrec :: forall (v :: * -> *). Show1 v => Int -> Retry v -> String -> String
showsPrec :: Int -> Retry v -> String -> String
$cshow :: forall (v :: * -> *). Show1 v => Retry v -> String
show :: Retry v -> String
$cshowList :: forall (v :: * -> *). Show1 v => [Retry v] -> String -> String
showList :: [Retry v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> Retry f -> Retry g)
-> FunctorB Retry
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Retry f -> Retry g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Retry f -> Retry g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Retry f -> Retry g
B.FunctorB, FunctorB Retry
FunctorB Retry =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> Retry f -> e (Retry g))
-> TraversableB Retry
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Retry f -> e (Retry g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Retry f -> e (Retry g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Retry f -> e (Retry g)
B.TraversableB)

-- | Retry backoffs the model draws from.
retryBackoffs :: [NominalDiffTime]
retryBackoffs :: [NominalDiffTime]
retryBackoffs = [NominalDiffTime
0, NominalDiffTime
30]

-- | A command that picks a live job from the model and runs an id-keyed
-- operation, tagging any invariant failure with the label. @removes@ says
-- whether the job leaves the queue. The post-check runs after the operation.
jobRefCommandL'
  :: (MonadGen gen, MonadIO m, MonadTest m)
  => String
  -> (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Bool
  -> (Int64 -> m ())
  -> (Int64 -> sm ())
  -> Command gen m Model
jobRefCommandL' :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> m ())
-> (Int64 -> sm ())
-> Command gen m Model
jobRefCommandL' String
lbl forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn Bool
removes Int64 -> m ()
postCheck Int64 -> sm ()
operation =
  (Model Symbolic -> Maybe (gen (JobRef Symbolic)))
-> (JobRef Concrete -> m ())
-> [Callback JobRef () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command Model Symbolic -> Maybe (gen (JobRef Symbolic))
forall {f :: * -> *} {v :: * -> *}.
MonadGen f =>
Model v -> Maybe (f (JobRef v))
gen JobRef Concrete -> m ()
exec [Callback JobRef () Model]
callbacks
  where
    gen :: Model v -> Maybe (f (JobRef v))
gen Model v
model
      | Map (Var Int64 v) (Maybe Text) -> Bool
forall k a. Map k a -> Bool
Map.null (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model) = Maybe (f (JobRef v))
forall a. Maybe a
Nothing
      | Bool
otherwise = f (JobRef v) -> Maybe (f (JobRef v))
forall a. a -> Maybe a
Just (Var Int64 v -> JobRef v
forall (v :: * -> *). Var Int64 v -> JobRef v
JobRef (Var Int64 v -> JobRef v) -> f (Var Int64 v) -> f (JobRef v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var Int64 v] -> f (Var Int64 v)
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element (Map (Var Int64 v) (Maybe Text) -> [Var Int64 v]
forall k a. Map k a -> [k]
Map.keys (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model)))
    exec :: JobRef Concrete -> m ()
exec (JobRef Var Int64 Concrete
ref) = do
      IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm () -> IO ()
forall a. sm a -> IO a
run (Int64 -> sm ()
operation (Var Int64 Concrete -> Int64
forall a. Var a Concrete -> a
concrete Var Int64 Concrete
ref)))
      Int64 -> m ()
postCheck (Var Int64 Concrete -> Int64
forall a. Var a Concrete -> a
concrete Var Int64 Concrete
ref)
      String
-> Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
String
-> Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariantsL String
lbl Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    callbacks :: [Callback JobRef () Model]
callbacks =
      (Model Symbolic -> JobRef Symbolic -> Bool)
-> Callback JobRef () Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(state Symbolic -> input Symbolic -> Bool)
-> Callback input output state
Require (\Model Symbolic
model (JobRef Var Int64 Symbolic
ref) -> Var Int64 Symbolic -> Map (Var Int64 Symbolic) (Maybe Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Var Int64 Symbolic
ref (Model Symbolic -> Map (Var Int64 Symbolic) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model Symbolic
model))
        Callback JobRef () Model
-> [Callback JobRef () Model] -> [Callback JobRef () Model]
forall a. a -> [a] -> [a]
: [(forall (v :: * -> *).
 Ord1 v =>
 Model v -> JobRef v -> Var () v -> Model v)
-> Callback JobRef () Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(forall (v :: * -> *).
 Ord1 v =>
 state v -> input v -> Var output v -> state v)
-> Callback input output state
Update (\Model v
model (JobRef Var Int64 v
ref) Var () v
_ -> Model v
model {mLive = Map.delete ref (mLive model)}) | Bool
removes]

jobRefCommandL
  :: (MonadGen gen, MonadIO m, MonadTest m)
  => String
  -> (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Bool
  -> (Int64 -> sm ())
  -> Command gen m Model
jobRefCommandL :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
jobRefCommandL String
lbl forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn Bool
removes =
  String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> m ())
-> (Int64 -> sm ())
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> m ())
-> (Int64 -> sm ())
-> Command gen m Model
jobRefCommandL' String
lbl sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Bool
removes (\Int64
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

cAck
  , cCancel
  , cSuspend
  , cResume
  , cPromote
  , cRetry
  , cExtend
  , cRelease
    :: forall gen m sm
     . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
    => (forall a. sm a -> IO a)
    -> Text
    -> Text
    -> (forall a. (PG.Connection -> IO a) -> IO a)
    -> Command gen m Model
cAck :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cAck forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> m ())
-> (Int64 -> sm ())
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> m ())
-> (Int64 -> sm ())
-> Command gen m Model
jobRefCommandL' String
"Ack" sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Bool
True Int64 -> m ()
ackedRowGone Int64 -> sm ()
forall (sm :: * -> *). ArbiterC sm => Int64 -> sm ()
mkAck
  where
    -- An acked tracked job is gone from the main table. Tracked jobs are never
    -- rollup finalizers.
    ackedRowGone :: Int64 -> m ()
ackedRowGone Int64
jid = do
      present <- IO Bool -> m Bool
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Int64
-> IO Bool
rowExists Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
jid)
      present === False
cCancel :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cCancel forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
jobRefCommandL String
"Cancel" sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Bool
True (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.cancelJob @SMPayload)
cSuspend :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cSuspend forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
jobRefCommandL String
"Suspend" sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Bool
False (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.suspendJob @SMPayload)
cResume :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cResume forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
jobRefCommandL String
"Resume" sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Bool
False (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.resumeJob @SMPayload)
cPromote :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cPromote forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (JobRef Symbolic)))
-> (JobRef Concrete -> m ())
-> [Callback JobRef () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command Model Symbolic -> Maybe (gen (JobRef Symbolic))
forall {f :: * -> *} {v :: * -> *}.
MonadGen f =>
Model v -> Maybe (f (JobRef v))
gen JobRef Concrete -> m ()
exec [(Model Symbolic -> JobRef Symbolic -> Bool)
-> Callback JobRef () Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(state Symbolic -> input Symbolic -> Bool)
-> Callback input output state
Require (\Model Symbolic
model (JobRef Var Int64 Symbolic
ref) -> Var Int64 Symbolic -> Map (Var Int64 Symbolic) (Maybe Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Var Int64 Symbolic
ref (Model Symbolic -> Map (Var Int64 Symbolic) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model Symbolic
model))]
  where
    gen :: Model v -> Maybe (f (JobRef v))
gen Model v
model
      | Map (Var Int64 v) (Maybe Text) -> Bool
forall k a. Map k a -> Bool
Map.null (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model) = Maybe (f (JobRef v))
forall a. Maybe a
Nothing
      | Bool
otherwise = f (JobRef v) -> Maybe (f (JobRef v))
forall a. a -> Maybe a
Just (Var Int64 v -> JobRef v
forall (v :: * -> *). Var Int64 v -> JobRef v
JobRef (Var Int64 v -> JobRef v) -> f (Var Int64 v) -> f (JobRef v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var Int64 v] -> f (Var Int64 v)
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element (Map (Var Int64 v) (Maybe Text) -> [Var Int64 v]
forall k a. Map k a -> [k]
Map.keys (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model)))
    -- Promote holds no claim. A leased or suspended row comes back untouched.
    exec :: JobRef Concrete -> m ()
exec (JobRef Var Int64 Concrete
ref) = do
      let jid :: Int64
jid = Var Int64 Concrete -> Int64
forall a. Var a Concrete -> a
concrete Var Int64 Concrete
ref
      (leased, susp, nvu) <- IO (Bool, Bool, Maybe UTCTime) -> m (Bool, Bool, Maybe UTCTime)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Int64
-> IO (Bool, Bool, Maybe UTCTime)
leaseState Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
jid)
      promoted <- evalIO (run (HL.promoteJob @SMPayload jid))
      when (leased || susp) $ do
        annotate ((if leased then "leased" else "suspended") <> " job " <> show jid <> " was promoted")
        promoted === 0
        (_, _, nvu') <- evalIO (leaseState schema table withConn jid)
        nvu' === nvu
      checkInvariantsL "Promote" schema table withConn
cRetry :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cRetry forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (Retry Symbolic)))
-> (Retry Concrete -> m ())
-> [Callback Retry () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command Model Symbolic -> Maybe (gen (Retry Symbolic))
forall {f :: * -> *} {v :: * -> *}.
MonadGen f =>
Model v -> Maybe (f (Retry v))
gen Retry Concrete -> m ()
exec [(Model Symbolic -> Retry Symbolic -> Bool)
-> Callback Retry () Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(state Symbolic -> input Symbolic -> Bool)
-> Callback input output state
Require (\Model Symbolic
model (Retry Var Int64 Symbolic
ref NominalDiffTime
_) -> Var Int64 Symbolic -> Map (Var Int64 Symbolic) (Maybe Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Var Int64 Symbolic
ref (Model Symbolic -> Map (Var Int64 Symbolic) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model Symbolic
model))]
  where
    gen :: Model v -> Maybe (f (Retry v))
gen Model v
model
      | Map (Var Int64 v) (Maybe Text) -> Bool
forall k a. Map k a -> Bool
Map.null (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model) = Maybe (f (Retry v))
forall a. Maybe a
Nothing
      | Bool
otherwise = f (Retry v) -> Maybe (f (Retry v))
forall a. a -> Maybe a
Just (Var Int64 v -> NominalDiffTime -> Retry v
forall (v :: * -> *). Var Int64 v -> NominalDiffTime -> Retry v
Retry (Var Int64 v -> NominalDiffTime -> Retry v)
-> f (Var Int64 v) -> f (NominalDiffTime -> Retry v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var Int64 v] -> f (Var Int64 v)
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element (Map (Var Int64 v) (Maybe Text) -> [Var Int64 v]
forall k a. Map k a -> [k]
Map.keys (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model)) f (NominalDiffTime -> Retry v) -> f NominalDiffTime -> f (Retry v)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [NominalDiffTime] -> f NominalDiffTime
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element [NominalDiffTime]
retryBackoffs)
    exec :: Retry Concrete -> m ()
exec (Retry Var Int64 Concrete
ref NominalDiffTime
backoff) = do
      IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
Int64 -> NominalDiffTime -> sm ()
mkRetry @sm (Var Int64 Concrete -> Int64
forall a. Var a Concrete -> a
concrete Var Int64 Concrete
ref) NominalDiffTime
backoff))
      String
-> Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
String
-> Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariantsL String
"Retry" Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
cExtend :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cExtend forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
jobRefCommandL String
"Extend" sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Bool
False Int64 -> sm ()
forall (sm :: * -> *). ArbiterC sm => Int64 -> sm ()
mkExtend

-- | Release a job's lease with a visibility timeout of 0. Claim and release
-- cycles drive a job to its @max_attempts@.
cRelease :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cRelease forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
String
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Bool
-> (Int64 -> sm ())
-> Command gen m Model
jobRefCommandL String
"Release" sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Bool
False Int64 -> sm ()
forall (sm :: * -> *). ArbiterC sm => Int64 -> sm ()
mkRelease

-- | Read a job by id at this test's payload type.
fetchJob :: forall sm. (ArbiterC sm) => Int64 -> sm (Maybe (JobRead SMPayload))
fetchJob :: forall (sm :: * -> *).
ArbiterC sm =>
Int64 -> sm (Maybe (JobRead SMPayload))
fetchJob = Int64 -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.getJobById

mkAck
  , mkExtend
  , mkRelease
  , mkToDLQ
    :: forall sm
     . (ArbiterC sm)
    => Int64
    -> sm ()
mkAck :: forall (sm :: * -> *). ArbiterC sm => Int64 -> sm ()
mkAck Int64
jid = forall (sm :: * -> *).
ArbiterC sm =>
Int64 -> sm (Maybe (JobRead SMPayload))
fetchJob @sm Int64
jid sm (Maybe (JobRead SMPayload))
-> (Maybe (JobRead SMPayload) -> sm ()) -> sm ()
forall a b. sm a -> (a -> sm b) -> sm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (JobRead SMPayload -> sm ()) -> Maybe (JobRead SMPayload) -> sm ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob)

-- | Park a leased job for @backoff@ seconds.
mkRetry :: forall sm. (ArbiterC sm) => Int64 -> NominalDiffTime -> sm ()
mkRetry :: forall (sm :: * -> *).
ArbiterC sm =>
Int64 -> NominalDiffTime -> sm ()
mkRetry Int64
jid NominalDiffTime
backoff = forall (sm :: * -> *).
ArbiterC sm =>
Int64 -> sm (Maybe (JobRead SMPayload))
fetchJob @sm Int64
jid sm (Maybe (JobRead SMPayload))
-> (Maybe (JobRead SMPayload) -> sm ()) -> sm ()
forall a b. sm a -> (a -> sm b) -> sm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (JobRead SMPayload -> sm ()) -> Maybe (JobRead SMPayload) -> sm ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\JobRead SMPayload
job -> JobRead SMPayload -> sm () -> sm ()
forall (m :: * -> *).
MonadIO m =>
JobRead SMPayload -> m () -> m ()
whenLeased JobRead SMPayload
job (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (NominalDiffTime -> Text -> JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
NominalDiffTime -> Text -> JobRead payload -> m Int64
HL.updateJobForRetry NominalDiffTime
backoff Text
"sm retry" JobRead SMPayload
job)))

mkExtend :: forall (sm :: * -> *). ArbiterC sm => Int64 -> sm ()
mkExtend Int64
jid = forall (sm :: * -> *).
ArbiterC sm =>
Int64 -> sm (Maybe (JobRead SMPayload))
fetchJob @sm Int64
jid sm (Maybe (JobRead SMPayload))
-> (Maybe (JobRead SMPayload) -> sm ()) -> sm ()
forall a b. sm a -> (a -> sm b) -> sm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (JobRead SMPayload -> sm ()) -> Maybe (JobRead SMPayload) -> sm ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\JobRead SMPayload
job -> JobRead SMPayload -> sm () -> sm ()
forall (m :: * -> *).
MonadIO m =>
JobRead SMPayload -> m () -> m ()
whenLeased JobRead SMPayload
job (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (NominalDiffTime -> JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
NominalDiffTime -> JobRead payload -> m Int64
HL.setVisibilityTimeout NominalDiffTime
90 JobRead SMPayload
job)))
mkRelease :: forall (sm :: * -> *). ArbiterC sm => Int64 -> sm ()
mkRelease Int64
jid = forall (sm :: * -> *).
ArbiterC sm =>
Int64 -> sm (Maybe (JobRead SMPayload))
fetchJob @sm Int64
jid sm (Maybe (JobRead SMPayload))
-> (Maybe (JobRead SMPayload) -> sm ()) -> sm ()
forall a b. sm a -> (a -> sm b) -> sm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (JobRead SMPayload -> sm ()) -> Maybe (JobRead SMPayload) -> sm ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\JobRead SMPayload
job -> JobRead SMPayload -> sm () -> sm ()
forall (m :: * -> *).
MonadIO m =>
JobRead SMPayload -> m () -> m ()
whenLeased JobRead SMPayload
job (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (NominalDiffTime -> JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
NominalDiffTime -> JobRead payload -> m Int64
HL.setVisibilityTimeout NominalDiffTime
0 JobRead SMPayload
job)))
mkToDLQ :: forall (sm :: * -> *). ArbiterC sm => Int64 -> sm ()
mkToDLQ Int64
jid = forall (sm :: * -> *).
ArbiterC sm =>
Int64 -> sm (Maybe (JobRead SMPayload))
fetchJob @sm Int64
jid sm (Maybe (JobRead SMPayload))
-> (Maybe (JobRead SMPayload) -> sm ()) -> sm ()
forall a b. sm a -> (a -> sm b) -> sm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (JobRead SMPayload -> sm ()) -> Maybe (JobRead SMPayload) -> sm ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
Text -> JobRead payload -> m Int64
HL.moveToDLQ Text
"sm dlq")

-- | Run a lease-management action only when the job is currently in flight.
whenLeased :: (MonadIO m) => JobRead SMPayload -> m () -> m ()
whenLeased :: forall (m :: * -> *).
MonadIO m =>
JobRead SMPayload -> m () -> m ()
whenLeased JobRead SMPayload
job m ()
act = do
  now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  when (attempts job > 0 && not (suspended job) && maybe False (> now) (notVisibleUntil job)) act

-- | Move a live job to the DLQ, then capture the new DLQ row id.
cToDLQ
  :: forall gen m sm
   . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cToDLQ :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cToDLQ forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (JobRef Symbolic)))
-> (JobRef Concrete -> m Int64)
-> [Callback JobRef Int64 Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command Model Symbolic -> Maybe (gen (JobRef Symbolic))
forall {f :: * -> *} {v :: * -> *}.
MonadGen f =>
Model v -> Maybe (f (JobRef v))
gen JobRef Concrete -> m Int64
exec [Callback JobRef Int64 Model]
callbacks
  where
    gen :: Model v -> Maybe (f (JobRef v))
gen Model v
model
      | Map (Var Int64 v) (Maybe Text) -> Bool
forall k a. Map k a -> Bool
Map.null (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model) = Maybe (f (JobRef v))
forall a. Maybe a
Nothing
      | Bool
otherwise = f (JobRef v) -> Maybe (f (JobRef v))
forall a. a -> Maybe a
Just (Var Int64 v -> JobRef v
forall (v :: * -> *). Var Int64 v -> JobRef v
JobRef (Var Int64 v -> JobRef v) -> f (Var Int64 v) -> f (JobRef v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var Int64 v] -> f (Var Int64 v)
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element (Map (Var Int64 v) (Maybe Text) -> [Var Int64 v]
forall k a. Map k a -> [k]
Map.keys (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model)))
    exec :: JobRef Concrete -> m Int64
exec (JobRef Var Int64 Concrete
ref) = do
      let jid :: Int64
jid = Var Int64 Concrete -> Int64
forall a. Var a Concrete -> a
concrete Var Int64 Concrete
ref
      dlqId <- IO Int64 -> m Int64
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => Int64 -> sm ()
mkToDLQ @sm Int64
jid) IO () -> IO Int64 -> IO Int64
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Int64
-> IO Int64
lookupDlqId Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
jid)
      checkInvariants schema table withConn
      pure dlqId
    callbacks :: [Callback JobRef Int64 Model]
callbacks =
      [ (Model Symbolic -> JobRef Symbolic -> Bool)
-> Callback JobRef Int64 Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(state Symbolic -> input Symbolic -> Bool)
-> Callback input output state
Require ((Model Symbolic -> JobRef Symbolic -> Bool)
 -> Callback JobRef Int64 Model)
-> (Model Symbolic -> JobRef Symbolic -> Bool)
-> Callback JobRef Int64 Model
forall a b. (a -> b) -> a -> b
$ \Model Symbolic
model (JobRef Var Int64 Symbolic
ref) -> Var Int64 Symbolic -> Map (Var Int64 Symbolic) (Maybe Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Var Int64 Symbolic
ref (Model Symbolic -> Map (Var Int64 Symbolic) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model Symbolic
model)
      , (forall (v :: * -> *).
 Ord1 v =>
 Model v -> JobRef v -> Var Int64 v -> Model v)
-> Callback JobRef Int64 Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(forall (v :: * -> *).
 Ord1 v =>
 state v -> input v -> Var output v -> state v)
-> Callback input output state
Update ((forall (v :: * -> *).
  Ord1 v =>
  Model v -> JobRef v -> Var Int64 v -> Model v)
 -> Callback JobRef Int64 Model)
-> (forall (v :: * -> *).
    Ord1 v =>
    Model v -> JobRef v -> Var Int64 v -> Model v)
-> Callback JobRef Int64 Model
forall a b. (a -> b) -> a -> b
$ \Model v
model (JobRef Var Int64 v
ref) Var Int64 v
output ->
          Model v
model
            { mLive = Map.delete ref (mLive model)
            , mDlq = Map.insert output (Map.findWithDefault Nothing ref (mLive model)) (mDlq model)
            }
      ]

-- | Retry a DLQ job back into the main queue, capturing its new id.
cFromDLQ
  :: forall gen m sm
   . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cFromDLQ :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cFromDLQ forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (JobRef Symbolic)))
-> (JobRef Concrete -> m Int64)
-> [Callback JobRef Int64 Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command Model Symbolic -> Maybe (gen (JobRef Symbolic))
forall {f :: * -> *} {v :: * -> *}.
MonadGen f =>
Model v -> Maybe (f (JobRef v))
gen JobRef Concrete -> m Int64
exec [Callback JobRef Int64 Model]
callbacks
  where
    gen :: Model v -> Maybe (f (JobRef v))
gen Model v
model
      | Map (Var Int64 v) (Maybe Text) -> Bool
forall k a. Map k a -> Bool
Map.null (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mDlq Model v
model) = Maybe (f (JobRef v))
forall a. Maybe a
Nothing
      | Bool
otherwise = f (JobRef v) -> Maybe (f (JobRef v))
forall a. a -> Maybe a
Just (Var Int64 v -> JobRef v
forall (v :: * -> *). Var Int64 v -> JobRef v
JobRef (Var Int64 v -> JobRef v) -> f (Var Int64 v) -> f (JobRef v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var Int64 v] -> f (Var Int64 v)
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element (Map (Var Int64 v) (Maybe Text) -> [Var Int64 v]
forall k a. Map k a -> [k]
Map.keys (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mDlq Model v
model)))
    exec :: JobRef Concrete -> m Int64
exec (JobRef Var Int64 Concrete
ref) = do
      newId <- IO Int64 -> m Int64
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm Int64 -> IO Int64
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => Int64 -> sm Int64
mkFromDLQ @sm (Var Int64 Concrete -> Int64
forall a. Var a Concrete -> a
concrete Var Int64 Concrete
ref)))
      checkInvariants schema table withConn
      pure newId
    callbacks :: [Callback JobRef Int64 Model]
callbacks =
      [ (Model Symbolic -> JobRef Symbolic -> Bool)
-> Callback JobRef Int64 Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(state Symbolic -> input Symbolic -> Bool)
-> Callback input output state
Require ((Model Symbolic -> JobRef Symbolic -> Bool)
 -> Callback JobRef Int64 Model)
-> (Model Symbolic -> JobRef Symbolic -> Bool)
-> Callback JobRef Int64 Model
forall a b. (a -> b) -> a -> b
$ \Model Symbolic
model (JobRef Var Int64 Symbolic
ref) -> Var Int64 Symbolic -> Map (Var Int64 Symbolic) (Maybe Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Var Int64 Symbolic
ref (Model Symbolic -> Map (Var Int64 Symbolic) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mDlq Model Symbolic
model)
      , (forall (v :: * -> *).
 Ord1 v =>
 Model v -> JobRef v -> Var Int64 v -> Model v)
-> Callback JobRef Int64 Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(forall (v :: * -> *).
 Ord1 v =>
 state v -> input v -> Var output v -> state v)
-> Callback input output state
Update ((forall (v :: * -> *).
  Ord1 v =>
  Model v -> JobRef v -> Var Int64 v -> Model v)
 -> Callback JobRef Int64 Model)
-> (forall (v :: * -> *).
    Ord1 v =>
    Model v -> JobRef v -> Var Int64 v -> Model v)
-> Callback JobRef Int64 Model
forall a b. (a -> b) -> a -> b
$ \Model v
model (JobRef Var Int64 v
ref) Var Int64 v
output ->
          Model v
model
            { mDlq = Map.delete ref (mDlq model)
            , mLive = Map.insert output (Map.findWithDefault Nothing ref (mDlq model)) (mLive model)
            }
      ]

mkFromDLQ :: forall sm. (ArbiterC sm) => Int64 -> sm Int64
mkFromDLQ :: forall (sm :: * -> *). ArbiterC sm => Int64 -> sm Int64
mkFromDLQ Int64
dlqId = do
  restored <- Int64 -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.retryFromDLQ Int64
dlqId :: sm (Maybe (JobRead SMPayload))
  pure (maybe dlqId primaryKey restored)

-- | The id of the DLQ row holding the given original job id.
lookupDlqId :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> Int64 -> IO Int64
lookupDlqId :: Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Int64
-> IO Int64
lookupDlqId Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn Int64
jid = (Connection -> IO Int64) -> IO Int64
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO Int64) -> IO Int64)
-> (Connection -> IO Int64) -> IO Int64
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  rows <- Connection -> Query -> Only Int64 -> IO [Only Int64]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query Connection
conn (Text -> Query
toQuery Text
sql) (Int64 -> Only Int64
forall a. a -> Only a
Only Int64
jid)
  pure $ case rows of
    Only Int64
dlqId : [Only Int64]
_ -> Int64
dlqId
    [Only Int64]
_ -> Int64
jid
  where
    sql :: Text
sql =
      Text
"SELECT id FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueDLQTable Text
schema Text
table
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE job_id = ? ORDER BY id DESC LIMIT 1"

-- ---------------------------------------------------------------------------
-- Batch and dedup commands (statement-level trigger paths)
-- ---------------------------------------------------------------------------

-- | A subset of live jobs, for the multi-row delete commands.
newtype JobRefs (v :: Type -> Type) = JobRefs [Var Int64 v]
  deriving stock (JobRefs v -> JobRefs v -> Bool
(JobRefs v -> JobRefs v -> Bool)
-> (JobRefs v -> JobRefs v -> Bool) -> Eq (JobRefs v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). Eq1 v => JobRefs v -> JobRefs v -> Bool
$c== :: forall (v :: * -> *). Eq1 v => JobRefs v -> JobRefs v -> Bool
== :: JobRefs v -> JobRefs v -> Bool
$c/= :: forall (v :: * -> *). Eq1 v => JobRefs v -> JobRefs v -> Bool
/= :: JobRefs v -> JobRefs v -> Bool
Eq, (forall x. JobRefs v -> Rep (JobRefs v) x)
-> (forall x. Rep (JobRefs v) x -> JobRefs v)
-> Generic (JobRefs v)
forall x. Rep (JobRefs v) x -> JobRefs v
forall x. JobRefs v -> Rep (JobRefs v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (JobRefs v) x -> JobRefs v
forall (v :: * -> *) x. JobRefs v -> Rep (JobRefs v) x
$cfrom :: forall (v :: * -> *) x. JobRefs v -> Rep (JobRefs v) x
from :: forall x. JobRefs v -> Rep (JobRefs v) x
$cto :: forall (v :: * -> *) x. Rep (JobRefs v) x -> JobRefs v
to :: forall x. Rep (JobRefs v) x -> JobRefs v
Generic, Int -> JobRefs v -> String -> String
[JobRefs v] -> String -> String
JobRefs v -> String
(Int -> JobRefs v -> String -> String)
-> (JobRefs v -> String)
-> ([JobRefs v] -> String -> String)
-> Show (JobRefs v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *).
Show1 v =>
Int -> JobRefs v -> String -> String
forall (v :: * -> *). Show1 v => [JobRefs v] -> String -> String
forall (v :: * -> *). Show1 v => JobRefs v -> String
$cshowsPrec :: forall (v :: * -> *).
Show1 v =>
Int -> JobRefs v -> String -> String
showsPrec :: Int -> JobRefs v -> String -> String
$cshow :: forall (v :: * -> *). Show1 v => JobRefs v -> String
show :: JobRefs v -> String
$cshowList :: forall (v :: * -> *). Show1 v => [JobRefs v] -> String -> String
showList :: [JobRefs v] -> String -> String
Show)

instance B.FunctorB JobRefs where
  bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> JobRefs f -> JobRefs g
bmap forall a. f a -> g a
natTrans (JobRefs [Var Int64 f]
refs) = [Var Int64 g] -> JobRefs g
forall (v :: * -> *). [Var Int64 v] -> JobRefs v
JobRefs ((Var Int64 f -> Var Int64 g) -> [Var Int64 f] -> [Var Int64 g]
forall a b. (a -> b) -> [a] -> [b]
map ((forall a. f a -> g a) -> Var Int64 f -> Var Int64 g
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Var Int64 f -> Var Int64 g
B.bmap f a -> g a
forall a. f a -> g a
natTrans) [Var Int64 f]
refs)

instance B.TraversableB JobRefs where
  btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> JobRefs f -> e (JobRefs g)
btraverse forall a. f a -> e (g a)
natTrans (JobRefs [Var Int64 f]
refs) = [Var Int64 g] -> JobRefs g
forall (v :: * -> *). [Var Int64 v] -> JobRefs v
JobRefs ([Var Int64 g] -> JobRefs g) -> e [Var Int64 g] -> e (JobRefs g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Var Int64 f -> e (Var Int64 g))
-> [Var Int64 f] -> e [Var Int64 g]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((forall a. f a -> e (g a)) -> Var Int64 f -> e (Var Int64 g)
forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Var Int64 f -> e (Var Int64 g)
B.btraverse f a -> e (g a)
forall a. f a -> e (g a)
natTrans) [Var Int64 f]
refs

-- | Insert several jobs in one statement. Left untracked. A batch output cannot
-- be split into per-row 'Var's.
newtype BatchInsert (v :: Type -> Type) = BatchInsert [(Maybe Text, Int)]
  deriving stock (BatchInsert v -> BatchInsert v -> Bool
(BatchInsert v -> BatchInsert v -> Bool)
-> (BatchInsert v -> BatchInsert v -> Bool) -> Eq (BatchInsert v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). BatchInsert v -> BatchInsert v -> Bool
$c== :: forall (v :: * -> *). BatchInsert v -> BatchInsert v -> Bool
== :: BatchInsert v -> BatchInsert v -> Bool
$c/= :: forall (v :: * -> *). BatchInsert v -> BatchInsert v -> Bool
/= :: BatchInsert v -> BatchInsert v -> Bool
Eq, (forall x. BatchInsert v -> Rep (BatchInsert v) x)
-> (forall x. Rep (BatchInsert v) x -> BatchInsert v)
-> Generic (BatchInsert v)
forall x. Rep (BatchInsert v) x -> BatchInsert v
forall x. BatchInsert v -> Rep (BatchInsert v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (BatchInsert v) x -> BatchInsert v
forall (v :: * -> *) x. BatchInsert v -> Rep (BatchInsert v) x
$cfrom :: forall (v :: * -> *) x. BatchInsert v -> Rep (BatchInsert v) x
from :: forall x. BatchInsert v -> Rep (BatchInsert v) x
$cto :: forall (v :: * -> *) x. Rep (BatchInsert v) x -> BatchInsert v
to :: forall x. Rep (BatchInsert v) x -> BatchInsert v
Generic, Int -> BatchInsert v -> String -> String
[BatchInsert v] -> String -> String
BatchInsert v -> String
(Int -> BatchInsert v -> String -> String)
-> (BatchInsert v -> String)
-> ([BatchInsert v] -> String -> String)
-> Show (BatchInsert v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *). Int -> BatchInsert v -> String -> String
forall (v :: * -> *). [BatchInsert v] -> String -> String
forall (v :: * -> *). BatchInsert v -> String
$cshowsPrec :: forall (v :: * -> *). Int -> BatchInsert v -> String -> String
showsPrec :: Int -> BatchInsert v -> String -> String
$cshow :: forall (v :: * -> *). BatchInsert v -> String
show :: BatchInsert v -> String
$cshowList :: forall (v :: * -> *). [BatchInsert v] -> String -> String
showList :: [BatchInsert v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> BatchInsert f -> BatchInsert g)
-> FunctorB BatchInsert
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> BatchInsert f -> BatchInsert g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> BatchInsert f -> BatchInsert g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> BatchInsert f -> BatchInsert g
B.FunctorB, FunctorB BatchInsert
FunctorB BatchInsert =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> BatchInsert f -> e (BatchInsert g))
-> TraversableB BatchInsert
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> BatchInsert f -> e (BatchInsert g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> BatchInsert f -> e (BatchInsert g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> BatchInsert f -> e (BatchInsert g)
B.TraversableB)

-- | @InsertTree group childCount@. Insert a suspended rollup finalizer over
-- @childCount@ children sharing the optional group. Left untracked.
data InsertTree (v :: Type -> Type) = InsertTree (Maybe Text) Int
  deriving stock (InsertTree v -> InsertTree v -> Bool
(InsertTree v -> InsertTree v -> Bool)
-> (InsertTree v -> InsertTree v -> Bool) -> Eq (InsertTree v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). InsertTree v -> InsertTree v -> Bool
$c== :: forall (v :: * -> *). InsertTree v -> InsertTree v -> Bool
== :: InsertTree v -> InsertTree v -> Bool
$c/= :: forall (v :: * -> *). InsertTree v -> InsertTree v -> Bool
/= :: InsertTree v -> InsertTree v -> Bool
Eq, (forall x. InsertTree v -> Rep (InsertTree v) x)
-> (forall x. Rep (InsertTree v) x -> InsertTree v)
-> Generic (InsertTree v)
forall x. Rep (InsertTree v) x -> InsertTree v
forall x. InsertTree v -> Rep (InsertTree v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (InsertTree v) x -> InsertTree v
forall (v :: * -> *) x. InsertTree v -> Rep (InsertTree v) x
$cfrom :: forall (v :: * -> *) x. InsertTree v -> Rep (InsertTree v) x
from :: forall x. InsertTree v -> Rep (InsertTree v) x
$cto :: forall (v :: * -> *) x. Rep (InsertTree v) x -> InsertTree v
to :: forall x. Rep (InsertTree v) x -> InsertTree v
Generic, Int -> InsertTree v -> String -> String
[InsertTree v] -> String -> String
InsertTree v -> String
(Int -> InsertTree v -> String -> String)
-> (InsertTree v -> String)
-> ([InsertTree v] -> String -> String)
-> Show (InsertTree v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *). Int -> InsertTree v -> String -> String
forall (v :: * -> *). [InsertTree v] -> String -> String
forall (v :: * -> *). InsertTree v -> String
$cshowsPrec :: forall (v :: * -> *). Int -> InsertTree v -> String -> String
showsPrec :: Int -> InsertTree v -> String -> String
$cshow :: forall (v :: * -> *). InsertTree v -> String
show :: InsertTree v -> String
$cshowList :: forall (v :: * -> *). [InsertTree v] -> String -> String
showList :: [InsertTree v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> InsertTree f -> InsertTree g)
-> FunctorB InsertTree
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> InsertTree f -> InsertTree g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> InsertTree f -> InsertTree g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> InsertTree f -> InsertTree g
B.FunctorB, FunctorB InsertTree
FunctorB InsertTree =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> InsertTree f -> e (InsertTree g))
-> TraversableB InsertTree
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> InsertTree f -> e (InsertTree g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> InsertTree f -> e (InsertTree g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> InsertTree f -> e (InsertTree g)
B.TraversableB)

cBatchInsert
  :: forall gen m sm
   . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cBatchInsert :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cBatchInsert forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (BatchInsert Symbolic)))
-> (BatchInsert Concrete -> m ())
-> [Callback BatchInsert () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command
    ( \Model Symbolic
_ ->
        gen (BatchInsert Symbolic) -> Maybe (gen (BatchInsert Symbolic))
forall a. a -> Maybe a
Just (gen (BatchInsert Symbolic) -> Maybe (gen (BatchInsert Symbolic)))
-> gen (BatchInsert Symbolic) -> Maybe (gen (BatchInsert Symbolic))
forall a b. (a -> b) -> a -> b
$
          [(Maybe Text, Int)] -> BatchInsert Symbolic
forall (v :: * -> *). [(Maybe Text, Int)] -> BatchInsert v
BatchInsert
            ([(Maybe Text, Int)] -> BatchInsert Symbolic)
-> gen [(Maybe Text, Int)] -> gen (BatchInsert Symbolic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> gen (Maybe Text, Int) -> gen [(Maybe Text, Int)]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list
              (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
2 Int
4)
              ((,) (Maybe Text -> Int -> (Maybe Text, Int))
-> gen (Maybe Text) -> gen (Int -> (Maybe Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> gen Text -> gen (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe ([Text] -> gen Text
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element [Text
"g1", Text
"g2", Text
"g3"]) gen (Int -> (Maybe Text, Int)) -> gen Int -> gen (Maybe Text, Int)
forall a b. gen (a -> b) -> gen a -> gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
5))
    )
    ( \(BatchInsert [(Maybe Text, Int)]
specs) -> do
        IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => [(Maybe Text, Int)] -> sm ()
mkBatchInsert @sm [(Maybe Text, Int)]
specs))
        Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariants Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    )
    []

mkBatchInsert
  :: forall sm
   . (ArbiterC sm)
  => [(Maybe Text, Int)]
  -> sm ()
mkBatchInsert :: forall (sm :: * -> *). ArbiterC sm => [(Maybe Text, Int)] -> sm ()
mkBatchInsert [(Maybe Text, Int)]
specs = sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([JobWrite SMPayload] -> sm Int64
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m Int64
HL.insertJobsBatch_ (((Maybe Text, Int) -> JobWrite SMPayload)
-> [(Maybe Text, Int)] -> [JobWrite SMPayload]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Text, Int) -> JobWrite SMPayload
forall {a}. Integral a => (Maybe Text, a) -> JobWrite SMPayload
toJob [(Maybe Text, Int)]
specs))
  where
    toJob :: (Maybe Text, a) -> JobWrite SMPayload
toJob (Maybe Text
group, a
prio) =
      Int32 -> JobWrite SMPayload -> JobWrite SMPayload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority (a -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
prio) (JobWrite SMPayload -> JobWrite SMPayload)
-> JobWrite SMPayload -> JobWrite SMPayload
forall a b. (a -> b) -> a -> b
$ JobWrite SMPayload
-> (Text -> JobWrite SMPayload) -> Maybe Text -> JobWrite SMPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SMPayload -> JobWrite SMPayload
forall payload. payload -> JobWrite payload
defaultJob SMPayload
payload) (Text -> SMPayload -> JobWrite SMPayload
forall payload. Text -> payload -> JobWrite payload
`defaultGroupedJob` SMPayload
payload) Maybe Text
group
    payload :: SMPayload
payload = Text -> SMPayload
smPayload Text
"sm batch"

cInsertTree
  :: forall gen m sm
   . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cInsertTree :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cInsertTree forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (InsertTree Symbolic)))
-> (InsertTree Concrete -> m ())
-> [Callback InsertTree () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command
    (\Model Symbolic
_ -> gen (InsertTree Symbolic) -> Maybe (gen (InsertTree Symbolic))
forall a. a -> Maybe a
Just (Maybe Text -> Int -> InsertTree Symbolic
forall (v :: * -> *). Maybe Text -> Int -> InsertTree v
InsertTree (Maybe Text -> Int -> InsertTree Symbolic)
-> gen (Maybe Text) -> gen (Int -> InsertTree Symbolic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> gen Text -> gen (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe ([Text] -> gen Text
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element [Text
"g1", Text
"g2", Text
"g3"]) gen (Int -> InsertTree Symbolic)
-> gen Int -> gen (InsertTree Symbolic)
forall a b. gen (a -> b) -> gen a -> gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
3)))
    ( \(InsertTree Maybe Text
group Int
childCount) -> do
        IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => Maybe Text -> Int -> sm ()
mkInsertTree @sm Maybe Text
group Int
childCount))
        Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariants Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    )
    []

mkInsertTree
  :: forall sm
   . (ArbiterC sm)
  => Maybe Text
  -> Int
  -> sm ()
mkInsertTree :: forall (sm :: * -> *). ArbiterC sm => Maybe Text -> Int -> sm ()
mkInsertTree Maybe Text
group Int
childCount =
  sm (Either Text (NonEmpty (JobRead SMPayload))) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree @SMPayload (Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
group Text
"sm tree parent" JobWrite SMPayload
-> NonEmpty (JobWrite SMPayload) -> JobTree SMPayload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ Maybe Text -> Text -> Int -> NonEmpty (JobWrite SMPayload)
smChildren Maybe Text
group Text
"sm tree child" Int
childCount))

-- | A labelled job, grouped when the caller names a group.
smJob :: Maybe Text -> Text -> JobWrite SMPayload
smJob :: Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
group Text
lbl = JobWrite SMPayload
-> (Text -> JobWrite SMPayload) -> Maybe Text -> JobWrite SMPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SMPayload -> JobWrite SMPayload
forall payload. payload -> JobWrite payload
defaultJob (Text -> SMPayload
smPayload Text
lbl)) (Text -> SMPayload -> JobWrite SMPayload
forall payload. Text -> payload -> JobWrite payload
`defaultGroupedJob` Text -> SMPayload
smPayload Text
lbl) Maybe Text
group

-- | @childCount@ jobs labelled from the prefix, numbered from zero.
smChildren :: Maybe Text -> Text -> Int -> NonEmpty (JobWrite SMPayload)
smChildren :: Maybe Text -> Text -> Int -> NonEmpty (JobWrite SMPayload)
smChildren Maybe Text
group Text
prefix Int
childCount =
  Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
group (Int -> Text
childLabel Int
0) JobWrite SMPayload
-> [JobWrite SMPayload] -> NonEmpty (JobWrite SMPayload)
forall a. a -> [a] -> NonEmpty a
:| [Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
group (Int -> Text
childLabel Int
index) | Int
index <- [Int
1 .. Int
childCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
  where
    childLabel :: Int -> Text
childLabel Int
index = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)

cBatchCancel
  , cBatchDLQ
    :: forall gen m sm
     . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
    => (forall a. sm a -> IO a)
    -> Text
    -> Text
    -> (forall a. (PG.Connection -> IO a) -> IO a)
    -> Command gen m Model
cBatchCancel :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cBatchCancel forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (JobRefs Symbolic)))
-> (JobRefs Concrete -> m ())
-> [Callback JobRefs () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command Model Symbolic -> Maybe (gen (JobRefs Symbolic))
forall {f :: * -> *} {v :: * -> *}.
MonadGen f =>
Model v -> Maybe (f (JobRefs v))
gen JobRefs Concrete -> m ()
exec [Callback JobRefs () Model]
forall {output}. [Callback JobRefs output Model]
callbacks
  where
    gen :: Model v -> Maybe (f (JobRefs v))
gen Model v
model
      | Map (Var Int64 v) (Maybe Text) -> Bool
forall k a. Map k a -> Bool
Map.null (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model) = Maybe (f (JobRefs v))
forall a. Maybe a
Nothing
      | Bool
otherwise = f (JobRefs v) -> Maybe (f (JobRefs v))
forall a. a -> Maybe a
Just ([Var Int64 v] -> JobRefs v
forall (v :: * -> *). [Var Int64 v] -> JobRefs v
JobRefs ([Var Int64 v] -> JobRefs v) -> f [Var Int64 v] -> f (JobRefs v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var Int64 v] -> f [Var Int64 v]
forall (m :: * -> *) a. MonadGen m => [a] -> m [a]
Gen.subsequence (Map (Var Int64 v) (Maybe Text) -> [Var Int64 v]
forall k a. Map k a -> [k]
Map.keys (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model)))
    exec :: JobRefs Concrete -> m ()
exec (JobRefs [Var Int64 Concrete]
refs) = do
      IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm () -> IO ()
forall a. sm a -> IO a
run (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall payload (m :: * -> *).
QueueOperation m payload =>
[Int64] -> m Int64
HL.cancelJobsBatch @SMPayload ((Var Int64 Concrete -> Int64) -> [Var Int64 Concrete] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Var Int64 Concrete -> Int64
forall a. Var a Concrete -> a
concrete [Var Int64 Concrete]
refs))))
      Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariants Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    callbacks :: [Callback JobRefs output Model]
callbacks =
      [ (Model Symbolic -> JobRefs Symbolic -> Bool)
-> Callback JobRefs output Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(state Symbolic -> input Symbolic -> Bool)
-> Callback input output state
Require ((Model Symbolic -> JobRefs Symbolic -> Bool)
 -> Callback JobRefs output Model)
-> (Model Symbolic -> JobRefs Symbolic -> Bool)
-> Callback JobRefs output Model
forall a b. (a -> b) -> a -> b
$ \Model Symbolic
model (JobRefs [Var Int64 Symbolic]
refs) -> (Var Int64 Symbolic -> Bool) -> [Var Int64 Symbolic] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Var Int64 Symbolic -> Map (Var Int64 Symbolic) (Maybe Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Model Symbolic -> Map (Var Int64 Symbolic) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model Symbolic
model) [Var Int64 Symbolic]
refs
      , (forall (v :: * -> *).
 Ord1 v =>
 Model v -> JobRefs v -> Var output v -> Model v)
-> Callback JobRefs output Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(forall (v :: * -> *).
 Ord1 v =>
 state v -> input v -> Var output v -> state v)
-> Callback input output state
Update ((forall (v :: * -> *).
  Ord1 v =>
  Model v -> JobRefs v -> Var output v -> Model v)
 -> Callback JobRefs output Model)
-> (forall (v :: * -> *).
    Ord1 v =>
    Model v -> JobRefs v -> Var output v -> Model v)
-> Callback JobRefs output Model
forall a b. (a -> b) -> a -> b
$ \Model v
model (JobRefs [Var Int64 v]
refs) Var output v
_ -> Model v
model {mLive = foldl' (flip Map.delete) (mLive model) refs}
      ]
cBatchDLQ :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cBatchDLQ forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (JobRefs Symbolic)))
-> (JobRefs Concrete -> m ())
-> [Callback JobRefs () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command Model Symbolic -> Maybe (gen (JobRefs Symbolic))
forall {f :: * -> *} {v :: * -> *}.
MonadGen f =>
Model v -> Maybe (f (JobRefs v))
gen JobRefs Concrete -> m ()
exec [Callback JobRefs () Model]
forall {output}. [Callback JobRefs output Model]
callbacks
  where
    gen :: Model v -> Maybe (f (JobRefs v))
gen Model v
model
      | Map (Var Int64 v) (Maybe Text) -> Bool
forall k a. Map k a -> Bool
Map.null (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model) = Maybe (f (JobRefs v))
forall a. Maybe a
Nothing
      | Bool
otherwise = f (JobRefs v) -> Maybe (f (JobRefs v))
forall a. a -> Maybe a
Just ([Var Int64 v] -> JobRefs v
forall (v :: * -> *). [Var Int64 v] -> JobRefs v
JobRefs ([Var Int64 v] -> JobRefs v) -> f [Var Int64 v] -> f (JobRefs v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var Int64 v] -> f [Var Int64 v]
forall (m :: * -> *) a. MonadGen m => [a] -> m [a]
Gen.subsequence (Map (Var Int64 v) (Maybe Text) -> [Var Int64 v]
forall k a. Map k a -> [k]
Map.keys (Model v -> Map (Var Int64 v) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model v
model)))
    exec :: JobRefs Concrete -> m ()
exec (JobRefs [Var Int64 Concrete]
refs) = do
      IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => [Int64] -> sm ()
mkBatchDLQ @sm ((Var Int64 Concrete -> Int64) -> [Var Int64 Concrete] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Var Int64 Concrete -> Int64
forall a. Var a Concrete -> a
concrete [Var Int64 Concrete]
refs)))
      Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariants Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    callbacks :: [Callback JobRefs output Model]
callbacks =
      [ (Model Symbolic -> JobRefs Symbolic -> Bool)
-> Callback JobRefs output Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(state Symbolic -> input Symbolic -> Bool)
-> Callback input output state
Require ((Model Symbolic -> JobRefs Symbolic -> Bool)
 -> Callback JobRefs output Model)
-> (Model Symbolic -> JobRefs Symbolic -> Bool)
-> Callback JobRefs output Model
forall a b. (a -> b) -> a -> b
$ \Model Symbolic
model (JobRefs [Var Int64 Symbolic]
refs) -> (Var Int64 Symbolic -> Bool) -> [Var Int64 Symbolic] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Var Int64 Symbolic -> Map (Var Int64 Symbolic) (Maybe Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Model Symbolic -> Map (Var Int64 Symbolic) (Maybe Text)
forall (v :: * -> *). Model v -> Map (Var Int64 v) (Maybe Text)
mLive Model Symbolic
model) [Var Int64 Symbolic]
refs
      , (forall (v :: * -> *).
 Ord1 v =>
 Model v -> JobRefs v -> Var output v -> Model v)
-> Callback JobRefs output Model
forall (input :: (* -> *) -> *) output (state :: (* -> *) -> *).
(forall (v :: * -> *).
 Ord1 v =>
 state v -> input v -> Var output v -> state v)
-> Callback input output state
Update ((forall (v :: * -> *).
  Ord1 v =>
  Model v -> JobRefs v -> Var output v -> Model v)
 -> Callback JobRefs output Model)
-> (forall (v :: * -> *).
    Ord1 v =>
    Model v -> JobRefs v -> Var output v -> Model v)
-> Callback JobRefs output Model
forall a b. (a -> b) -> a -> b
$ \Model v
model (JobRefs [Var Int64 v]
refs) Var output v
_ -> Model v
model {mLive = foldl' (flip Map.delete) (mLive model) refs}
      ]

mkBatchDLQ :: forall sm. (ArbiterC sm) => [Int64] -> sm ()
mkBatchDLQ :: forall (sm :: * -> *). ArbiterC sm => [Int64] -> sm ()
mkBatchDLQ [Int64]
ids = do
  jobs <- [Maybe (JobRead SMPayload)] -> [JobRead SMPayload]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (JobRead SMPayload)] -> [JobRead SMPayload])
-> sm [Maybe (JobRead SMPayload)] -> sm [JobRead SMPayload]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int64 -> sm (Maybe (JobRead SMPayload)))
-> [Int64] -> sm [Maybe (JobRead SMPayload)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (forall (sm :: * -> *).
ArbiterC sm =>
Int64 -> sm (Maybe (JobRead SMPayload))
fetchJob @sm) [Int64]
ids
  void (HL.moveToDLQBatch (map (\JobRead SMPayload
job -> (JobRead SMPayload
job, Text
"sm batch dlq")) jobs))

-- | Insert a job under one of a few shared dedup keys. Repeated keys exercise
-- the @ON CONFLICT@ path. Left untracked.
data Dedup (v :: Type -> Type) = Dedup Text Bool (Maybe Text) Int
  deriving stock (Dedup v -> Dedup v -> Bool
(Dedup v -> Dedup v -> Bool)
-> (Dedup v -> Dedup v -> Bool) -> Eq (Dedup v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). Dedup v -> Dedup v -> Bool
$c== :: forall (v :: * -> *). Dedup v -> Dedup v -> Bool
== :: Dedup v -> Dedup v -> Bool
$c/= :: forall (v :: * -> *). Dedup v -> Dedup v -> Bool
/= :: Dedup v -> Dedup v -> Bool
Eq, (forall x. Dedup v -> Rep (Dedup v) x)
-> (forall x. Rep (Dedup v) x -> Dedup v) -> Generic (Dedup v)
forall x. Rep (Dedup v) x -> Dedup v
forall x. Dedup v -> Rep (Dedup v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (Dedup v) x -> Dedup v
forall (v :: * -> *) x. Dedup v -> Rep (Dedup v) x
$cfrom :: forall (v :: * -> *) x. Dedup v -> Rep (Dedup v) x
from :: forall x. Dedup v -> Rep (Dedup v) x
$cto :: forall (v :: * -> *) x. Rep (Dedup v) x -> Dedup v
to :: forall x. Rep (Dedup v) x -> Dedup v
Generic, Int -> Dedup v -> String -> String
[Dedup v] -> String -> String
Dedup v -> String
(Int -> Dedup v -> String -> String)
-> (Dedup v -> String)
-> ([Dedup v] -> String -> String)
-> Show (Dedup v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *). Int -> Dedup v -> String -> String
forall (v :: * -> *). [Dedup v] -> String -> String
forall (v :: * -> *). Dedup v -> String
$cshowsPrec :: forall (v :: * -> *). Int -> Dedup v -> String -> String
showsPrec :: Int -> Dedup v -> String -> String
$cshow :: forall (v :: * -> *). Dedup v -> String
show :: Dedup v -> String
$cshowList :: forall (v :: * -> *). [Dedup v] -> String -> String
showList :: [Dedup v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> Dedup f -> Dedup g)
-> FunctorB Dedup
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Dedup f -> Dedup g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Dedup f -> Dedup g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Dedup f -> Dedup g
B.FunctorB, FunctorB Dedup
FunctorB Dedup =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> Dedup f -> e (Dedup g))
-> TraversableB Dedup
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Dedup f -> e (Dedup g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Dedup f -> e (Dedup g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Dedup f -> e (Dedup g)
B.TraversableB)

cDedup
  :: forall gen m sm
   . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cDedup :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cDedup forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (Dedup Symbolic)))
-> (Dedup Concrete -> m ())
-> [Callback Dedup () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command
    ( \Model Symbolic
_ ->
        gen (Dedup Symbolic) -> Maybe (gen (Dedup Symbolic))
forall a. a -> Maybe a
Just (gen (Dedup Symbolic) -> Maybe (gen (Dedup Symbolic)))
-> gen (Dedup Symbolic) -> Maybe (gen (Dedup Symbolic))
forall a b. (a -> b) -> a -> b
$
          Text -> Bool -> Maybe Text -> Int -> Dedup Symbolic
forall (v :: * -> *). Text -> Bool -> Maybe Text -> Int -> Dedup v
Dedup
            (Text -> Bool -> Maybe Text -> Int -> Dedup Symbolic)
-> gen Text -> gen (Bool -> Maybe Text -> Int -> Dedup Symbolic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> gen Text
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element [Text
"d1", Text
"d2", Text
"d3"]
            gen (Bool -> Maybe Text -> Int -> Dedup Symbolic)
-> gen Bool -> gen (Maybe Text -> Int -> Dedup Symbolic)
forall a b. gen (a -> b) -> gen a -> gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> gen Bool
forall (m :: * -> *). MonadGen m => m Bool
Gen.bool
            gen (Maybe Text -> Int -> Dedup Symbolic)
-> gen (Maybe Text) -> gen (Int -> Dedup Symbolic)
forall a b. gen (a -> b) -> gen a -> gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> gen Text -> gen (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe ([Text] -> gen Text
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element [Text
"g1", Text
"g2", Text
"g3"])
            gen (Int -> Dedup Symbolic) -> gen Int -> gen (Dedup Symbolic)
forall a b. gen (a -> b) -> gen a -> gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> gen Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
5)
    )
    ( \(Dedup Text
key Bool
replace Maybe Text
group Int
prio) -> do
        IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
Text -> Bool -> Maybe Text -> Int -> sm ()
mkDedup @sm Text
key Bool
replace Maybe Text
group Int
prio))
        Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariants Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    )
    []

mkDedup
  :: forall sm
   . (ArbiterC sm)
  => Text
  -> Bool
  -> Maybe Text
  -> Int
  -> sm ()
mkDedup :: forall (sm :: * -> *).
ArbiterC sm =>
Text -> Bool -> Maybe Text -> Int -> sm ()
mkDedup Text
key Bool
replace Maybe Text
group Int
prio = sm (Maybe (JobRead SMPayload)) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobWrite SMPayload -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite SMPayload
job)
  where
    dedupKey :: DedupKey
dedupKey = if Bool
replace then Text -> DedupKey
ReplaceDuplicate Text
key else Text -> DedupKey
IgnoreDuplicate Text
key
    job :: JobWrite SMPayload
job =
      Int32 -> JobWrite SMPayload -> JobWrite SMPayload
forall payload. Int32 -> JobWrite payload -> JobWrite payload
setPriority (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prio)
        (JobWrite SMPayload -> JobWrite SMPayload)
-> JobWrite SMPayload -> JobWrite SMPayload
forall a b. (a -> b) -> a -> b
$ Maybe DedupKey -> JobWrite SMPayload -> JobWrite SMPayload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just DedupKey
dedupKey)
        (JobWrite SMPayload -> JobWrite SMPayload)
-> JobWrite SMPayload -> JobWrite SMPayload
forall a b. (a -> b) -> a -> b
$ JobWrite SMPayload
-> (Text -> JobWrite SMPayload) -> Maybe Text -> JobWrite SMPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SMPayload -> JobWrite SMPayload
forall payload. payload -> JobWrite payload
defaultJob SMPayload
payload) (Text -> SMPayload -> JobWrite SMPayload
forall payload. Text -> payload -> JobWrite payload
`defaultGroupedJob` SMPayload
payload) Maybe Text
group
    payload :: SMPayload
payload = Text -> SMPayload
smPayload Text
"sm dedup"

-- | Run the reaper.
data Refresh (v :: Type -> Type) = Refresh
  deriving stock (Refresh v -> Refresh v -> Bool
(Refresh v -> Refresh v -> Bool)
-> (Refresh v -> Refresh v -> Bool) -> Eq (Refresh v)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: * -> *). Refresh v -> Refresh v -> Bool
$c== :: forall (v :: * -> *). Refresh v -> Refresh v -> Bool
== :: Refresh v -> Refresh v -> Bool
$c/= :: forall (v :: * -> *). Refresh v -> Refresh v -> Bool
/= :: Refresh v -> Refresh v -> Bool
Eq, (forall x. Refresh v -> Rep (Refresh v) x)
-> (forall x. Rep (Refresh v) x -> Refresh v)
-> Generic (Refresh v)
forall x. Rep (Refresh v) x -> Refresh v
forall x. Refresh v -> Rep (Refresh v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: * -> *) x. Rep (Refresh v) x -> Refresh v
forall (v :: * -> *) x. Refresh v -> Rep (Refresh v) x
$cfrom :: forall (v :: * -> *) x. Refresh v -> Rep (Refresh v) x
from :: forall x. Refresh v -> Rep (Refresh v) x
$cto :: forall (v :: * -> *) x. Rep (Refresh v) x -> Refresh v
to :: forall x. Rep (Refresh v) x -> Refresh v
Generic, Int -> Refresh v -> String -> String
[Refresh v] -> String -> String
Refresh v -> String
(Int -> Refresh v -> String -> String)
-> (Refresh v -> String)
-> ([Refresh v] -> String -> String)
-> Show (Refresh v)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (v :: * -> *). Int -> Refresh v -> String -> String
forall (v :: * -> *). [Refresh v] -> String -> String
forall (v :: * -> *). Refresh v -> String
$cshowsPrec :: forall (v :: * -> *). Int -> Refresh v -> String -> String
showsPrec :: Int -> Refresh v -> String -> String
$cshow :: forall (v :: * -> *). Refresh v -> String
show :: Refresh v -> String
$cshowList :: forall (v :: * -> *). [Refresh v] -> String -> String
showList :: [Refresh v] -> String -> String
Show)
  deriving anyclass ((forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> Refresh f -> Refresh g)
-> FunctorB Refresh
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Refresh f -> Refresh g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Refresh f -> Refresh g
bmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> Refresh f -> Refresh g
B.FunctorB, FunctorB Refresh
FunctorB Refresh =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> Refresh f -> e (Refresh g))
-> TraversableB Refresh
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Refresh f -> e (Refresh g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Refresh f -> e (Refresh g)
btraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> Refresh f -> e (Refresh g)
B.TraversableB)

-- | A reaper tick. Drift-correct the groups summary, sweep exhausted jobs to the
-- DLQ and sweep lapsed force-cancelled jobs.
runReaper
  :: forall sm
   . (MonadArbiter sm, RegistryTables (RegistryOf sm))
  => Text
  -> Text
  -> sm ()
runReaper :: forall (sm :: * -> *).
(MonadArbiter sm, RegistryTables (RegistryOf sm)) =>
Text -> Text -> sm ()
runReaper Text
schema Text
table = do
  sm (Int64, [Text]) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *).
(MonadArbiter m, RegistryTables (RegistryOf m)) =>
m (Int64, [Text])
HL.refreshAllGroupsFully @sm)
  sm (Int64, [Text]) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> [Text] -> sm (Int64, [Text])
forall (m :: * -> *).
MonadArbiter m =>
Text -> [Text] -> m (Int64, [Text])
Ops.sweepExhaustedJobs Text
schema [Text
table])
  sm (Int64, [Text]) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> [Text] -> sm (Int64, [Text])
forall (m :: * -> *).
MonadArbiter m =>
Text -> [Text] -> m (Int64, [Text])
Ops.sweepCancelledJobs Text
schema [Text
table])

cRefresh
  :: forall gen m sm
   . (ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Command gen m Model
cRefresh :: forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cRefresh forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  (Model Symbolic -> Maybe (gen (Refresh Symbolic)))
-> (Refresh Concrete -> m ())
-> [Callback Refresh () Model]
-> Command gen m Model
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *)
       (input :: (* -> *) -> *) output.
(TraversableB input, Show (input Symbolic), Show output,
 Typeable output) =>
(state Symbolic -> Maybe (gen (input Symbolic)))
-> (input Concrete -> m output)
-> [Callback input output state]
-> Command gen m state
Command
    (\Model Symbolic
_ -> gen (Refresh Symbolic) -> Maybe (gen (Refresh Symbolic))
forall a. a -> Maybe a
Just (Refresh Symbolic -> gen (Refresh Symbolic)
forall a. a -> gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Refresh Symbolic
forall (v :: * -> *). Refresh v
Refresh))
    ( \Refresh Concrete
Refresh -> do
        IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
evalIO (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *).
(MonadArbiter sm, RegistryTables (RegistryOf sm)) =>
Text -> Text -> sm ()
runReaper @sm Text
schema Text
table))
        Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadTest m) =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> m ()
checkInvariants Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    )
    []

-- ---------------------------------------------------------------------------
-- Concurrency property
-- ---------------------------------------------------------------------------

-- | Groups and dedup keys for the concurrency churn. Fewer groups than workers
-- keeps contention per group high.
concGroups, concDedupKeys :: [Text]
concGroups :: [Text]
concGroups = [Text
"g" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index) | Int
index <- [Int
1 .. Int
3 :: Int]]
concDedupKeys :: [Text]
concDedupKeys = [Text
"d" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index) | Int
index <- [Int
1 .. Int
6 :: Int]]

-- | One self-contained engine action with its parameters baked in. Showable
-- and shrinkable. Every target-based op claims first and acts on what it
-- claimed.
data Act
  = AInsert (Maybe Text) (Maybe Int) Int (Maybe Int) Extras
  | ABatchInsert [(Maybe Text, Int)]
  | AInsertTree (Maybe Text) Int
  | ADedup Text Bool (Maybe Text) Int
  | AClaimAck
  | AClaimRetry
  | AClaimCancel
  | AClaimForceCancel
  | AClaimExtend
  | AClaimRelease
  | AClaimToDLQ
  | AClaimSpawn (Maybe Text) Int
  | ARetryRandomDLQ
  | ASuspendRandom
  | AResumeRandom
  | APromoteRandom
  | ACancelCascade
  | APauseChildren
  | AResumeChildren
  | ADeleteDLQ
  | ADeleteDLQBatch
  | AReaper
  deriving stock (Act -> Act -> Bool
(Act -> Act -> Bool) -> (Act -> Act -> Bool) -> Eq Act
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Act -> Act -> Bool
== :: Act -> Act -> Bool
$c/= :: Act -> Act -> Bool
/= :: Act -> Act -> Bool
Eq, Int -> Act -> String -> String
[Act] -> String -> String
Act -> String
(Int -> Act -> String -> String)
-> (Act -> String) -> ([Act] -> String -> String) -> Show Act
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Act -> String -> String
showsPrec :: Int -> Act -> String -> String
$cshow :: Act -> String
show :: Act -> String
$cshowList :: [Act] -> String -> String
showList :: [Act] -> String -> String
Show)

genActionData :: Gen Act
genActionData :: Gen Act
genActionData =
  [(Int, Gen Act)] -> Gen Act
forall (m :: * -> *) a.
(HasCallStack, MonadGen m) =>
[(Int, m a)] -> m a
Gen.frequency
    [ (Int
3, Maybe Text -> Maybe Int -> Int -> Maybe Int -> Extras -> Act
AInsert (Maybe Text -> Maybe Int -> Int -> Maybe Int -> Extras -> Act)
-> GenT Identity (Maybe Text)
-> GenT Identity (Maybe Int -> Int -> Maybe Int -> Extras -> Act)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity (Maybe Text)
genGroup GenT Identity (Maybe Int -> Int -> Maybe Int -> Extras -> Act)
-> GenT Identity (Maybe Int)
-> GenT Identity (Int -> Maybe Int -> Extras -> Act)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity (Maybe Int)
genDelay GenT Identity (Int -> Maybe Int -> Extras -> Act)
-> GenT Identity Int -> GenT Identity (Maybe Int -> Extras -> Act)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Int
genPrio GenT Identity (Maybe Int -> Extras -> Act)
-> GenT Identity (Maybe Int) -> GenT Identity (Extras -> Act)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity (Maybe Int)
genMaxAtts GenT Identity (Extras -> Act) -> GenT Identity Extras -> Gen Act
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Extras
forall (g :: * -> *). MonadGen g => g Extras
genExtras)
    , (Int
1, [(Maybe Text, Int)] -> Act
ABatchInsert ([(Maybe Text, Int)] -> Act)
-> GenT Identity [(Maybe Text, Int)] -> Gen Act
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int
-> GenT Identity (Maybe Text, Int)
-> GenT Identity [(Maybe Text, Int)]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
2 Int
4) ((,) (Maybe Text -> Int -> (Maybe Text, Int))
-> GenT Identity (Maybe Text)
-> GenT Identity (Int -> (Maybe Text, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity (Maybe Text)
genGroup GenT Identity (Int -> (Maybe Text, Int))
-> GenT Identity Int -> GenT Identity (Maybe Text, Int)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Int
genPrio))
    , (Int
1, Maybe Text -> Int -> Act
AInsertTree (Maybe Text -> Int -> Act)
-> GenT Identity (Maybe Text) -> GenT Identity (Int -> Act)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity (Maybe Text)
genGroup GenT Identity (Int -> Act) -> GenT Identity Int -> Gen Act
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
3))
    , (Int
2, Text -> Bool -> Maybe Text -> Int -> Act
ADedup (Text -> Bool -> Maybe Text -> Int -> Act)
-> GenT Identity Text
-> GenT Identity (Bool -> Maybe Text -> Int -> Act)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> GenT Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element [Text]
concDedupKeys GenT Identity (Bool -> Maybe Text -> Int -> Act)
-> GenT Identity Bool -> GenT Identity (Maybe Text -> Int -> Act)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Bool
forall (m :: * -> *). MonadGen m => m Bool
Gen.bool GenT Identity (Maybe Text -> Int -> Act)
-> GenT Identity (Maybe Text) -> GenT Identity (Int -> Act)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity (Maybe Text)
genGroup GenT Identity (Int -> Act) -> GenT Identity Int -> Gen Act
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Int
genPrio)
    , (Int
3, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AClaimAck)
    , (Int
2, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AClaimRetry)
    , (Int
2, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AClaimCancel)
    , (Int
2, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AClaimForceCancel)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AClaimExtend)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AClaimRelease)
    , (Int
2, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AClaimToDLQ)
    , (Int
2, Maybe Text -> Int -> Act
AClaimSpawn (Maybe Text -> Int -> Act)
-> GenT Identity (Maybe Text) -> GenT Identity (Int -> Act)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity (Maybe Text)
genGroup GenT Identity (Int -> Act) -> GenT Identity Int -> Gen Act
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
2))
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
ARetryRandomDLQ)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
ASuspendRandom)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AResumeRandom)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
APromoteRandom)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
ACancelCascade)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
APauseChildren)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AResumeChildren)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
ADeleteDLQ)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
ADeleteDLQBatch)
    , (Int
1, Act -> Gen Act
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Act
AReaper)
    ]
  where
    genGroup :: GenT Identity (Maybe Text)
genGroup = GenT Identity Text -> GenT Identity (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe ([Text] -> GenT Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadGen m) =>
f a -> m a
Gen.element [Text]
concGroups)
    genDelay :: GenT Identity (Maybe Int)
genDelay = GenT Identity Int -> GenT Identity (Maybe Int)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
30 Int
120))
    genPrio :: GenT Identity Int
genPrio = Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
5)
    genMaxAtts :: GenT Identity (Maybe Int)
genMaxAtts = GenT Identity Int -> GenT Identity (Maybe Int)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
3))

-- | Interpret an 'Act' into a backend operation.
interpret
  :: forall sm
   . (ArbiterC sm)
  => Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Act
  -> sm ()
interpret :: forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> Act -> sm ()
interpret Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn Act
act = case Act
act of
  AInsert Maybe Text
group Maybe Int
delay Int
prio Maybe Int
maxAtts Extras
extras -> sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm (Extras -> JobWrite SMPayload -> JobWrite SMPayload
applyExtras Extras
extras) Maybe Text
group Maybe Int
delay Int
prio Maybe Int
maxAtts)
  ABatchInsert [(Maybe Text, Int)]
specs -> forall (sm :: * -> *). ArbiterC sm => [(Maybe Text, Int)] -> sm ()
mkBatchInsert @sm [(Maybe Text, Int)]
specs
  AInsertTree Maybe Text
group Int
childCount -> forall (sm :: * -> *). ArbiterC sm => Maybe Text -> Int -> sm ()
mkInsertTree @sm Maybe Text
group Int
childCount
  ADedup Text
key Bool
replace Maybe Text
group Int
prio -> forall (sm :: * -> *).
ArbiterC sm =>
Text -> Bool -> Maybe Text -> Int -> sm ()
mkDedup @sm Text
key Bool
replace Maybe Text
group Int
prio
  Act
AClaimAck -> forall (sm :: * -> *). ArbiterC sm => sm ()
claimAck @sm
  Act
AClaimRetry -> forall (sm :: * -> *). ArbiterC sm => sm ()
claimRetry @sm
  Act
AClaimCancel -> forall (sm :: * -> *). ArbiterC sm => sm ()
claimCancel @sm
  Act
AClaimForceCancel -> forall (sm :: * -> *). ArbiterC sm => sm ()
claimForceCancel @sm
  Act
AClaimExtend -> forall (sm :: * -> *). ArbiterC sm => sm ()
claimExtend @sm
  Act
AClaimRelease -> forall (sm :: * -> *). ArbiterC sm => sm ()
claimRelease @sm
  Act
AClaimToDLQ -> forall (sm :: * -> *). ArbiterC sm => sm ()
claimToDLQ @sm
  AClaimSpawn Maybe Text
group Int
childCount -> forall (sm :: * -> *). ArbiterC sm => Maybe Text -> Int -> sm ()
claimSpawn @sm Maybe Text
group Int
childCount
  Act
ARetryRandomDLQ -> forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
retryRandomDLQ @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  Act
ASuspendRandom -> forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
suspendRandom @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  Act
AResumeRandom -> forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
resumeRandom @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  Act
APromoteRandom -> forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
promoteRandom @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  Act
ACancelCascade ->
    forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> (Int64 -> sm ())
-> sm ()
onRandomRollupParent @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.cancelJobCascade @SMPayload)
  Act
APauseChildren -> forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> (Int64 -> sm ())
-> sm ()
onRandomRollupParent @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.pauseChildren @SMPayload)
  Act
AResumeChildren -> forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> (Int64 -> sm ())
-> sm ()
onRandomRollupParent @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.resumeChildren @SMPayload)
  Act
ADeleteDLQ -> forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
deleteRandomDLQ @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  Act
ADeleteDLQBatch -> forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
deleteRandomDLQBatch @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  Act
AReaper -> forall (sm :: * -> *).
(MonadArbiter sm, RegistryTables (RegistryOf sm)) =>
Text -> Text -> sm ()
runReaper @sm Text
schema Text
table

-- | The opaque-action form, for samplers that do not shrink.
genAction
  :: forall sm
   . (ArbiterC sm)
  => Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> Gen (sm ())
genAction :: forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> Gen (sm ())
genAction Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn =
  forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> Act -> sm ()
interpret @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (Act -> sm ()) -> Gen Act -> GenT Identity (sm ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Act
genActionData

claimThenWith :: forall sm a. (ArbiterC sm) => (JobRead SMPayload -> sm a) -> sm [a]
claimThenWith :: forall (sm :: * -> *) a.
ArbiterC sm =>
(JobRead SMPayload -> sm a) -> sm [a]
claimThenWith JobRead SMPayload -> sm a
handle = do
  jobs <- Int -> NominalDiffTime -> UUID -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> UUID -> m [JobRead payload]
HL.claimNextVisibleJobsAs Int
3 NominalDiffTime
30 UUID
smWorker :: sm [JobRead SMPayload]
  traverse handle jobs

claimThen :: forall sm. (ArbiterC sm) => (JobRead SMPayload -> sm ()) -> sm ()
claimThen :: forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ()) -> sm ()
claimThen = sm [()] -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm [()] -> sm ())
-> ((JobRead SMPayload -> sm ()) -> sm [()])
-> (JobRead SMPayload -> sm ())
-> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sm :: * -> *) a.
ArbiterC sm =>
(JobRead SMPayload -> sm a) -> sm [a]
claimThenWith @sm

claimAck
  , claimRetry
  , claimCancel
  , claimForceCancel
  , claimExtend
  , claimRelease
  , claimToDLQ
    :: forall sm. (ArbiterC sm) => sm ()
claimAck :: forall (sm :: * -> *). ArbiterC sm => sm ()
claimAck = forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ()) -> sm ()
claimThen @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob)
claimRetry :: forall (sm :: * -> *). ArbiterC sm => sm ()
claimRetry = forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ()) -> sm ()
claimThen @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Text -> JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
NominalDiffTime -> Text -> JobRead payload -> m Int64
HL.updateJobForRetry NominalDiffTime
30 Text
"conc retry")
claimCancel :: forall (sm :: * -> *). ArbiterC sm => sm ()
claimCancel = forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ()) -> sm ()
claimThen @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.cancelJob @SMPayload (Int64 -> sm Int64)
-> (JobRead SMPayload -> Int64) -> JobRead SMPayload -> sm Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey)
-- Force-cancel while still leased flags the job in place. It stays present and keeps blocking its group head.
claimForceCancel :: forall (sm :: * -> *). ArbiterC sm => sm ()
claimForceCancel = forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ()) -> sm ()
claimThen @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.forceCancelJob @SMPayload (Int64 -> sm Int64)
-> (JobRead SMPayload -> Int64) -> JobRead SMPayload -> sm Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey)
claimExtend :: forall (sm :: * -> *). ArbiterC sm => sm ()
claimExtend = forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ()) -> sm ()
claimThen @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
NominalDiffTime -> JobRead payload -> m Int64
HL.setVisibilityTimeout NominalDiffTime
60)
claimRelease :: forall (sm :: * -> *). ArbiterC sm => sm ()
claimRelease = forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ()) -> sm ()
claimThen @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
NominalDiffTime -> JobRead payload -> m Int64
HL.setVisibilityTimeout NominalDiffTime
0)
claimToDLQ :: forall (sm :: * -> *). ArbiterC sm => sm ()
claimToDLQ = forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ()) -> sm ()
claimThen @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
Text -> JobRead payload -> m Int64
HL.moveToDLQ Text
"conc dlq")

-- | Attach children to a claimed job and settle it suspended, as a spawn callback does.
claimSpawn :: forall sm. (ArbiterC sm) => Maybe Text -> Int -> sm ()
claimSpawn :: forall (sm :: * -> *). ArbiterC sm => Maybe Text -> Int -> sm ()
claimSpawn Maybe Text
group Int
childCount = sm Int -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (sm :: * -> *). ArbiterC sm => Maybe Text -> Int -> sm Int
claimSpawnCount @sm Maybe Text
group Int
childCount)

-- | 'claimSpawn', counting the spawns that committed.
claimSpawnCount :: forall sm. (ArbiterC sm) => Maybe Text -> Int -> sm Int
claimSpawnCount :: forall (sm :: * -> *). ArbiterC sm => Maybe Text -> Int -> sm Int
claimSpawnCount Maybe Text
group Int
childCount = [Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Bool] -> Int) -> ([Bool] -> [Bool]) -> [Bool] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
filter Bool -> Bool
forall a. a -> a
id ([Bool] -> Int) -> sm [Bool] -> sm Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sm :: * -> *) a.
ArbiterC sm =>
(JobRead SMPayload -> sm a) -> sm [a]
claimThenWith @sm JobRead SMPayload -> sm Bool
spawnOne
  where
    children :: NonEmpty (JobWrite SMPayload)
children = Maybe Text -> Text -> Int -> NonEmpty (JobWrite SMPayload)
smChildren Maybe Text
group Text
"sm spawn child" Int
childCount
    spawnOne :: JobRead SMPayload -> sm Bool
spawnOne JobRead SMPayload
job =
      sm () -> sm (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny
        ( sm () -> sm ()
forall a. sm a -> sm a
forall (m :: * -> *) a. MonadArbiter m => m a -> m a
withDbTransaction (sm () -> sm ()) -> sm () -> sm ()
forall a b. (a -> b) -> a -> b
$ do
            sm (NonEmpty (JobRead SMPayload)) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobRead SMPayload
-> NonEmpty (JobWrite SMPayload)
-> sm (NonEmpty (JobRead SMPayload))
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload
-> NonEmpty (JobWrite payload) -> m (NonEmpty (JobRead payload))
HL.spawnChildren JobRead SMPayload
job NonEmpty (JobWrite SMPayload)
children)
            sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob JobRead SMPayload
job)
        )
        sm (Either SomeException ())
-> (Either SomeException () -> sm Bool) -> sm Bool
forall a b. sm a -> (a -> sm b) -> sm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> sm Bool)
-> (() -> sm Bool) -> Either SomeException () -> sm Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\SomeException
err -> Bool
False Bool -> sm () -> sm Bool
forall a b. a -> sm b -> sm a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SomeException -> sm ()
forall (m :: * -> *). MonadIO m => SomeException -> m ()
rethrowAbort SomeException
err) (sm Bool -> () -> sm Bool
forall a b. a -> b -> a
const (Bool -> sm Bool
forall a. a -> sm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True))

-- | Let a deadlock or serialization abort through, swallowing the rest.
rethrowAbort :: (MonadIO m) => SomeException -> m ()
rethrowAbort :: forall (m :: * -> *). MonadIO m => SomeException -> m ()
rethrowAbort SomeException
err = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SomeException -> Bool
isRetryableError SomeException
err Bool -> Bool -> Bool
|| SomeException -> Bool
isDeadlock SomeException
err) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
err))

-- | Run one round of a deadlock guard, counting the deadlocks.
countingDeadlocks :: IORef Int -> IO () -> IO ()
countingDeadlocks :: IORef Int -> IO () -> IO ()
countingDeadlocks IORef Int
deadlocks IO ()
act = do
  outcome <- IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny IO ()
act
  case outcome of
    Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Left SomeException
err
      | SomeException -> Bool
isDeadlock SomeException
err -> IORef Int -> IO ()
forall a. Num a => IORef a -> IO ()
bumpRef IORef Int
deadlocks
      | String
"40001" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` SomeException -> String
forall a. Show a => a -> String
show SomeException
err -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise -> SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
err

-- | Retry one arbitrary DLQ row back into the main queue, if any exists.
retryRandomDLQ
  :: forall sm
   . (ArbiterC sm)
  => Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> sm ()
retryRandomDLQ :: forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
retryRandomDLQ Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = do
  mId <- IO (Maybe Int64) -> sm (Maybe Int64)
forall a. IO a -> sm a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((forall a. (Connection -> IO a) -> IO a)
-> Text -> IO (Maybe Int64)
firstId (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Text
sql)
  traverse_ (\Int64
dlqId -> sm (Maybe (JobRead SMPayload)) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int64 -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.retryFromDLQ Int64
dlqId :: sm (Maybe (JobRead SMPayload)))) mId
  where
    sql :: Text
sql =
      Text
"SELECT id FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueDLQTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ORDER BY random() LIMIT 1"

-- | Apply an id-keyed admin op to a random live job, if any.
onRandomJob
  :: forall sm
   . (ArbiterC sm)
  => Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> (Int64 -> sm ())
  -> sm ()
onRandomJob :: forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> (Int64 -> sm ())
-> sm ()
onRandomJob Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn Int64 -> sm ()
act = do
  mId <- IO (Maybe Int64) -> sm (Maybe Int64)
forall a. IO a -> sm a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((forall a. (Connection -> IO a) -> IO a)
-> Text -> IO (Maybe Int64)
firstId (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Text
sql)
  traverse_ act mId
  where
    sql :: Text
sql = Text
"SELECT id FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ORDER BY random() LIMIT 1"

suspendRandom
  , resumeRandom
  , promoteRandom
    :: forall sm
     . (ArbiterC sm)
    => Text
    -> Text
    -> (forall a. (PG.Connection -> IO a) -> IO a)
    -> sm ()
suspendRandom :: forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
suspendRandom Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> (Int64 -> sm ())
-> sm ()
onRandomJob @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.suspendJob @SMPayload)
resumeRandom :: forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
resumeRandom Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> (Int64 -> sm ())
-> sm ()
onRandomJob @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.resumeJob @SMPayload)
promoteRandom :: forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
promoteRandom Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> (Int64 -> sm ())
-> sm ()
onRandomJob @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.promoteJob @SMPayload)

-- | Apply an id-keyed op to a random rollup-finalizer parent, if any. A parent
-- is a row with a @parent_state@ snapshot.
onRandomRollupParent
  :: forall sm
   . (ArbiterC sm)
  => Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> (Int64 -> sm ())
  -> sm ()
onRandomRollupParent :: forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> (Int64 -> sm ())
-> sm ()
onRandomRollupParent Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn Int64 -> sm ()
act = do
  mId <- IO (Maybe Int64) -> sm (Maybe Int64)
forall a. IO a -> sm a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((forall a. (Connection -> IO a) -> IO a)
-> Text -> IO (Maybe Int64)
firstId (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Text
sql)
  traverse_ act mId
  where
    sql :: Text
sql =
      Text
"SELECT id FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE parent_state IS NOT NULL ORDER BY random() LIMIT 1"

-- | Delete a random DLQ row.
deleteRandomDLQ
  :: forall sm
   . (ArbiterC sm)
  => Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> sm ()
deleteRandomDLQ :: forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
deleteRandomDLQ Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = do
  mId <- IO (Maybe Int64) -> sm (Maybe Int64)
forall a. IO a -> sm a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((forall a. (Connection -> IO a) -> IO a)
-> Text -> IO (Maybe Int64)
firstId (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Text
sql)
  traverse_ (void . HL.deleteDLQJob @SMPayload) mId
  where
    sql :: Text
sql = Text
"SELECT id FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueDLQTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ORDER BY random() LIMIT 1"

-- | Delete a small random batch of DLQ rows in one statement.
deleteRandomDLQBatch
  :: forall sm
   . (ArbiterC sm)
  => Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> sm ()
deleteRandomDLQBatch :: forall (sm :: * -> *).
ArbiterC sm =>
Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> sm ()
deleteRandomDLQBatch Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn = do
  ids <- IO [Int64] -> sm [Int64]
forall a. IO a -> sm a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Int64] -> sm [Int64]) -> IO [Int64] -> sm [Int64]
forall a b. (a -> b) -> a -> b
$ (Connection -> IO [Int64]) -> IO [Int64]
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO [Int64]) -> IO [Int64])
-> (Connection -> IO [Int64]) -> IO [Int64]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    rows <-
      Connection -> Query -> IO [Only Int64]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (Text -> Query
toQuery (Text
"SELECT id FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueDLQTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ORDER BY random() LIMIT 3"))
    pure [dlqId | Only dlqId <- rows]
  void (HL.deleteDLQJobsBatch @SMPayload ids)

-- | Run an action, retrying transient serialization aborts.
withRetry :: IO () -> IO ()
withRetry :: IO () -> IO ()
withRetry IO ()
act = Int -> IO ()
go (Int
5 :: Int)
  where
    go :: Int -> IO ()
go Int
remaining = do
      outcome <- IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny IO ()
act
      case outcome of
        Right () -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Left SomeException
err
          | Int
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& SomeException -> Bool
isRetryableError SomeException
err -> Int -> IO ()
go (Int
remaining Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          | Bool
otherwise -> SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
err

-- | Detect a transient serialization abort by the SQLSTATE in the rendered message.
-- A deadlock is a lock-order defect, so it fails the test.
isRetryableError :: SomeException -> Bool
isRetryableError :: SomeException -> Bool
isRetryableError SomeException
err = String
"40001" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` SomeException -> String
forall a. Show a => a -> String
show SomeException
err

-- | Detect a deadlock abort by the SQLSTATE in the rendered message.
isDeadlock :: SomeException -> Bool
isDeadlock :: SomeException -> Bool
isDeadlock SomeException
err = String
"40P01" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` SomeException -> String
forall a. Show a => a -> String
show SomeException
err

-- | Install the gap-free HOL violation detector on a raw connection.
installHolDetector :: PG.Connection -> Text -> Text -> IO ()
installHolDetector :: Connection -> Text -> Text -> IO ()
installHolDetector Connection
conn Text
schema Text
table =
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Connection -> Text -> IO ()
execute_ Connection
conn) (Text -> Text -> [Text]
holInstallSql Text
schema Text
table)

-- | One message per violation the HOL detector trigger recorded.
holViolations :: PG.Connection -> Text -> Text -> IO [String]
holViolations :: Connection -> Text -> Text -> IO [String]
holViolations Connection
conn Text
schema Text
table = do
  rows <- Connection -> Query -> IO [(Text, Int64)]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (Text -> Query
toQuery (Text
"SELECT group_key, job_id FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holViolTbl Text
schema Text
table))
  pure
    [ "HOL violation: job " <> show (jid :: Int64) <> " claimed while group " <> T.unpack groupName <> " already in-flight"
    | (groupName, jid) <- rows
    ]

-- | Remove the HOL detector trigger, function, and violations table.
removeHolDetector :: PG.Connection -> Text -> Text -> IO ()
removeHolDetector :: Connection -> Text -> Text -> IO ()
removeHolDetector Connection
conn Text
schema Text
table =
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Connection -> Text -> IO ()
execute_ Connection
conn) (Text -> Text -> [Text]
holRemoveSql Text
schema Text
table)

-- ---------------------------------------------------------------------------
-- Property + hspec wiring
-- ---------------------------------------------------------------------------

prop_engine
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> Property
prop_engine :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> Property
prop_engine forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = TestLimit -> Property -> Property
withTests TestLimit
300 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  actions <-
    Gen (Sequential (PropertyT IO) Model)
-> PropertyT IO (Sequential (PropertyT IO) Model)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen (Sequential (PropertyT IO) Model)
 -> PropertyT IO (Sequential (PropertyT IO) Model))
-> Gen (Sequential (PropertyT IO) Model)
-> PropertyT IO (Sequential (PropertyT IO) Model)
forall a b. (a -> b) -> a -> b
$
      Range Int
-> (forall (v :: * -> *). Model v)
-> [Command (GenT Identity) (PropertyT IO) Model]
-> Gen (Sequential (PropertyT IO) Model)
forall (gen :: * -> *) (m :: * -> *) (state :: (* -> *) -> *).
(MonadGen gen, MonadTest m) =>
Range Int
-> (forall (v :: * -> *). state v)
-> [Command gen m state]
-> gen (Sequential m state)
Gen.sequential
        (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
40)
        Model v
forall (v :: * -> *). Model v
initialModel
        [ forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cInsert @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cClaim @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cAck @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cCancel @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cSuspend @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cResume @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cPromote @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cRetry @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cExtend @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cRelease @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cToDLQ @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cFromDLQ @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cBatchInsert @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cInsertTree @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cBatchCancel @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cBatchDLQ @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cDedup @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cRefresh @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command (GenT Identity) (PropertyT IO) Model
forall (gen :: * -> *) (m :: * -> *).
(MonadGen gen, MonadIO m, MonadTest m) =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cCrash Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        , forall (gen :: * -> *) (m :: * -> *) (sm :: * -> *).
(ArbiterC sm, MonadGen gen, MonadIO m, MonadTest m) =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> Command gen m Model
cSuspendLapsed @_ @_ @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
        ]
  evalIO (resetSeeded reset schema withConn)
  executeSequential initialModel actions
  settled <- evalIO (queryViolations schema table withConn)
  settled === []

-- | Concurrent property with up to eight independent action branches. The seed
-- reproduces the branches. Shrinking is off. Run them under the
-- caller-installed HOL detector. Then run one reaper tick and check the detector
-- log and settled summary.
prop_concurrent
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> Property
-- A concurrent failure is nondeterministic and shrink candidates rarely
-- reproduce it. The seed-reproducible counterexample is kept.
prop_concurrent :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> Property
prop_concurrent forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = TestLimit -> Property -> Property
withTests TestLimit
100 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ ShrinkLimit -> Property -> Property
withShrinks ShrinkLimit
0 (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  branches <- Gen [[Act]] -> PropertyT IO [[Act]]
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen [[Act]] -> PropertyT IO [[Act]])
-> Gen [[Act]] -> PropertyT IO [[Act]]
forall a b. (a -> b) -> a -> b
$ Range Int -> GenT Identity [Act] -> Gen [[Act]]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
2 Int
8) (Range Int -> Gen Act -> GenT Identity [Act]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
5 Int
25) Gen Act
genActionData)
  (hol, settled) <- evalIO $ do
    resetSeeded reset schema withConn
    truncateHol schema table withConn
    mapConcurrently_
      (traverse_ (\Act
act -> IO () -> IO ()
withRetry (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> Act -> sm ()
interpret @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Act
act))))
      branches
    void (run (runReaper @sm schema table))
    (,) <$> withConn (\Connection
conn -> Connection -> Text -> Text -> IO [String]
holViolations Connection
conn Text
schema Text
table) <*> queryViolations schema table withConn
  (hol <> settled) === []

-- | Set a wall-clock time limit for a concurrent test.
withinSecs :: Int -> IO () -> IO ()
withinSecs :: Int -> IO () -> IO ()
withinSecs Int
secs IO ()
act =
  Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
secs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000) IO ()
act
    IO (Maybe ()) -> (Maybe () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (() -> IO ()) -> Maybe () -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String
"timed out after " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
secs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"s")) () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- ---------------------------------------------------------------------------
-- Deterministic regression guards
-- ---------------------------------------------------------------------------
-- Saturated, bounded stress targeted at fixed concurrency bugs. These reproduce
-- a regression on nearly every run.

-- | Test for the cross-group trigger deadlock. Two actors repeatedly run
-- conflicting multi-group operations. One inserts a batch across g1 and g3.
-- The other moves a deduplication key between those groups. The @FOR UPDATE@
-- clauses lock group rows in a consistent order. Count @40P01@ errors.
deadlockGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> IO ()
  -> IO ()
deadlockGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
deadlockGuard forall a. sm a -> IO a
run IO ()
reset = do
  IO ()
reset
  deadlocks <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
  let rounds = Int
600 :: Int
      watch = IORef Int -> IO () -> IO ()
countingDeadlocks IORef Int
deadlocks
      actorA = Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
rounds (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
watch (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => [(Maybe Text, Int)] -> sm ()
mkBatchInsert @sm [(Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"g1", Int
0), (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"g3", Int
0)]))
      actorB =
        (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
          (\Int
index -> IO () -> IO ()
watch (sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
Text -> Bool -> Maybe Text -> Int -> sm ()
mkDedup @sm Text
"dlk" Bool
True (Text -> Maybe Text
forall a. a -> Maybe a
Just (if Int -> Bool
forall a. Integral a => a -> Bool
even Int
index then Text
"g1" else Text
"g3")) Int
0)))
          [Int
1 .. Int
rounds]
  mapConcurrently_ id [actorA, actorB]
  deadlockCount <- readIORef deadlocks
  deadlockCount `shouldBe` 0

lockWaitSecs :: Int
lockWaitSecs :: Int
lockWaitSecs = Int
5

lockPollMicros :: Int
lockPollMicros :: Int
lockPollMicros = Int
10_000

-- | Wait until @count@ backends on this database wait on a lock.
awaitLockWaiters :: (forall a. (PG.Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters :: (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters forall a. (Connection -> IO a) -> IO a
withConn Int64
count = Int -> IO () -> IO ()
withinSecs Int
lockWaitSecs IO ()
go
  where
    go :: IO ()
go = do
      waiting <-
        (forall a. (Connection -> IO a) -> IO a) -> Text -> IO Int64
countQuery
          (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
          Text
"SELECT count(*) FROM pg_stat_activity WHERE wait_event_type = 'Lock' AND datname = current_database()"
      when (waiting < count) (threadDelay lockPollMicros >> go)

-- | Open the gate when the action ends, so a paused worker finishes before it is cancelled.
releasing :: MVar () -> IO a -> IO a
releasing :: forall a. MVar () -> IO a -> IO a
releasing MVar ()
gate IO a
action = IO a
action IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
gate ())

-- | A settle that wakes a parent in an earlier group, against a batch insert across both
-- groups. A held middle group stops the insert between its two group locks.
crossGroupWakeLockOrder
  :: forall sm
   . (ArbiterC sm)
  => (JobRead SMPayload -> sm ())
  -> (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
crossGroupWakeLockOrder :: forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrder = (JobRead SMPayload -> sm ())
-> (JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrderAfter (sm () -> JobRead SMPayload -> sm ()
forall a b. a -> b -> a
const (() -> sm ()
forall a. a -> sm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

-- | 'crossGroupWakeLockOrder' with @prepare@ run on the claimed child before the insert.
crossGroupWakeLockOrderAfter
  :: forall sm
   . (ArbiterC sm)
  => (JobRead SMPayload -> sm ())
  -> (JobRead SMPayload -> sm ())
  -> (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
crossGroupWakeLockOrderAfter :: forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrderAfter JobRead SMPayload -> sm ()
prepare JobRead SMPayload -> sm ()
settle forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  later <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
  let scheduled Text
group = Maybe UTCTime -> JobWrite SMPayload -> JobWrite SMPayload
forall payload.
Maybe UTCTime -> JobWrite payload -> JobWrite payload
setNotVisibleUntil (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
later) (Maybe Text -> Text -> JobWrite SMPayload
smJob (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
group) Text
"sm scheduled")
  void (run (HL.insertJobTree @SMPayload (smJob (Just "aa") "sm parent" <~~ (smJob (Just "zz") "sm child" :| []))))
  void (run (HL.insertJob (scheduled "mm")))
  [child] <- run (HL.claimNextVisibleJobs 1 60) :: IO [JobRead SMPayload]
  run (prepare child)
  held <- newEmptyMVar
  release <- newEmptyMVar
  let holder = (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
        Connection -> IO ()
PG.begin Connection
conn
        IO [Only Int] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
          ( Connection -> Query -> IO [Only Int]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_
              Connection
conn
              (Text -> Query
toQuery (Text
"SELECT 1 FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueGroupsTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE group_key = 'mm' FOR UPDATE"))
              :: IO [Only Int]
          )
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
held ()
        MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
release
        Connection -> IO ()
PG.commit Connection
conn
      inserter = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([JobWrite SMPayload] -> sm Int64
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m Int64
HL.insertJobsBatch_ [Text -> JobWrite SMPayload
scheduled Text
"aa", Text -> JobWrite SMPayload
scheduled Text
"mm", Text -> JobWrite SMPayload
scheduled Text
"zz"])))
      acker = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (JobRead SMPayload -> sm ()
settle JobRead SMPayload
child))
  withAsync holder $ \Async ()
holding -> do
    Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
holding
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
held
    IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
inserter ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
insertDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
release (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
1
      IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
acker ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
ackDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
release (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
2
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
release ()
        outcomes <- (,) (Either SomeException ()
 -> Either SomeException ()
 -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO
     (Either SomeException ()
      -> (Either SomeException (), Either SomeException ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
insertDone IO
  (Either SomeException ()
   -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO (Either SomeException (), Either SomeException ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
ackDone
        let failures = [SomeException -> String
forall a. Show a => a -> String
show SomeException
err | Left SomeException
err <- [(Either SomeException (), Either SomeException ())
-> Either SomeException ()
forall a b. (a, b) -> a
fst (Either SomeException (), Either SomeException ())
outcomes, (Either SomeException (), Either SomeException ())
-> Either SomeException ()
forall a b. (a, b) -> b
snd (Either SomeException (), Either SomeException ())
outcomes]]
        failures `shouldBe` []

-- | A batch settle over two claimed rows, against a transaction that locks the higher row
-- and then the lower one, as every multi-row statement does.
descendingSettleLockOrder
  :: forall sm
   . (ArbiterC sm)
  => ([JobRead SMPayload] -> sm ())
  -> (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
descendingSettleLockOrder :: forall (sm :: * -> *).
ArbiterC sm =>
([JobRead SMPayload] -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
descendingSettleLockOrder [JobRead SMPayload] -> sm ()
settle forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> IO Int64
forall a. sm a -> IO a
run ([JobWrite SMPayload] -> sm Int64
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m Int64
HL.insertJobsBatch_ [Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
forall a. Maybe a
Nothing Text
"sm low", Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
forall a. Maybe a
Nothing Text
"sm high"]))
  claimed <- (JobRead SMPayload -> Int64)
-> [JobRead SMPayload] -> [JobRead SMPayload]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey ([JobRead SMPayload] -> [JobRead SMPayload])
-> IO [JobRead SMPayload] -> IO [JobRead SMPayload]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
2 NominalDiffTime
60) :: IO [JobRead SMPayload])
  [low, high] <- pure claimed
  let lockRow Connection
conn JobRead SMPayload
job =
        IO [Only Int] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
          ( Connection -> Query -> IO [Only Int]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_
              Connection
conn
              ( Text -> Query
toQuery
                  (Text
"SELECT 1 FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int64 -> String
forall a. Show a => a -> String
show (JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead SMPayload
job)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" FOR UPDATE")
              )
              :: IO [Only Int]
          )
  held <- newEmptyMVar
  proceed <- newEmptyMVar
  let holder = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (IO () -> IO (Either SomeException ()))
-> ((Connection -> IO ()) -> IO ())
-> (Connection -> IO ())
-> IO (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO (Either SomeException ()))
-> (Connection -> IO ()) -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
        Connection -> IO ()
PG.begin Connection
conn
        Connection -> JobRead SMPayload -> IO ()
lockRow Connection
conn JobRead SMPayload
high
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
held ()
        MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
proceed
        Connection -> JobRead SMPayload -> IO ()
lockRow Connection
conn JobRead SMPayload
low
        Connection -> IO ()
PG.commit Connection
conn
      settler = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run ([JobRead SMPayload] -> sm ()
settle [JobRead SMPayload]
claimed))
  withAsync holder $ \Async (Either SomeException ())
holding -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
proceed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
held
    IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
settler ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
settleDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
proceed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
1
      MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
proceed ()
      outcomes <- (,) (Either SomeException ()
 -> Either SomeException ()
 -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO
     (Either SomeException ()
      -> (Either SomeException (), Either SomeException ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
holding IO
  (Either SomeException ()
   -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO (Either SomeException (), Either SomeException ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
settleDone
      [show err | Left err <- [void (fst outcomes), snd outcomes]] `shouldBe` []

-- | A transaction that creates a group row and then touches a later group, against a batch
-- insert across both. The insert cannot see the uncommitted group row when it locks.
newGroupLockOrder
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
newGroupLockOrder :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> (forall a. (Connection -> IO a) -> IO a) -> IO () -> IO ()
newGroupLockOrder forall a. sm a -> IO a
run forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  later <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
  let scheduled Text
group = Maybe UTCTime -> JobWrite SMPayload -> JobWrite SMPayload
forall payload.
Maybe UTCTime -> JobWrite payload -> JobWrite payload
setNotVisibleUntil (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
later) (Maybe Text -> Text -> JobWrite SMPayload
smJob (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
group) Text
"sm scheduled")
  void (run (HL.insertJob (scheduled "zz")))
  created <- newEmptyMVar
  proceed <- newEmptyMVar
  let creator = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (IO () -> IO (Either SomeException ()))
-> (sm () -> IO ()) -> sm () -> IO (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sm () -> IO ()
forall a. sm a -> IO a
run (sm () -> IO ()) -> (sm () -> sm ()) -> sm () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sm () -> sm ()
forall a. sm a -> sm a
forall (m :: * -> *) a. MonadArbiter m => m a -> m a
withDbTransaction (sm () -> IO (Either SomeException ()))
-> sm () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
        sm (Maybe (JobRead SMPayload)) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobWrite SMPayload -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> JobWrite SMPayload
scheduled Text
"aa"))
        IO () -> sm ()
forall a. IO a -> sm a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
created () IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
proceed)
        sm (Maybe (JobRead SMPayload)) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobWrite SMPayload -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> JobWrite SMPayload
scheduled Text
"zz"))
      inserter = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([JobWrite SMPayload] -> sm Int64
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m Int64
HL.insertJobsBatch_ [Text -> JobWrite SMPayload
scheduled Text
"aa", Text -> JobWrite SMPayload
scheduled Text
"zz"])))
  withAsync creator $ \Async (Either SomeException ())
creatorDone -> do
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
created
    IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
inserter ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
insertDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
proceed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
1
      MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
proceed ()
      outcomes <- (,) (Either SomeException ()
 -> Either SomeException ()
 -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO
     (Either SomeException ()
      -> (Either SomeException (), Either SomeException ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
creatorDone IO
  (Either SomeException ()
   -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO (Either SomeException (), Either SomeException ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
insertDone
      [show err | Left err <- [fst outcomes, snd outcomes]] `shouldBe` []

-- | A spawn whose children land in a later group than the parent, against a batch insert
-- across both groups. The spawn pauses between its children insert and its settle.
spawnGroupLockOrder
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
spawnGroupLockOrder :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> (forall a. (Connection -> IO a) -> IO a) -> IO () -> IO ()
spawnGroupLockOrder forall a. sm a -> IO a
run forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  later <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
3600 (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
  let scheduled Text
group = Maybe UTCTime -> JobWrite SMPayload -> JobWrite SMPayload
forall payload.
Maybe UTCTime -> JobWrite payload -> JobWrite payload
setNotVisibleUntil (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
later) (Maybe Text -> Text -> JobWrite SMPayload
smJob (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
group) Text
"sm scheduled")
  void (run (HL.insertJobsBatch_ [smJob (Just "aa") "sm parent", scheduled "zz"]))
  [parent] <- run (HL.claimNextVisibleJobs 1 60) :: IO [JobRead SMPayload]
  spawned <- newEmptyMVar
  proceed <- newEmptyMVar
  let spawner = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (IO () -> IO (Either SomeException ()))
-> (sm () -> IO ()) -> sm () -> IO (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sm () -> IO ()
forall a. sm a -> IO a
run (sm () -> IO ()) -> (sm () -> sm ()) -> sm () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sm () -> sm ()
forall a. sm a -> sm a
forall (m :: * -> *) a. MonadArbiter m => m a -> m a
withDbTransaction (sm () -> IO (Either SomeException ()))
-> sm () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
        sm (NonEmpty (JobRead SMPayload)) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobRead SMPayload
-> NonEmpty (JobWrite SMPayload)
-> sm (NonEmpty (JobRead SMPayload))
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload
-> NonEmpty (JobWrite payload) -> m (NonEmpty (JobRead payload))
HL.spawnChildren JobRead SMPayload
parent (Maybe Text -> Text -> Int -> NonEmpty (JobWrite SMPayload)
smChildren (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"zz") Text
"sm spawn child" Int
1))
        IO () -> sm ()
forall a. IO a -> sm a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
spawned () IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
proceed)
        sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob JobRead SMPayload
parent)
      inserter = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([JobWrite SMPayload] -> sm Int64
forall payload (m :: * -> *).
QueueOperation m payload =>
[JobWrite payload] -> m Int64
HL.insertJobsBatch_ [Text -> JobWrite SMPayload
scheduled Text
"aa", Text -> JobWrite SMPayload
scheduled Text
"zz"])))
  withAsync spawner $ \Async (Either SomeException ())
spawnDone -> do
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
spawned
    IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
inserter ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
insertDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
proceed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
1
      MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
proceed ()
      outcomes <- (,) (Either SomeException ()
 -> Either SomeException ()
 -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO
     (Either SomeException ()
      -> (Either SomeException (), Either SomeException ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
spawnDone IO
  (Either SomeException ()
   -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO (Either SomeException (), Either SomeException ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
insertDone
      [show err | Left err <- [fst outcomes, snd outcomes]] `shouldBe` []

-- | A rollup's next spawn round, against a delete of its dead-lettered child. A held parent
-- row stops the spawn after it takes the parent lock and before it detaches the child.
respawnDLQDeleteLockOrder
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
respawnDLQDeleteLockOrder :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
respawnDLQDeleteLockOrder forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  IO (Either Text (NonEmpty (JobRead SMPayload))) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm (Either Text (NonEmpty (JobRead SMPayload)))
-> IO (Either Text (NonEmpty (JobRead SMPayload)))
forall a. sm a -> IO a
run (forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree @SMPayload (Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
forall a. Maybe a
Nothing Text
"sm parent" JobWrite SMPayload
-> NonEmpty (JobWrite SMPayload) -> JobTree SMPayload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ Maybe Text -> Text -> Int -> NonEmpty (JobWrite SMPayload)
smChildren Maybe Text
forall a. Maybe a
Nothing Text
"sm child" Int
2)))
  [failed, done] <- sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
2 NominalDiffTime
60) :: IO [JobRead SMPayload]
  void (run (HL.moveToDLQ "sm dlq" failed))
  void (run (HL.ackJob done))
  [parent] <- run (HL.claimNextVisibleJobs 1 60) :: IO [JobRead SMPayload]
  dlqId <- lookupDlqId schema table withConn (primaryKey failed)
  held <- newEmptyMVar
  release <- newEmptyMVar
  let holder = (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
        Connection -> IO ()
PG.begin Connection
conn
        IO [Only Int] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
          ( Connection -> Query -> Only Int64 -> IO [Only Int]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query
              Connection
conn
              (Text -> Query
toQuery (Text
"SELECT 1 FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE id = ? FOR UPDATE"))
              (Int64 -> Only Int64
forall a. a -> Only a
Only (JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead SMPayload
parent))
              :: IO [Only Int]
          )
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
held ()
        MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
release
        Connection -> IO ()
PG.commit Connection
conn
      spawner = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (sm (NonEmpty (JobRead SMPayload)) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JobRead SMPayload
-> NonEmpty (JobWrite SMPayload)
-> sm (NonEmpty (JobRead SMPayload))
forall payload (m :: * -> *).
JobOperation m payload =>
JobRead payload
-> NonEmpty (JobWrite payload) -> m (NonEmpty (JobRead payload))
HL.spawnChildren JobRead SMPayload
parent (Maybe Text -> Text -> Int -> NonEmpty (JobWrite SMPayload)
smChildren Maybe Text
forall a. Maybe a
Nothing Text
"sm respawn" Int
1))))
      deleter = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.deleteDLQJob @SMPayload Int64
dlqId)))
  withAsync holder $ \Async ()
holding -> do
    Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
holding
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
held
    IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
spawner ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
spawnDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
release (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
1
      IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
deleter ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
deleteDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
release (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
2
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
release ()
        outcomes <- (,) (Either SomeException ()
 -> Either SomeException ()
 -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO
     (Either SomeException ()
      -> (Either SomeException (), Either SomeException ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
spawnDone IO
  (Either SomeException ()
   -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO (Either SomeException (), Either SomeException ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
deleteDone
        [show err | Left err <- [fst outcomes, snd outcomes]] `shouldBe` []

-- | A retry of a dead-lettered child that re-suspends its woken parent, against a delete of
-- the same DLQ row. A held parent row stops the delete at its tree lock.
retryDLQDeleteLockOrder
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
retryDLQDeleteLockOrder :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
retryDLQDeleteLockOrder forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  IO (Either Text (NonEmpty (JobRead SMPayload))) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm (Either Text (NonEmpty (JobRead SMPayload)))
-> IO (Either Text (NonEmpty (JobRead SMPayload)))
forall a. sm a -> IO a
run (forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree @SMPayload (Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
forall a. Maybe a
Nothing Text
"sm parent" JobWrite SMPayload
-> NonEmpty (JobWrite SMPayload) -> JobTree SMPayload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ Maybe Text -> Text -> Int -> NonEmpty (JobWrite SMPayload)
smChildren Maybe Text
forall a. Maybe a
Nothing Text
"sm child" Int
2)))
  [failed, done] <- sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
2 NominalDiffTime
60) :: IO [JobRead SMPayload]
  void (run (HL.moveToDLQ "sm dlq" failed))
  void (run (HL.ackJob done))
  dlqId <- lookupDlqId schema table withConn (primaryKey failed)
  held <- newEmptyMVar
  release <- newEmptyMVar
  let holder = (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
        Connection -> IO ()
PG.begin Connection
conn
        IO [Only Int] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
          ( Connection -> Query -> IO [Only Int]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_
              Connection
conn
              (Text -> Query
toQuery (Text
"SELECT 1 FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE parent_id IS NULL FOR UPDATE"))
              :: IO [Only Int]
          )
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
held ()
        MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
release
        Connection -> IO ()
PG.commit Connection
conn
      deleter = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.deleteDLQJob @SMPayload Int64
dlqId)))
      retrier = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (sm (Maybe (JobRead SMPayload)) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int64 -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.retryFromDLQ Int64
dlqId :: sm (Maybe (JobRead SMPayload)))))
  withAsync holder $ \Async ()
holding -> do
    Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
holding
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
held
    IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
deleter ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
deleteDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
release (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
1
      IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
retrier ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
retryDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
release (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
2
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
release ()
        outcomes <- (,) (Either SomeException ()
 -> Either SomeException ()
 -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO
     (Either SomeException ()
      -> (Either SomeException (), Either SomeException ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
deleteDone IO
  (Either SomeException ()
   -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO (Either SomeException (), Either SomeException ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
retryDone
        [show err | Left err <- [fst outcomes, snd outcomes]] `shouldBe` []

-- | A retry of a dead-lettered child that re-suspends its parent, against a cancel of a
-- live sibling that wakes the same parent. A held count row stops the cancel after it
-- locks the parent's group.
retryDLQCancelLockOrder
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
retryDLQCancelLockOrder :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
retryDLQCancelLockOrder forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO () -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
resetSeeded IO ()
reset Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  let sibling :: JobWrite SMPayload
sibling = Extras -> JobWrite SMPayload -> JobWrite SMPayload
applyExtras (Maybe Text -> Maybe Text -> Extras
Extras (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cap-a") Maybe Text
forall a. Maybe a
Nothing) (Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
forall a. Maybe a
Nothing Text
"sm sibling")
  IO (Either Text (NonEmpty (JobRead SMPayload))) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm (Either Text (NonEmpty (JobRead SMPayload)))
-> IO (Either Text (NonEmpty (JobRead SMPayload)))
forall a. sm a -> IO a
run (forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree @SMPayload (Maybe Text -> Text -> JobWrite SMPayload
smJob (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"gp") Text
"sm parent" JobWrite SMPayload
-> NonEmpty (JobWrite SMPayload) -> JobTree SMPayload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ (Maybe Text -> Text -> JobWrite SMPayload
smJob Maybe Text
forall a. Maybe a
Nothing Text
"sm failed" JobWrite SMPayload
-> [JobWrite SMPayload] -> NonEmpty (JobWrite SMPayload)
forall a. a -> [a] -> NonEmpty a
:| [JobWrite SMPayload
sibling]))))
  [failed, live] <-
    (JobRead SMPayload -> Bool)
-> [JobRead SMPayload] -> [JobRead SMPayload]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool)
-> (JobRead SMPayload -> Maybe Text) -> JobRead SMPayload -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMPayload -> Maybe Text
smConcSlot (SMPayload -> Maybe Text)
-> (JobRead SMPayload -> SMPayload)
-> JobRead SMPayload
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> SMPayload
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> payload
Job.payload) ([JobRead SMPayload] -> [JobRead SMPayload])
-> IO [JobRead SMPayload] -> IO [JobRead SMPayload]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
2 NominalDiffTime
60) :: IO [JobRead SMPayload])
  void (run (HL.moveToDLQ "sm dlq" failed))
  dlqId <- lookupDlqId schema table withConn (primaryKey failed)
  held <- newEmptyMVar
  release <- newEmptyMVar
  let holder = (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
        Connection -> IO ()
PG.begin Connection
conn
        Connection -> Text -> Text -> IO ()
lockConcurrencyKey Connection
conn (Text -> Text
arbiterConcurrencyTable Text
schema) Text
"cap-a:s"
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
held ()
        MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
release
        Connection -> IO ()
PG.commit Connection
conn
      canceller = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.cancelJobCascade @SMPayload (JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead SMPayload
live))))
      retrier = IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (sm () -> IO ()
forall a. sm a -> IO a
run (sm (Maybe (JobRead SMPayload)) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int64 -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m (Maybe (JobRead payload))
HL.retryFromDLQ Int64
dlqId :: sm (Maybe (JobRead SMPayload)))))
  withAsync holder $ \Async ()
holding -> do
    Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
link Async ()
holding
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
held
    IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
canceller ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
cancelDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
release (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
1
      IO (Either SomeException ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> (Async a -> m b) -> m b
withAsync IO (Either SomeException ())
retrier ((Async (Either SomeException ()) -> IO ()) -> IO ())
-> (Async (Either SomeException ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async (Either SomeException ())
retryDone -> MVar () -> IO () -> IO ()
forall a. MVar () -> IO a -> IO a
releasing MVar ()
release (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (forall a. (Connection -> IO a) -> IO a) -> Int64 -> IO ()
awaitLockWaiters (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn Int64
2
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
release ()
        outcomes <- (,) (Either SomeException ()
 -> Either SomeException ()
 -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO
     (Either SomeException ()
      -> (Either SomeException (), Either SomeException ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
cancelDone IO
  (Either SomeException ()
   -> (Either SomeException (), Either SomeException ()))
-> IO (Either SomeException ())
-> IO (Either SomeException (), Either SomeException ())
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Async (Either SomeException ()) -> IO (Either SomeException ())
forall (m :: * -> *) a. MonadIO m => Async a -> m a
wait Async (Either SomeException ())
retryDone
        [show err | Left err <- [fst outcomes, snd outcomes]] `shouldBe` []

-- | Guard for the tree lock order a spawn shares with a dead-letter move and a
-- cascade cancel.
spawnDeadlockGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
spawnDeadlockGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
spawnDeadlockGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  deadlocks <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
  spawns <- newIORef (0 :: Int)
  let rounds = Int
200 :: Int
      watch = IORef Int -> IO () -> IO ()
countingDeadlocks IORef Int
deadlocks
      spawnRound = do
        sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => [(Maybe Text, Int)] -> sm ()
mkBatchInsert @sm [(Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"spd", Int
0), (Maybe Text
forall a. Maybe a
Nothing, Int
0)])
        committed <- sm Int -> IO Int
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => Maybe Text -> Int -> sm Int
claimSpawnCount @sm (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"spd") Int
2)
        atomicModifyIORef' spawns (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
committed, ()))
      actorA = Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
rounds (IO () -> IO ()
watch IO ()
spawnRound)
      actorB =
        Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
rounds
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
watch
          (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => sm ()
claimToDLQ @sm sm () -> sm () -> sm ()
forall a b. sm a -> sm b -> sm b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> (Int64 -> sm ())
-> sm ()
onRandomRollupParent @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ()) -> (Int64 -> sm Int64) -> Int64 -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.cancelJobCascade @SMPayload))
  mapConcurrently_ id [actorA, actorB]
  -- A saturated run commits a few hundred spawns. Refuse a run that raced itself idle.
  readIORef spawns >>= (`shouldSatisfy` (>= rounds `div` 2))
  deadlockCount <- readIORef deadlocks
  deadlockCount `shouldBe` 0

-- | Guard for the dedup group-move double-claim. Saturates the hot groups with
-- concurrent dedup moves and claims under the gap-free HOL detector, with the
-- reaper churning. Asserts the detector stayed empty.
serializationGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
serializationGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
serializationGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO () -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
resetSeeded IO ()
reset Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Text -> Text -> IO ()
installHolDetector Connection
conn Text
schema Text
table
  (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally ((Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Text -> Text -> IO ()
removeHolDetector Connection
conn Text
schema Text
table) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
truncateHol Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    let rounds :: Int
rounds = Int
800 :: Int
        nActors :: Int
nActors = Int
16 :: Int
        actor :: IO ()
actor = Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
rounds (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          act <- Gen (sm ()) -> IO (sm ())
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Gen a -> m a
Gen.sample (forall (sm :: * -> *).
ArbiterC sm =>
Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> Gen (sm ())
genAction @sm Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn)
          withRetry (run act)
        reaper :: IO ()
reaper = Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (Int
rounds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
withRetry (sm () -> IO ()
forall a. sm a -> IO a
run (sm (Int64, [Text]) -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *).
(MonadArbiter m, RegistryTables (RegistryOf m)) =>
m (Int64, [Text])
HL.refreshAllGroupsFully @sm)))
    (IO () -> IO ()) -> [IO ()] -> IO ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
(a -> m b) -> f a -> m ()
mapConcurrently_ IO () -> IO ()
forall a. a -> a
id (IO ()
reaper IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: Int -> IO () -> [IO ()]
forall a. Int -> a -> [a]
replicate Int
nActors IO ()
actor)
    hol <- (Connection -> IO [String]) -> IO [String]
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO [String]) -> IO [String])
-> (Connection -> IO [String]) -> IO [String]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Text -> Text -> IO [String]
holViolations Connection
conn Text
schema Text
table
    hol `shouldBe` []

-- | Concurrent churn with no reaper, then assert the group summary matches a fresh recompute.
concurrentDriftGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
concurrentDriftGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
concurrentDriftGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO () -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
resetSeeded IO ()
reset Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  let rounds :: Int
rounds = Int
300 :: Int
      nActors :: Int
nActors = Int
12 :: Int
      actor :: IO ()
actor = Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
rounds (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        act <- Gen Act -> IO Act
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Gen a -> m a
Gen.sample ((Act -> Bool) -> Gen Act -> Gen Act
forall (m :: * -> *) a.
(MonadGen m, GenBase m ~ Identity) =>
(a -> Bool) -> m a -> m a
Gen.filter (Act -> Act -> Bool
forall a. Eq a => a -> a -> Bool
/= Act
AReaper) Gen Act
genActionData)
        withRetry (run (interpret @sm schema table withConn act))
  (IO () -> IO ()) -> [IO ()] -> IO ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
(a -> m b) -> f a -> m ()
mapConcurrently_ IO () -> IO ()
forall a. a -> a
id (Int -> IO () -> [IO ()]
forall a. Int -> a -> [a]
replicate Int
nActors IO ()
actor)
  Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
driftViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO [String] -> ([String] -> 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
>>= ([String] -> [String] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [])

-- | Deterministic guard for the @max_attempts@ machinery. Inserts ungrouped jobs
-- capped at a single attempt, then claim and release cycles them. The claim guard
-- holds attempts at the limit and the reaper sweep moves every exhausted job to
-- the DLQ.
exhaustionGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
exhaustionGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
exhaustionGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  let jobCount :: Int
jobCount = Int
20 :: Int
  sm () -> IO ()
forall a. sm a -> IO a
run (Int -> sm () -> sm ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
jobCount (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id Maybe Text
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Int
0 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1))))
  -- Claim everything, then release it back. Only the first cycle claims. Later
  -- cycles are no-ops.
  Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
3 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    sm () -> IO ()
forall a. sm a -> IO a
run (sm () -> IO ()) -> sm () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      jobs <- Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
100 NominalDiffTime
60 :: sm [JobRead SMPayload]
      traverse_ (void . HL.setVisibilityTimeout 0) jobs
  -- No live job is past its limit.
  Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
exactViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO [String] -> ([String] -> 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
>>= ([String] -> [String] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` [])
  -- Every exhausted, claimable job lands in the DLQ.
  IO (Int64, [Text]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm (Int64, [Text]) -> IO (Int64, [Text])
forall a. sm a -> IO a
run (Text -> [Text] -> sm (Int64, [Text])
forall (m :: * -> *).
MonadArbiter m =>
Text -> [Text] -> m (Int64, [Text])
Ops.sweepExhaustedJobs Text
schema [Text
table]))
  let tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table
  stranded <-
    (forall a. (Connection -> IO a) -> IO a) -> Text -> IO Int64
countQuery (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (Text -> IO Int64) -> Text -> IO Int64
forall a b. (a -> b) -> a -> b
$
      Text
"SELECT count(*) FROM "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE attempts >= 1 AND NOT suspended"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AND (not_visible_until IS NULL OR not_visible_until <= NOW())"
  dlqd <- countQuery withConn ("SELECT count(*) FROM " <> jobQueueDLQTable schema table)
  stranded `shouldBe` 0
  dlqd `shouldBe` fromIntegral jobCount

-- | Claim everything visible and ack it, repeatedly, until a claim comes back
-- empty or the round bound is hit.
drainToEmpty
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Int
  -> IO ()
drainToEmpty :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> Int -> IO ()
drainToEmpty forall a. sm a -> IO a
run = Int -> IO ()
go
  where
    go :: Int -> IO ()
go Int
bound
      | Int
bound Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
          jobs <- sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
50 NominalDiffTime
60 :: sm [JobRead SMPayload])
          if null jobs
            then pure ()
            else run (traverse_ (void . HL.ackJob) jobs) >> go (bound - 1)

-- | Deterministic liveness guard. A fixed set of jobs across several groups plus
-- ungrouped, at mixed priorities, drains fully under a fair claim and ack loop
-- within a bounded number of rounds.
progressGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
progressGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
progressGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  sm () -> IO ()
forall a. sm a -> IO a
run (sm () -> IO ()) -> sm () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (Int -> sm ()) -> [Int] -> sm ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
      ( \Int
index ->
          sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
            (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"pg-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show (Int
index Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8)))) Maybe Int
forall a. Maybe a
Nothing (Int
index Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
5) Maybe Int
forall a. Maybe a
Nothing)
      )
      [Int
1 .. Int
40 :: Int]
    (Int -> sm ()) -> [Int] -> sm ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
      (\Int
index -> sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id Maybe Text
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing (Int
index Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
5) Maybe Int
forall a. Maybe a
Nothing))
      [Int
1 .. Int
20 :: Int]
  forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> Int -> IO ()
drainToEmpty @sm sm a -> IO a
forall a. sm a -> IO a
run Int
300
  remaining <- (Connection -> IO Int64) -> IO Int64
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO Int64) -> IO Int64)
-> (Connection -> IO Int64) -> IO Int64
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    [Only count] <- Connection -> Query -> IO [Only Int64]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (Text -> Query
toQuery (Text
"SELECT count(*) FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueTable Text
schema Text
table))
    pure (count :: Int64)
  remaining `shouldBe` 0

-- | Deterministic guard against group starvation. Ineligible groups in backoff
-- or suspended drop out of the ready ranking. A regression makes the productive
-- claim come back empty.
starvationGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> IO ()
  -> IO ()
starvationGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
starvationGuard forall a. sm a -> IO a
run IO ()
reset = do
  let crowders :: [Int]
crowders = [Int
1 .. Int
30 :: Int]
      grp :: Text -> a -> Text
grp Text
prefix a
index = Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (a -> String
forall a. Show a => a -> String
show a
index)
      ins :: Text -> Text -> IO ()
ins Text
group Text
lbl = IO (Maybe (JobRead SMPayload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm (Maybe (JobRead SMPayload)) -> IO (Maybe (JobRead SMPayload))
forall a. sm a -> IO a
run (JobWrite SMPayload -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> SMPayload -> JobWrite SMPayload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
group (Text -> SMPayload
smPayload Text
lbl))))
      claim1 :: IO [JobRead SMPayload]
claim1 = sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60 :: sm [JobRead SMPayload])
  -- Backoff-blocked crowders. Each fails its head into a long backoff with a
  -- ready successor queued behind it.
  IO ()
reset
  (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Int
index -> Text -> Text -> IO ()
ins (Text -> Int -> Text
forall {a}. Show a => Text -> a -> Text
grp Text
"boff-" Int
index) (Text -> Int -> Text
forall {a}. Show a => Text -> a -> Text
grp Text
"boff-" Int
index Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-head")) [Int]
crowders
  Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
crowders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    jobs <- IO [JobRead SMPayload]
claim1
    run (traverse_ (void . HL.updateJobForRetry 3600 "boom") jobs)
  (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Int
index -> Text -> Text -> IO ()
ins (Text -> Int -> Text
forall {a}. Show a => Text -> a -> Text
grp Text
"boff-" Int
index) (Text -> Int -> Text
forall {a}. Show a => Text -> a -> Text
grp Text
"boff-" Int
index Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-succ")) [Int]
crowders
  Text -> Text -> IO ()
ins Text
"productive-g" Text
"productive"
  behindBackoff <- IO [JobRead SMPayload]
claim1
  length behindBackoff `shouldBe` 1
  -- Suspended crowders. They are not claimable and leave the ready ranking.
  reset
  traverse_
    ( \Int
index -> do
        inserted <- sm (Maybe (JobRead SMPayload)) -> IO (Maybe (JobRead SMPayload))
forall a. sm a -> IO a
run (JobWrite SMPayload -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob (Text -> SMPayload -> JobWrite SMPayload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob (Text -> Int -> Text
forall {a}. Show a => Text -> a -> Text
grp Text
"susp-" Int
index) (Text -> SMPayload
smPayload (Text -> Int -> Text
forall {a}. Show a => Text -> a -> Text
grp Text
"susp-" Int
index))))
        run (traverse_ (void . HL.suspendJob @SMPayload . primaryKey) inserted)
    )
    crowders
  ins "productive-g" "productive"
  behindSuspended <- claim1
  length behindSuspended `shouldBe` 1

-- | Deterministic guard for the rollup-tree lifecycle. Part 1: a finalizer over
-- two children resumes and completes once both children are acked. Part 2:
-- DLQ'ing the parent cascades every tree member to the DLQ.
treeGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
treeGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
treeGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  let tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table
      mainCount :: IO Int64
mainCount = (forall a. (Connection -> IO a) -> IO a) -> Text -> IO Int64
countQuery (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (Text
"SELECT count(*) FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl)
      dlqCount :: IO Int64
dlqCount = (forall a. (Connection -> IO a) -> IO a) -> Text -> IO Int64
countQuery (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (Text
"SELECT count(*) FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueDLQTable Text
schema Text
table)
      mkJob :: Text -> JobWrite SMPayload
mkJob Text
lbl = SMPayload -> JobWrite SMPayload
forall payload. payload -> JobWrite payload
defaultJob (Text -> SMPayload
smPayload Text
lbl)
      twoChildTree :: JobTree SMPayload
twoChildTree = Text -> JobWrite SMPayload
mkJob Text
"tg parent" JobWrite SMPayload
-> NonEmpty (JobWrite SMPayload) -> JobTree SMPayload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ (Text -> JobWrite SMPayload
mkJob Text
"tg child 0" JobWrite SMPayload
-> [JobWrite SMPayload] -> NonEmpty (JobWrite SMPayload)
forall a. a -> [a] -> NonEmpty a
:| [Text -> JobWrite SMPayload
mkJob Text
"tg child 1"])
  -- Part 1: acking both children resumes the parent, which then completes.
  IO ()
reset
  sm () -> IO ()
forall a. sm a -> IO a
run (forall (sm :: * -> *). ArbiterC sm => Maybe Text -> Int -> sm ()
mkInsertTree @sm Maybe Text
forall a. Maybe a
Nothing Int
2)
  forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> Int -> IO ()
drainToEmpty @sm sm a -> IO a
forall a. sm a -> IO a
run Int
10
  IO Int64
mainCount IO Int64 -> (Int64 -> 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
>>= (Int64 -> Int64 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int64
0)
  IO Int64
dlqCount IO Int64 -> (Int64 -> 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
>>= (Int64 -> Int64 -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int64
0)
  -- Part 2: DLQ'ing the suspended parent cascades the whole tree to the DLQ.
  IO ()
reset
  Right (parent :| _) <- sm (Either Text (NonEmpty (JobRead SMPayload)))
-> IO (Either Text (NonEmpty (JobRead SMPayload)))
forall a. sm a -> IO a
run (forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree @SMPayload JobTree SMPayload
twoChildTree)
  void (run (HL.moveToDLQ "tree guard cascade" parent))
  mainCount >>= (`shouldBe` 0)
  dlqCount >>= (`shouldBe` 3)

-- | A dedup-replaced job is fresh and carries no stale claim owner. A grouped
-- job is claimed with a 1s lease and abandoned, then dedup-replaced once the
-- lease expires. The replaced row has no claimant.
dedupReplaceStaleLeaseGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
dedupReplaceStaleLeaseGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
dedupReplaceStaleLeaseGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  let job :: JobWrite SMPayload
job = Maybe DedupKey -> JobWrite SMPayload -> JobWrite SMPayload
forall payload.
Maybe DedupKey -> JobWrite payload -> JobWrite payload
setDedupKey (DedupKey -> Maybe DedupKey
forall a. a -> Maybe a
Just (Text -> DedupKey
ReplaceDuplicate Text
"drsl-key")) (JobWrite SMPayload -> JobWrite SMPayload)
-> JobWrite SMPayload -> JobWrite SMPayload
forall a b. (a -> b) -> a -> b
$ Text -> SMPayload -> JobWrite SMPayload
forall payload. Text -> payload -> JobWrite payload
defaultGroupedJob Text
"drslg" (Text -> SMPayload
smPayload Text
"drsl")
  IO (Maybe (JobRead SMPayload)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm (Maybe (JobRead SMPayload)) -> IO (Maybe (JobRead SMPayload))
forall a. sm a -> IO a
run (JobWrite SMPayload -> sm (Maybe (JobRead SMPayload))
forall payload (m :: * -> *).
QueueOperation m payload =>
JobWrite payload -> m (Maybe (JobRead payload))
HL.insertJob JobWrite SMPayload
job))
  _ <- sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> UUID -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> UUID -> m [JobRead payload]
HL.claimNextVisibleJobsAs Int
1 NominalDiffTime
1 (Word32 -> Word32 -> Word32 -> Word32 -> UUID
UUID.fromWords Word32
0 Word32
0 Word32
0 Word32
1) :: sm [JobRead SMPayload])
  threadDelay pastLeaseMicros
  void (run (HL.insertJob job))
  stale <-
    countQuery withConn $
      "SELECT count(*) FROM " <> jobQueueTable schema table <> " WHERE dedup_key = 'drsl-key' AND claimed_by IS NOT NULL"
  stale `shouldBe` 0

-- | Deterministic guard for the rows promote refuses: back in flight on a second
-- attempt, released, and suspended with a schedule.
promoteLeaseGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
promoteLeaseGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
promoteLeaseGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  -- Back in flight on a second attempt.
  IO ()
reset
  jid <- sm Int64 -> IO Int64
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id Maybe Text
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Int
0 Maybe Int
forall a. Maybe a
Nothing)
  _ <- run (HL.claimNextVisibleJobsAs 1 60 smWorker :: sm [JobRead SMPayload])
  run (mkRetry @sm jid 0)
  attempt2 <- run (HL.claimNextVisibleJobsAs 1 60 smWorker :: sm [JobRead SMPayload])
  map primaryKey attempt2 `shouldBe` [jid]
  run (HL.promoteJob @SMPayload jid) >>= (`shouldBe` 0)
  isLiveInFlight schema table withConn jid >>= (`shouldBe` True)
  -- Released with a zero visibility timeout. Still claimed, no window left.
  reset
  rid <- run (mkInsert @sm id Nothing Nothing 0 Nothing)
  released <- run (HL.claimNextVisibleJobsAs 1 60 smWorker :: sm [JobRead SMPayload])
  map primaryKey released `shouldBe` [rid]
  run (HL.setVisibilityTimeout 0 (head released)) >>= (`shouldBe` 1)
  leaseState schema table withConn rid >>= (`shouldBe` (False, False, Nothing))
  run (HL.promoteJob @SMPayload rid) >>= (`shouldBe` 0)
  -- Suspended with a schedule its resume restores.
  reset
  sid <- run (mkInsert @sm id Nothing (Just 30) 0 Nothing)
  run (HL.suspendJob @SMPayload sid) >>= (`shouldBe` 1)
  (_, _, nvu) <- leaseState schema table withConn sid
  run (HL.promoteJob @SMPayload sid) >>= (`shouldBe` 0)
  (_, _, nvu') <- leaseState schema table withConn sid
  nvu' `shouldBe` nvu

-- | Deterministic guard for crashed-worker recovery. A grouped job claimed with
-- a one-second lease becomes reclaimable once the lease expires, both through the
-- @next_due@ trigger path and after a reaper recompute of @in_flight_until@.
reclaimGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> IO ()
  -> IO ()
reclaimGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
reclaimGuard forall a. sm a -> IO a
run IO ()
reset = do
  let insClaimExpire :: Text -> IO ()
insClaimExpire Text
group = do
        IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> IO Int64
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
group) Maybe Int
forall a. Maybe a
Nothing Int
0 Maybe Int
forall a. Maybe a
Nothing))
        _ <- sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
1 :: sm [JobRead SMPayload])
        threadDelay pastLeaseMicros
      claim1 :: IO [JobRead SMPayload]
claim1 = sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60 :: sm [JobRead SMPayload])
  -- Through the next_due trigger path alone.
  IO ()
reset
  Text -> IO ()
insClaimExpire Text
"rc-trig"
  viaTrigger <- IO [JobRead SMPayload]
claim1
  length viaTrigger `shouldBe` 1
  -- After a reaper recompute of in_flight_until.
  reset
  insClaimExpire "rc-reaper"
  void (run (HL.refreshAllGroupsFully @sm))
  viaReaper <- claim1
  length viaReaper `shouldBe` 1

-- | An expired lease leaves a past @in_flight_until@, which every reader treats as
-- free. The drift oracle accepts it.
expiredLeaseDriftGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
expiredLeaseDriftGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
expiredLeaseDriftGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> IO Int64
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"drift-lapse") Maybe Int
forall a. Maybe a
Nothing Int
0 Maybe Int
forall a. Maybe a
Nothing))
  claimed <- sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
1 :: sm [JobRead SMPayload])
  length claimed `shouldBe` 1
  threadDelay pastLeaseMicros
  driftViolations schema table withConn >>= (`shouldBe` [])

-- | Deterministic checks for 'Ops.runGated'. A second caller within the interval
-- is skipped. Under concurrency exactly one of many callers wins.
runGatedChecks
  :: forall sm
   . (MonadArbiter sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
runGatedChecks :: forall (sm :: * -> *).
MonadArbiter sm =>
(forall a. sm a -> IO a)
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
runGatedChecks forall a. sm a -> IO a
run Text
schema forall a. (Connection -> IO a) -> IO a
withConn = do
  let truncateGates :: IO ()
truncateGates =
        (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn ->
          Connection -> Text -> IO ()
execute_ Connection
conn (Text
"TRUNCATE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
arbiterGatesTable Text
schema)
  -- A second call within the interval is skipped.
  IO ()
truncateGates
  firstRun <- sm (Maybe Int) -> IO (Maybe Int)
forall a. sm a -> IO a
run (Text -> Text -> NominalDiffTime -> sm Int -> sm (Maybe Int)
forall (m :: * -> *) a.
MonadArbiter m =>
Text -> Text -> NominalDiffTime -> m a -> m (Maybe a)
Ops.runGated Text
schema Text
"sm-gate" NominalDiffTime
3600 (Int -> sm Int
forall a. a -> sm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1 :: Int)))
  secondRun <- run (Ops.runGated schema "sm-gate" 3600 (pure (2 :: Int)))
  firstRun `shouldBe` Just 1
  secondRun `shouldBe` Nothing
  -- Under concurrency exactly one caller wins the gate.
  truncateGates
  results <- mapConcurrently (const (run (Ops.runGated schema "sm-gate2" 3600 (pure ())))) [1 .. 16 :: Int]
  length (filter isJust results) `shouldBe` 1

-- | Deterministic crash-recovery guard. Jobs claimed with a short lease and
-- abandoned are reclaimed and acked exactly once under concurrent workers, with
-- per-group serialization intact.
concurrentReclaimGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
concurrentReclaimGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
concurrentReclaimGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO ()
reset
  (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Text -> Text -> IO ()
installHolDetector Connection
conn Text
schema Text
table
  (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally ((Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Text -> Text -> IO ()
removeHolDetector Connection
conn Text
schema Text
table) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
truncateHol Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    let groups :: [Maybe Text]
groups = [Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"crg" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
index)) | Int
index <- [Int
1 .. Int
5 :: Int]]
        seeds :: [(Maybe Text, Int)]
seeds = [(Maybe Text
forall a. Maybe a
Nothing, Int
prio) | Int
prio <- [Int
0 .. Int
29 :: Int]] [(Maybe Text, Int)] -> [(Maybe Text, Int)] -> [(Maybe Text, Int)]
forall a. Semigroup a => a -> a -> a
<> [(Maybe Text
group, Int
prio) | Maybe Text
group <- [Maybe Text]
groups, Int
prio <- [Int
0 .. Int
1 :: Int]]
    ids <- sm [Int64] -> IO [Int64]
forall a. sm a -> IO a
run (((Maybe Text, Int) -> sm Int64)
-> [(Maybe Text, Int)] -> sm [Int64]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Maybe Text
group, Int
prio) -> forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id Maybe Text
group Maybe Int
forall a. Maybe a
Nothing Int
prio Maybe Int
forall a. Maybe a
Nothing) [(Maybe Text, Int)]
seeds)
    let total = [Int64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
ids
    -- Claim with a 1s lease and abandon, simulating crashed workers.
    void (run (HL.claimNextVisibleJobs total 1 :: sm [JobRead SMPayload]))
    threadDelay crashedLeaseLapseMicros
    -- Race workers to reclaim and ack until drained, recording every acked id.
    acked <- newIORef []
    let drain = do
          jobs <- sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
5 NominalDiffTime
60 :: sm [JobRead SMPayload])
          if null jobs
            then pure ()
            else do
              run (traverse_ (void . HL.ackJob) jobs)
              atomicModifyIORef' acked (\[Int64]
acc -> ((JobRead SMPayload -> Int64) -> [JobRead SMPayload] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey [JobRead SMPayload]
jobs [Int64] -> [Int64] -> [Int64]
forall a. Semigroup a => a -> a -> a
<> [Int64]
acc, ()))
              drain
    mapConcurrently_ id (replicate 10 drain)
    got <- readIORef acked
    length got `shouldBe` total
    Set.size (Set.fromList got) `shouldBe` total
    hol <- withConn $ \Connection
conn -> Connection -> Text -> Text -> IO [String]
holViolations Connection
conn Text
schema Text
table
    hol `shouldBe` []

-- | Deterministic guard that claims honor priority. Ungrouped jobs come out in
-- ascending priority order, and the grouped candidate ranking serves the lowest
-- min-priority group first.
priorityOrderGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> IO ()
  -> IO ()
priorityOrderGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
priorityOrderGuard forall a. sm a -> IO a
run IO ()
reset = do
  let ins :: Maybe Text -> Int -> sm ()
ins Maybe Text
group Int
prio = sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id Maybe Text
group Maybe Int
forall a. Maybe a
Nothing Int
prio Maybe Int
forall a. Maybe a
Nothing)
      claimPriorities :: [Int32] -> IO [Int32]
claimPriorities [Int32]
acc = do
        claimed <- sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
1 NominalDiffTime
60 :: sm [JobRead SMPayload])
        case claimed of
          [] -> [Int32] -> IO [Int32]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int32] -> [Int32]
forall a. [a] -> [a]
reverse [Int32]
acc)
          [JobRead SMPayload]
jobs -> [Int32] -> IO [Int32]
claimPriorities ((JobRead SMPayload -> Int32) -> [JobRead SMPayload] -> [Int32]
forall a b. (a -> b) -> [a] -> [b]
map JobRead SMPayload -> Int32
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> Int32
priority [JobRead SMPayload]
jobs [Int32] -> [Int32] -> [Int32]
forall a. Semigroup a => a -> a -> a
<> [Int32]
acc)
  -- Ungrouped: claim order is ascending in priority.
  IO ()
reset
  sm () -> IO ()
forall a. sm a -> IO a
run ((Int -> sm ()) -> [Int] -> sm ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Maybe Text -> Int -> sm ()
ins Maybe Text
forall a. Maybe a
Nothing) [Int
3, Int
1, Int
4, Int
1, Int
5, Int
0, Int
2])
  prs <- [Int32] -> IO [Int32]
claimPriorities []
  prs `shouldBe` map fromIntegral [0, 1, 1, 2, 3, 4, 5 :: Int]
  -- Grouped: the lowest min-priority group is served first.
  reset
  run (ins (Just "pg-hi") 5)
  run (ins (Just "pg-lo") 0)
  claimed <- run (HL.claimNextVisibleJobs 1 60 :: sm [JobRead SMPayload])
  map priority claimed `shouldBe` [0]

-- | Deterministic guard. A freshly inserted scheduled job becomes claimable when
-- its delay elapses, for both the grouped and ungrouped paths.
scheduledDueGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> IO ()
  -> IO ()
scheduledDueGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
scheduledDueGuard forall a. sm a -> IO a
run IO ()
reset = do
  IO ()
reset
  IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> IO Int64
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"sched-g") (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) Int
0 Maybe Int
forall a. Maybe a
Nothing))
  IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> IO Int64
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm JobWrite SMPayload -> JobWrite SMPayload
forall a. a -> a
id Maybe Text
forall a. Maybe a
Nothing (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) Int
0 Maybe Int
forall a. Maybe a
Nothing))
  early <- sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> m [JobRead payload]
HL.claimNextVisibleJobs Int
5 NominalDiffTime
60 :: sm [JobRead SMPayload])
  length early `shouldBe` 0
  threadDelay pastScheduleMicros
  due <- run (HL.claimNextVisibleJobs 5 60 :: sm [JobRead SMPayload])
  length due `shouldBe` 2

-- | Deterministic guard for the recursive @retryFromDLQ@ restore. A rollup tree
-- cascaded to the DLQ and then retried is restored intact and drains to empty.
treeRetryFromDLQGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
treeRetryFromDLQGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
treeRetryFromDLQGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  let tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table
      mainCount :: IO Int64
mainCount = (forall a. (Connection -> IO a) -> IO a) -> Text -> IO Int64
countQuery (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (Text
"SELECT count(*) FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl)
      dlqCount :: IO Int64
dlqCount = (forall a. (Connection -> IO a) -> IO a) -> Text -> IO Int64
countQuery (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn (Text
"SELECT count(*) FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueDLQTable Text
schema Text
table)
      mkJob :: Text -> JobWrite SMPayload
mkJob Text
lbl = SMPayload -> JobWrite SMPayload
forall payload. payload -> JobWrite payload
defaultJob (Text -> SMPayload
smPayload Text
lbl)
      tree :: JobTree SMPayload
tree = Text -> JobWrite SMPayload
mkJob Text
"trd parent" JobWrite SMPayload
-> NonEmpty (JobWrite SMPayload) -> JobTree SMPayload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ (Text -> JobWrite SMPayload
mkJob Text
"trd child 0" JobWrite SMPayload
-> [JobWrite SMPayload] -> NonEmpty (JobWrite SMPayload)
forall a. a -> [a] -> NonEmpty a
:| [Text -> JobWrite SMPayload
mkJob Text
"trd child 1"])
  IO ()
reset
  Right (parent :| _) <- sm (Either Text (NonEmpty (JobRead SMPayload)))
-> IO (Either Text (NonEmpty (JobRead SMPayload)))
forall a. sm a -> IO a
run (forall payload (m :: * -> *).
QueueOperation m payload =>
JobTree payload -> m (Either Text (NonEmpty (JobRead payload)))
HL.insertJobTree @SMPayload JobTree SMPayload
tree)
  void (run (HL.moveToDLQ "tree retry guard" parent))
  mainCount >>= (`shouldBe` 0)
  dlqCount >>= (`shouldBe` 3)
  -- Retry the parent's DLQ row. The recursive restore brings the whole tree back.
  dlqId <- withConn $ \Connection
conn -> do
    [Only rowId] <-
      Connection -> Query -> Only Int64 -> IO [Only Int64]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PG.query
        Connection
conn
        (Text -> Query
toQuery (Text
"SELECT id FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
jobQueueDLQTable Text
schema Text
table Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" WHERE job_id = ?"))
        (Int64 -> Only Int64
forall a. a -> Only a
Only (JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey JobRead SMPayload
parent))
    pure (rowId :: Int64)
  void (run (HL.retryFromDLQ dlqId :: sm (Maybe (JobRead SMPayload))))
  mainCount >>= (`shouldBe` 3)
  dlqCount >>= (`shouldBe` 0)
  drainToEmpty @sm run 10
  mainCount >>= (`shouldBe` 0)

-- | A job carrying both a concurrency slot and a rate-limit key is admitted only
-- up to the tighter cap. Assumes 'smBucket' capacity 3 and the cap-a\/cap-c policies.
combinedGateGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
combinedGateGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
combinedGateGuard forall a. sm a -> IO a
run Text
schema forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO () -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
resetSeeded IO ()
reset Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  let insBoth :: Text -> Text -> Int -> IO ()
insBoth Text
conc Text
rate Int
count =
        sm () -> IO ()
forall a. sm a -> IO a
run
          ( Int -> sm () -> sm ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_
              Int
count
              ( sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
                  (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm (Extras -> JobWrite SMPayload -> JobWrite SMPayload
applyExtras (Maybe Text -> Maybe Text -> Extras
Extras (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
conc) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
rate))) Maybe Text
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Int
0 Maybe Int
forall a. Maybe a
Nothing)
              )
          )
      claimN :: Int -> IO [JobRead SMPayload]
claimN Int
limit = sm [JobRead SMPayload] -> IO [JobRead SMPayload]
forall a. sm a -> IO a
run (Int -> NominalDiffTime -> UUID -> sm [JobRead SMPayload]
forall payload (m :: * -> *).
QueueOperation m payload =>
Int -> NominalDiffTime -> UUID -> m [JobRead payload]
HL.claimNextVisibleJobsAs Int
limit NominalDiffTime
60 UUID
smWorker :: sm [JobRead SMPayload])
  -- Concurrency is the tighter gate. cap-a admits 1 and the bucket holds 3.
  Text -> Text -> Int -> IO ()
insBoth Text
"cap-a" Text
"rk-1" Int
4
  concCapped <- Int -> IO [JobRead SMPayload]
claimN Int
10
  length concCapped `shouldBe` 1
  -- Spend rk-2 to one token under the roomy cap-c policy.
  insBoth "cap-c" "rk-2" 2
  spent <- claimN 10
  length spent `shouldBe` 2
  run (traverse_ (void . HL.ackJob) spent)
  -- Ack frees the slots and leaves the tokens spent. Rate now caps the fresh batch.
  insBoth "cap-c" "rk-2" 3
  rateCapped <- claimN 10
  length rateCapped `shouldBe` 1

-- | Deterministic guard for the claim-trigger lock inversion. A claim's throttle
-- deferral row references a count row the claim never locked. The update trigger
-- leaves that row unlocked.
deferralLockOrderGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
deferralLockOrderGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
deferralLockOrderGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO () -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
resetSeeded IO ()
reset Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  let ins :: Maybe Text -> Maybe Text -> IO ()
ins Maybe Text
conc Maybe Text
rate = IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> IO Int64
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm (Extras -> JobWrite SMPayload -> JobWrite SMPayload
applyExtras (Maybe Text -> Maybe Text -> Extras
Extras Maybe Text
conc Maybe Text
rate)) Maybe Text
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Int
0 Maybe Int
forall a. Maybe a
Nothing))
      tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table
      concTbl :: Text
concTbl = Text -> Text
arbiterConcurrencyTable Text
schema
  -- The cap-a job is rate-denied on a drained bucket. The claim defers it without
  -- holding cap-a:s. The cap-b:s row parks the ordered scan between cap-a:s and
  -- cap-c:s. The cap-c job is admitted and the claim holds cap-c:s.
  Maybe Text -> Maybe Text -> IO ()
ins (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cap-a") (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"rk-1")
  Maybe Text -> Maybe Text -> IO ()
ins (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cap-c") Maybe Text
forall a. Maybe a
Nothing
  (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    Connection -> Text -> IO ()
execute_
      Connection
conn
      (Text
"UPDATE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
arbiterRateLimitsTable Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" SET tokens = 0, last_refill = NOW() WHERE rate_limit_key = 'smrl:rk-1'")
    Connection -> Text -> IO ()
execute_
      Connection
conn
      ( Text
"INSERT INTO "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
concTbl
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (concurrency_key, concurrency_prefix, in_flight) VALUES ('cap-b:s', 'cap-b', 0) ON CONFLICT (concurrency_key) DO NOTHING"
      )
  held <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  release <- newEmptyMVar
  holder <- async $ withConn $ \Connection
conn -> do
    Connection -> IO ()
PG.begin Connection
conn
    Connection -> Text -> Text -> IO ()
lockConcurrencyKey Connection
conn Text
concTbl Text
"cap-b:s"
    MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
held ()
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
release
    Connection -> IO ()
PG.commit Connection
conn
  takeMVar held
  -- The ordered scan locks cap-a:s, then parks on the held cap-b:s.
  reconciler <- async (void (run (HL.reconcileConcurrencyCounts :: sm Int64)))
  threadDelay parkMicros
  claimer <- async (run (HL.claimNextVisibleJobsAs 10 60 smWorker :: sm [JobRead SMPayload]))
  threadDelay parkMicros
  putMVar release ()
  wait holder
  claimedJobs <- wait claimer
  wait reconciler
  length claimedJobs `shouldBe` 1
  countQuery withConn ("SELECT count(*) FROM " <> tbl <> " WHERE throttled_until IS NOT NULL") >>= (`shouldBe` 1)

-- | The claimed_by-flip variant of 'deferralLockOrderGuard'. Deferring a
-- stale-leased job flips claimed_by and the trigger locks its count row. The
-- claim skips the deferral while another claimer holds that row.
deferralClaimedByFlipGuard
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -> IO ()
  -> IO ()
deferralClaimedByFlipGuard :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
deferralClaimedByFlipGuard forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  IO () -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
resetSeeded IO ()
reset Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  let ins :: Maybe Text -> Maybe Text -> IO ()
ins Maybe Text
conc Maybe Text
rate = IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> IO Int64
forall a. sm a -> IO a
run (forall (sm :: * -> *).
ArbiterC sm =>
(JobWrite SMPayload -> JobWrite SMPayload)
-> Maybe Text -> Maybe Int -> Int -> Maybe Int -> sm Int64
mkInsert @sm (Extras -> JobWrite SMPayload -> JobWrite SMPayload
applyExtras (Maybe Text -> Maybe Text -> Extras
Extras Maybe Text
conc Maybe Text
rate)) Maybe Text
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Int
0 Maybe Int
forall a. Maybe a
Nothing))
      tbl :: Text
tbl = Text -> Text -> Text
jobQueueTable Text
schema Text
table
      concTbl :: Text
concTbl = Text -> Text
arbiterConcurrencyTable Text
schema
      staleWorker :: Text
staleWorker = Text
"00000000-0000-0000-0000-000000000009" :: Text
  -- The cap-a job is a stale lease with a drained bucket. A claim would rate-defer
  -- it with a claimed_by flip. The cap-c job is admissible and the claim holds
  -- cap-c:s.
  Maybe Text -> Maybe Text -> IO ()
ins (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cap-a") (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"rk-1")
  Maybe Text -> Maybe Text -> IO ()
ins (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cap-c") Maybe Text
forall a. Maybe a
Nothing
  (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    Connection -> Text -> IO ()
execute_
      Connection
conn
      ( Text
"UPDATE "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tbl
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" SET claimed_by = '"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
staleWorker
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"', attempts = 1, not_visible_until = NOW() - interval '1 second' WHERE concurrency_key = 'cap-a:s'"
      )
    Connection -> Text -> IO ()
execute_
      Connection
conn
      (Text
"UPDATE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
arbiterRateLimitsTable Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" SET tokens = 0, last_refill = NOW() WHERE rate_limit_key = 'smrl:rk-1'")
  held <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  -- Hold cap-a:s like a concurrent claimer, then reach for the cap-c:s row the
  -- claim holds.
  holder <- async $ withConn $ \Connection
conn -> do
    Connection -> IO ()
PG.begin Connection
conn
    Connection -> Text -> Text -> IO ()
lockConcurrencyKey Connection
conn Text
concTbl Text
"cap-a:s"
    MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
held ()
    Int -> IO ()
threadDelay Int
claimReachMicros
    Connection -> Text -> Text -> IO ()
lockConcurrencyKey Connection
conn Text
concTbl Text
"cap-c:s"
    Connection -> IO ()
PG.commit Connection
conn
  takeMVar held
  claimedJobs <- run (HL.claimNextVisibleJobsAs 10 60 smWorker :: sm [JobRead SMPayload])
  wait holder
  length claimedJobs `shouldBe` 1
  countQuery withConn ("SELECT count(*) FROM " <> tbl <> " WHERE throttled_until IS NOT NULL") >>= (`shouldBe` 0)
  countQuery withConn ("SELECT count(*) FROM " <> tbl <> " WHERE claimed_by = '" <> staleWorker <> "'") >>= (`shouldBe` 1)

-- | Parameterized state-machine property suite. The runner executes a backend
-- action against the real database. @withConn@ exposes a raw 'PG.Connection' for
-- the oracle and HOL-detector SQL. @reset@ truncates the test tables.
-- The runner's registry must declare a queue for 'SMPayload' at the table name.
stateMachineSpec
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -- ^ Runner
  -> Text
  -> Text
  -> (forall a. (PG.Connection -> IO a) -> IO a)
  -- ^ Raw-connection accessor
  -> IO ()
  -- ^ Reset (truncate) action
  -> Spec
stateMachineSpec :: forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> Spec
stateMachineSpec forall a. sm a -> IO a
run Text
schema Text
table forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset = do
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"core engine invariants hold over random operation sequences" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    passed <- Property -> IO Bool
forall (m :: * -> *). MonadIO m => Property -> m Bool
check (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> Property
prop_engine @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
    passed `shouldBe` True
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"no serialization or summary violation under N concurrent generated streams" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
180 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Text -> Text -> IO ()
installHolDetector Connection
conn Text
schema Text
table
      passed <-
        Property -> IO Bool
forall (m :: * -> *). MonadIO m => Property -> m Bool
check (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> Property
prop_concurrent @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
          IO Bool -> IO () -> IO Bool
forall a b. IO a -> IO b -> IO a
`finally` (Connection -> IO ()) -> IO ()
forall a. (Connection -> IO a) -> IO a
withConn (\Connection
conn -> Connection -> Text -> Text -> IO ()
removeHolDetector Connection
conn Text
schema Text
table)
      passed `shouldBe` True
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"concurrent cross-group operations never deadlock" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
150 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
deadlockGuard @sm sm a -> IO a
forall a. sm a -> IO a
run IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an ack waking a parent in an earlier group does not deadlock with a multi-group insert" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrder @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
JobRead payload -> m Int64
HL.ackJob) sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch ack waking a parent in an earlier group does not deadlock with a multi-group insert" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrder @sm (sm [Int64] -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm [Int64] -> sm ())
-> (JobRead SMPayload -> sm [Int64]) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JobRead SMPayload] -> sm [Int64]
forall payload (m :: * -> *).
MonadArbiter m =>
[JobRead payload] -> m [Int64]
HL.ackJobsBatch ([JobRead SMPayload] -> sm [Int64])
-> (JobRead SMPayload -> [JobRead SMPayload])
-> JobRead SMPayload
-> sm [Int64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> [JobRead SMPayload]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a transaction creating a group row does not deadlock with a multi-group insert" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> (forall a. (Connection -> IO a) -> IO a) -> IO () -> IO ()
newGroupLockOrder @sm sm a -> IO a
forall a. sm a -> IO a
run (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a spawn into a later group does not deadlock with a multi-group insert" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> (forall a. (Connection -> IO a) -> IO a) -> IO () -> IO ()
spawnGroupLockOrder @sm sm a -> IO a
forall a. sm a -> IO a
run (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a rollup respawn does not deadlock with a delete of its dead-lettered child" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
respawnDLQDeleteLockOrder @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a DLQ retry re-suspending its parent does not deadlock with a delete of the same row" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
retryDLQDeleteLockOrder @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a DLQ retry re-suspending its parent does not deadlock with a cancel waking the same parent" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
retryDLQCancelLockOrder @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a cancel waking a parent in an earlier group does not deadlock with a multi-group insert" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs
      Int
30
      (forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrder @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.cancelJob @SMPayload (Int64 -> sm Int64)
-> (JobRead SMPayload -> Int64) -> JobRead SMPayload -> sm Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey) sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a dead-letter move waking a parent in an earlier group does not deadlock with a multi-group insert" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrder @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JobRead SMPayload -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
Text -> JobRead payload -> m Int64
HL.moveToDLQ Text
"sm dlq") sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch dead-letter move waking a parent in an earlier group does not deadlock with a multi-group insert" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs
      Int
30
      (forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrder @sm (\JobRead SMPayload
job -> sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ([(JobRead SMPayload, Text)] -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
[(JobRead payload, Text)] -> m Int64
HL.moveToDLQBatch [(JobRead SMPayload
job, Text
"sm dlq")])) sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a cascade cancel waking a parent in an earlier group does not deadlock with a multi-group insert" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs
      Int
30
      (forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrder @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.cancelJobCascade @SMPayload (Int64 -> sm Int64)
-> (JobRead SMPayload -> Int64) -> JobRead SMPayload -> sm Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey) sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch cancel waking a parent in an earlier group does not deadlock with a multi-group insert" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs
      Int
30
      (forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrder @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
[Int64] -> m Int64
HL.cancelJobsBatch @SMPayload ([Int64] -> sm Int64)
-> (JobRead SMPayload -> [Int64]) -> JobRead SMPayload -> sm Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> [Int64]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> [Int64])
-> (JobRead SMPayload -> Int64) -> JobRead SMPayload -> [Int64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey) sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a flagged-job delete waking a parent in an earlier group does not deadlock with a multi-group insert"
    (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ Int -> IO () -> IO ()
withinSecs Int
30
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ())
-> (JobRead SMPayload -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
crossGroupWakeLockOrderAfter @sm
      (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> (JobRead SMPayload -> sm Int64) -> JobRead SMPayload -> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall payload (m :: * -> *).
QueueOperation m payload =>
Int64 -> m Int64
HL.forceCancelJob @SMPayload (Int64 -> sm Int64)
-> (JobRead SMPayload -> Int64) -> JobRead SMPayload -> sm Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
Job payload key q insertedAt adm -> key
primaryKey)
      ( \JobRead SMPayload
job -> do
          deleted <- Text -> Text -> CancelledScope SMPayload -> sm [Int64]
forall (m :: * -> *) payload.
MonadArbiter m =>
Text -> Text -> CancelledScope payload -> m [Int64]
Ops.deleteCancelledJobs Text
schema Text
table (UUID -> [JobRead SMPayload] -> CancelledScope SMPayload
forall payload. UUID -> [JobRead payload] -> CancelledScope payload
Ops.HeldBy (Maybe UUID -> UUID
forall a. HasCallStack => Maybe a -> a
fromJust (JobRead SMPayload -> Maybe UUID
forall payload q insertedAt adm.
Job payload Int64 q insertedAt adm -> Maybe UUID
Job.claimedBy JobRead SMPayload
job)) [JobRead SMPayload
job])
          liftIO (deleted `shouldBe` [primaryKey job])
      )
      sm a -> IO a
forall a. sm a -> IO a
run
      Text
schema
      Text
table
      (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
      IO ()
reset
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch nack locks its rows descending" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
([JobRead SMPayload] -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
descendingSettleLockOrder @sm (sm [Int64] -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm [Int64] -> sm ())
-> ([JobRead SMPayload] -> sm [Int64])
-> [JobRead SMPayload]
-> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JobRead SMPayload] -> sm [Int64]
forall payload (m :: * -> *).
MonadArbiter m =>
[JobRead payload] -> m [Int64]
HL.nackJobsBatch) sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch ack locks its rows descending" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
30 (forall (sm :: * -> *).
ArbiterC sm =>
([JobRead SMPayload] -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
descendingSettleLockOrder @sm (sm [Int64] -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm [Int64] -> sm ())
-> ([JobRead SMPayload] -> sm [Int64])
-> [JobRead SMPayload]
-> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [JobRead SMPayload] -> sm [Int64]
forall payload (m :: * -> *).
MonadArbiter m =>
[JobRead payload] -> m [Int64]
HL.ackJobsBatch) sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch dead-letter move locks its rows descending" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs
      Int
30
      (forall (sm :: * -> *).
ArbiterC sm =>
([JobRead SMPayload] -> sm ())
-> (forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
descendingSettleLockOrder @sm (sm Int64 -> sm ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (sm Int64 -> sm ())
-> ([JobRead SMPayload] -> sm Int64)
-> [JobRead SMPayload]
-> sm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(JobRead SMPayload, Text)] -> sm Int64
forall payload (m :: * -> *).
MonadArbiter m =>
[(JobRead payload, Text)] -> m Int64
HL.moveToDLQBatch ([(JobRead SMPayload, Text)] -> sm Int64)
-> ([JobRead SMPayload] -> [(JobRead SMPayload, Text)])
-> [JobRead SMPayload]
-> sm Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JobRead SMPayload -> (JobRead SMPayload, Text))
-> [JobRead SMPayload] -> [(JobRead SMPayload, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (,Text
"sm dlq")) sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"concurrent spawns, dead-letter moves and cascade cancels never deadlock" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
150 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
spawnDeadlockGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"concurrent dedup moves and claims never double-claim a group" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
120 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
serializationGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"trigger-maintained group summary stays exact under concurrency without the reaper" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
120 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
concurrentDriftGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"exhausted jobs are capped by the claim guard and swept to the DLQ" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
exhaustionGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"rollup tree resumes on child completion and cascades to the DLQ" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
treeGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ineligible groups do not starve a productive group" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
starvationGuard @sm sm a -> IO a
forall a. sm a -> IO a
run IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a fixed workload fully drains under a fair claim loop" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
progressGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"expired-lease grouped job is reclaimable via triggers and after a reaper recompute" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
reclaimGuard @sm sm a -> IO a
forall a. sm a -> IO a
run IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the drift oracle accepts an expired lease's past in-flight time" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
expiredLeaseDriftGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a dedup-replaced job does not carry a stale claim owner" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
dedupReplaceStaleLeaseGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"promote leaves a live lease and a paused schedule alone" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
promoteLeaseGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"abandoned jobs are reclaimed and acked exactly once under concurrent workers" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
90 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
concurrentReclaimGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"claims honor priority order" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
priorityOrderGuard @sm sm a -> IO a
forall a. sm a -> IO a
run IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a freshly scheduled job becomes claimable when its delay elapses" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a) -> IO () -> IO ()
scheduledDueGuard @sm sm a -> IO a
forall a. sm a -> IO a
run IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a DLQ'd rollup tree is restored intact on retry and drains" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
treeRetryFromDLQGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"runGated skips within the interval and serializes concurrent callers" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 ((forall a. sm a -> IO a)
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
forall (sm :: * -> *).
MonadArbiter sm =>
(forall a. sm a -> IO a)
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
runGatedChecks sm a -> IO a
forall a. sm a -> IO a
run Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the combined rate and concurrency gate admits only up to the tighter cap" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
combinedGateGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a claim's throttle deferral does not deadlock with an ordered concurrency scan" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
deferralLockOrderGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a stale-leased job is not deferred while another claimer holds its count row" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    Int -> IO () -> IO ()
withinSecs Int
60 (forall (sm :: * -> *).
ArbiterC sm =>
(forall a. sm a -> IO a)
-> Text
-> Text
-> (forall a. (Connection -> IO a) -> IO a)
-> IO ()
-> IO ()
deferralClaimedByFlipGuard @sm sm a -> IO a
forall a. sm a -> IO a
run Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn IO ()
reset)