{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Parameterized stateful property-based tests for the core job engine, using
-- hedgehog. Works against any 'MonadArbiter' backend via a passed runner and a
-- raw-connection accessor.
--
-- Generates random sequences of engine operations against the real database
-- (insert at varying priority, scheduled insert, claim, ack, cancel, suspend,
-- resume, promote, retry, extend-lease, move-to-DLQ, retry-from-DLQ, batch
-- insert/cancel/DLQ, dedup insert, and the reaper) and checks the core
-- invariants after every step:
--
--   * at most one in-flight job per group (the serialization guarantee)
--   * no job exceeds its @max_attempts@
--   * no duplicate live @dedup_key@
--   * no concurrency key has more claimed-in-flight jobs than its effective cap
--   * every group summary column matches its recompute from the main table
--
-- Generated inserts also carry rate-limit keys and concurrency slots.
--
-- A second property ('prop_concurrent') generates N independent branches of
-- self-contained actions, runs them concurrently under a gap-free serialization
-- detector (a row trigger that fires inside every claim), then quiesces with a
-- reaper tick and asserts both the detector log and the full settled oracle are
-- clean. All contention is in the generated, shrinkable model.
-- Deterministic guards back the known-critical races.
module Arbiter.Test.StateMachine
  ( stateMachineSpec
  , SMPayload (..)
  , holViolTbl
  , holInstallSql
  , holRemoveSql
  ) where

import Arbiter.Core.Concurrency.Spec
  ( HasConcurrency (..)
  , concurrencyBy
  , concurrencyByCase
  , concurrencyPool
  , noConcurrency
  )
import Arbiter.Core.HighLevel qualified as HL
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)
import Arbiter.Core.Operations qualified as Ops
import Arbiter.Core.QueueRegistry (RegistryTables, TableForPayload)
import Arbiter.Core.RateLimit.Schema (toPolicyRow, upsertPolicyRowSQL)
import Arbiter.Core.RateLimit.Spec
  ( HasRateLimit (..)
  , Policy
  , limitBy
  , limitByCase
  , noLimit
  , tokenBucket
  )
import Barbies qualified as B
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
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 (atomicModifyIORef', newIORef, readIORef)
import Data.Int (Int32, Int64)
import Data.Kind (Type)
import Data.List (isInfixOf, nub)
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.String (fromString)
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, mapConcurrently, mapConcurrently_, wait)

import Arbiter.Test.Setup (execute_, seedConcurrencyPoolSQL)

-- | Constraints every HL-issuing helper in this module needs.
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)
-- ---------------------------------------------------------------------------

-- | Names of the head-of-line detector's table, function, and trigger.
holViolTbl, holFn, holTrigger :: 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"
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 job becomes in-flight while another @attempts > 0@ job in its group
-- already is. 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 > 0 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
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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
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
"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
          ]
  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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack 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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack 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
        (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack (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 ->
  IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Int64
PG.execute_ Connection
conn (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack (Text
"TRUNCATE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
holViolTbl Text
schema Text
table)))

-- Test schema and table names are plain lowercase identifiers. The SQL
-- interpolates them unquoted.
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] -> [String]
forall a. Semigroup a => a -> a -> a
(<>) ([String] -> [String] -> [String])
-> IO [String] -> IO ([String] -> [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 [String] -> IO [String]
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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

-- | 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
    toQuery :: Text -> Query
toQuery = String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> (Text -> String) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
    tbl :: Text
tbl = 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
    groupsTbl :: Text
groupsTbl = 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
"_groups"
    -- NOW() is evaluated once per statement. The recompute filters mirror the
    -- trigger definitions.
    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, 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)::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) 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 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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
serialSql))
  over <- PG.query_ conn (fromString (T.unpack overSql))
  dups <- PG.query_ conn (fromString (T.unpack dupSql))
  conc <- PG.query_ conn (fromString (T.unpack concSql))
  overSpent <- PG.query_ conn (fromString (T.unpack rlSql))
  rlMax <- PG.query_ conn (fromString (T.unpack 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
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table
    concPolicies :: Text
concPolicies = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".arbiter_concurrency_policies"
    rlBuckets :: Text
rlBuckets = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".arbiter_rate_limits"
    rlPolicies :: Text
rlPolicies = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".arbiter_rate_limit_policies"
    groupsTbl :: Text
groupsTbl = 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
"_groups"
    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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
jobsSql)) (Text -> Only Text
forall a. a -> Only a
Only Text
groupName)
      summ <- PG.query conn (fromString (T.unpack 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 attempts > 0"
        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
    -- pool override, else the pool 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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
orphanSql))
  pure ["orphaned child " <> show (jid :: Int64) <> " (parent gone)" | Only jid <- orphans]
  where
    tbl :: Text
tbl = 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
    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 pool 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 pools 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 pool. Each pool 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.
JobRecord 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
  , SMPayload -> Maybe Text
smConcSlot :: Maybe Text
  , SMPayload -> Maybe Text
smRateKey :: Maybe Text
  }
  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
concurrencyPool 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
concurrencyPool 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
concurrencyPool 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 :: Policy
smBucket :: Policy
smBucket = Text -> Double -> NominalDiffTime -> Policy
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 = Policy -> (payload -> Text) -> RateLimitFor payload
forall payload. Policy -> (payload -> Text) -> RateLimitFor payload
limitBy Policy
smBucket (Text -> payload -> Text
forall a b. a -> b -> a
const Text
"rk-1")
      rateSel SMRate
RateK2 = Policy -> (payload -> Text) -> RateLimitFor payload
forall payload. Policy -> (payload -> Text) -> RateLimitFor payload
limitBy Policy
smBucket (Text -> payload -> Text
forall a b. a -> b -> a
const Text
"rk-2")

-- | Seed the concurrency pools. Idempotent.
seedConcurrencyPools :: Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO ()
seedConcurrencyPools :: Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
seedConcurrencyPools 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
pool, Int32
limit) -> (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> (Text -> IO Int64) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> Query -> IO Int64
PG.execute_ Connection
conn (Query -> IO Int64) -> (Text -> Query) -> Text -> IO Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> (Text -> String) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Text -> Text -> Int32 -> [Text]
seedConcurrencyPoolSQL Text
schema Text
pool 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 ->
  IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Int64
PG.execute_ Connection
conn (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack (Text -> PolicyRow -> Text
upsertPolicyRowSQL Text
schema (Policy -> PolicyRow
toPolicyRow Policy
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 ()
seedConcurrencyPools 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 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] -> [Int64]
forall a. Eq a => [a] -> [a]
nub ((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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack 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
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
" 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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack 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
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
" 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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack 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
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
" 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 :: * -> *).
JobOperation m payload =>
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 :: * -> *).
JobOperation m payload =>
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 :: * -> *).
JobOperation m payload =>
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 :: * -> *).
JobOperation m payload =>
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 :: * -> *).
JobOperation m payload =>
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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack 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
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
"_dlq 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 = do
  let mkJob :: Text -> JobWrite SMPayload
mkJob 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
      children :: NonEmpty (JobWrite SMPayload)
children = Text -> JobWrite SMPayload
mkJob Text
"sm tree child 0" JobWrite SMPayload
-> [JobWrite SMPayload] -> NonEmpty (JobWrite SMPayload)
forall a. a -> [a] -> NonEmpty a
:| [Text -> JobWrite SMPayload
mkJob (Text
"sm tree child " 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
childCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
  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 (Text -> JobWrite SMPayload
mkJob Text
"sm tree parent" JobWrite SMPayload
-> NonEmpty (JobWrite SMPayload) -> JobTree SMPayload
forall payload.
JobWrite payload -> NonEmpty (JobWrite payload) -> JobTree payload
<~~ NonEmpty (JobWrite SMPayload)
children))

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 and sweep exhausted jobs to
-- the DLQ.
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])

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

claimThen :: forall sm. (ArbiterC sm) => (JobRead SMPayload -> sm ()) -> sm ()
claimThen :: forall (sm :: * -> *).
ArbiterC sm =>
(JobRead SMPayload -> sm ()) -> sm ()
claimThen JobRead SMPayload -> sm ()
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

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 :: * -> *).
JobOperation m payload =>
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 :: * -> *).
JobOperation m payload =>
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.
JobRecord 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.
JobRecord 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 :: * -> *).
JobOperation m payload =>
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 :: * -> *).
JobOperation m payload =>
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 :: * -> *).
JobOperation m payload =>
Text -> JobRead payload -> m Int64
HL.moveToDLQ Text
"conc dlq")

-- | 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
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
"_dlq 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
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
" 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
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
" 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
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
"_dlq 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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack (Text
"SELECT id FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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
"_dlq ORDER BY random() LIMIT 3")))
    pure [dlqId | Only dlqId <- rows]
  void (HL.deleteDLQJobsBatch @SMPayload ids)

-- | Run an action, retrying transient serialization and deadlock 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 or deadlock abort by the SQLSTATE in the
-- rendered message.
isRetryableError :: SomeException -> Bool
isRetryableError :: SomeException -> Bool
isRetryableError SomeException
err = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` SomeException -> String
forall a. Show a => a -> String
show SomeException
err) [String
"40P01", String
"40001"]

-- | Install the gap-free HOL detector through the raw-connection accessor.
installHolDetector :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO ()
installHolDetector :: Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
installHolDetector 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 ->
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> (Text -> IO Int64) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> Query -> IO Int64
PG.execute_ Connection
conn (Query -> IO Int64) -> (Text -> Query) -> Text -> IO Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> (Text -> String) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Text -> Text -> [Text]
holInstallSql Text
schema Text
table)

countHolViolations :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO [String]
countHolViolations :: Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
countHolViolations 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, Int64)]
forall r. FromRow r => Connection -> Query -> IO [r]
PG.query_ Connection
conn (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack (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
    ]

removeHolDetector :: Text -> Text -> (forall a. (PG.Connection -> IO a) -> IO a) -> IO ()
removeHolDetector :: Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
removeHolDetector 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 ->
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> (Text -> IO Int64) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> Query -> IO Int64
PG.execute_ Connection
conn (Query -> IO Int64) -> (Text -> Query) -> Text -> IO Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Query
forall a. IsString a => String -> a
fromString (String -> Query) -> (Text -> String) -> Text -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (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
        ]
  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
-- branches are shrinkable and reproducible from the seed. 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))
    (,) <$> countHolViolations schema table withConn <*> 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 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
            | String
"40P01" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` SomeException -> String
forall a. Show a => a -> String
show SomeException
err -> IORef Int -> (Int -> (Int, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Int
deadlocks (\Int
count -> (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, ()))
            | 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
      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
  -- Tolerate the rare residual race. A regression produces hundreds of deadlocks.
  deadlockCount `shouldSatisfy` (<= rounds `div` 100)

-- | 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
  Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
installHolDetector Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  (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 (Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
removeHolDetector Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn) (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 <- Text
-> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO [String]
countHolViolations Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
    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
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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 " <> tbl <> "_dlq")
  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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack (Text
"SELECT count(*) FROM " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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)))
    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
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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
tbl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_dlq")
      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 2_000_000
  void (run (HL.insertJob job))
  stale <-
    countQuery withConn $
      "SELECT count(*) FROM " <> 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 2_000_000
      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

-- | 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 ->
          IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Connection -> Query -> IO Int64
PG.execute_ Connection
conn (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack (Text
"TRUNCATE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".arbiter_gates"))))
  -- 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
  Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
installHolDetector Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
  (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 (Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
removeHolDetector Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn) (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 1_500_000
    -- 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.
JobRecord 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
    length (nub got) `shouldBe` total
    hol <- countHolViolations schema table withConn
    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.
JobRecord 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 1_500_000
  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
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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
tbl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_dlq")
      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 (String -> Query
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack (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
"_dlq WHERE job_id = ?"))) (Int64 -> Only Int64
forall a. a -> Only a
Only (JobRead SMPayload -> Int64
forall payload key q insertedAt adm.
JobRecord 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 pools.
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 pool.
  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
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table
      concTbl :: Text
concTbl = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".arbiter_concurrency"
  -- 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
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".arbiter_rate_limits 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 300_000
  claimer <- async (run (HL.claimNextVisibleJobsAs 10 60 smWorker :: sm [JobRead SMPayload]))
  threadDelay 300_000
  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
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
table
      concTbl :: Text
concTbl = Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".arbiter_concurrency"
      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
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".arbiter_rate_limits 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
600_000
    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.
stateMachineSpec
  :: forall sm
   . (ArbiterC sm)
  => (forall a. sm a -> IO a)
  -- ^ Runner
  -> Text
  -- ^ schemaName
  -> Text
  -- ^ tableName
  -> (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
      Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
installHolDetector Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
      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` Text -> Text -> (forall a. (Connection -> IO a) -> IO a) -> IO ()
removeHolDetector Text
schema Text
table (Connection -> IO a) -> IO a
forall a. (Connection -> IO a) -> IO a
withConn
      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
"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
"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)