core, plan: badge manager worker for monthly reissue

plans/badges-codes/2026-08-21-badges-web-checkout.md

@@ -146,7 +146,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat
 | B10 | Service integration tests | B7, B8 | ☑ |
 | C1 | `Store/Badges.hs`: client badge store | A1, A2 | ☑ |
 | C2 | Commands, responses, events, parsers, View | A2, B2, C1 | ☑ |
-| C3 | `BadgeManager` worker | C1, C2 | ☐ |
+| C3 | `BadgeManager` worker | C1, C2 | ☑ |
 | C4 | Redeem path wired end to end | B6, B7, B9, C3 | ☐ |
 | C5 | Client and service integration tests | B10, C4 | ☐ |
 | D0 | Store layer: orders, invoices, provider events | A3, A5, B1 | ☐ |
@@ -689,9 +689,7 @@ Phase C ends with a chat client that can redeem a code minted by B8 and show the
 **Do:** Reduced from core §6 to this scope.
 
 ```haskell
-newtype BadgeManager = BadgeManager
-  { badgeWorkers :: TMap UserId Worker    -- agent Worker: doWork TMVar, restart on crash
-  }
+badgeWorkers :: TMap UserId Worker    -- a ChatController field: agent Worker, doWork TMVar, restart on crash
 ```
 
 - Reuse the agent `Worker` framework from simplexmq's `Simplex.Messaging.Agent.Client`. `getAgentWorker` is used at `Library/Subscriber.hs:4024,4091,4331` (imported at `:82`); `hasWorkToDo'` and `cancelWorker` are exported by the same module but have no in-repo caller yet. The `TMap … Worker` controller fields follow `deliveryTaskWorkers` and `relayRequestWorkers` (`Controller.hs:307-309`).
@@ -699,7 +697,7 @@ newtype BadgeManager = BadgeManager
 - Add a `CLBadge UserId` constructor to `ChatLockEntity` (`Store/Shared.hs:68`), whose derived `Eq` and `Ord` still hold, and give it a branch in `enityLockString` (`Library/Commands.hs:3639-3646`): `CLBadge userId -> "Badge " <> tshow userId`. That case is exhaustive with no wildcard and the build uses `-Werror=incomplete-patterns` (`simplex-chat.cabal:338`), so the new constructor breaks the build until the branch exists.
 - Define `withBadgeLock :: Text -> UserId -> CM a -> CM a`, `withEntityLock name . CLBadge`, with an `INLINE` pragma, beside the existing wrappers at `Library/Internal.hs:133-139`, and lock every signed badge operation with it. There is no separate lock map: the badge lock is an ordinary entity lock over the shared `entityLocks` map (`Controller.hs:295`), so the `chatLock`-first order is inherited rather than reimplemented, and no new lock order is introduced.
 - The worker calls `sendBadgeRequest :: Maybe C.PrivateKeyEd25519 -> BadgeServiceRequest -> CM BadgeServiceResponse`, the single send path C4 implements in `Library/Commands.hs`. At this step it is a stub with that signature returning `BSPError` with code `internal` and the message `not implemented`, so the worker compiles and its mechanics are testable; C4 gives it the lazy connection and the signing.
-- Per pass, for the shown purchase: re-issue when the balance is positive and the month is unissued, by calling `issueBadge`. Apply the response with C1's writers, in one transaction: `insertLedgerEntries` for the statement verbatim, then `createIssuance` for the new period. The purchase row itself does not change on a re-issue, since it is already `issued`; only a new issuance row is written. Verify it with C2's `verifyUserBadge` before the transaction and call `setUserBadge` inside it, writing the `User` it returns to the `currentUser` TVar; a credential that fails verification is discarded and nothing is written. Release the badge lock, then call C2's `presentUserBadgeToContacts` with that `User`, which takes `chatLock`, so the monthly pass never broadcasts while holding a lock. Emit `CEvtBadgeChanged` on change.
+- Per pass, for the shown purchase: re-issue when the balance is positive and the month is unissued — the last ledger entry's `balanceMonths > 0` and `balanceStartTs <= now`, which is `issue`'s own guard and never the balance alone (B2) — by calling `issueBadge`, signed with the purchase's own key and carrying the purchase row's master key unchanged (§9). Apply the response with C1's writers, in one transaction: `insertLedgerEntries` for the statement verbatim, then `createIssuance` for the period the statement's last `debit(badge)` entry implies, with `ledgerEntryId = Nothing` (§9). The purchase row itself does not change on a re-issue, since it is already `issued`; only a new issuance row is written. Verify it with C2's `verifyUserBadge` before the transaction and call `setUserBadge` inside it, writing the `User` it returns to the `currentUser` TVar; a credential that fails verification is discarded and nothing is written. Release the badge lock, then call C2's `presentUserBadgeToContacts` with that `User`, which takes `chatLock`, so the monthly pass never broadcasts while holding a lock. Emit `CEvtBadgeChanged` on change.
 - A response with `credential = Nothing` is not an error: it is the exhausted balance B7 defines. Store the statement's ledger rows, write no issuance, leave the profile's badge as it is, and emit `CEvtBadgeChanged` only if the stored state changed. The pass is not suppressed afterwards: a pass on a zero balance reads the last ledger entry and stops, which is cheap, and suppressing it would need a re-arming signal that nothing sends.
 - Three things trigger a pass, and nothing else does:
   - the chat controller start signals every user's worker, beside the other worker starts in `startChatController`'s `start` block (`Library/Commands.hs:250-252`, `startDeliveryWorkers`, `startRelayRequestWorker_`, `startCleanupManager`), which has `users` in hand and so suits a per-user worker. `src/Simplex/Chat.hs:196-198,242-244` is `newChatController` and only initialises the maps;
@@ -708,7 +706,7 @@ newtype BadgeManager = BadgeManager
 - `hasWorkToDo'` signals the `doWork` TMVar in all three cases, and the timer is the badge worker's own loop rather than a shared scheduler. Tests drive a pass with `APIGetBadgeState` rather than the timer, so no test waits on wall-clock time.
 - Out of scope here: invoice reconciliation, store evidence, the alert timer, `CEvtBadgeAlert`, and Monday presentation. Those stay deferred in §6.
 
-**Verify:** In `tests/Bots/BadgeManagerTests.hs`, registered in the test stanza's `other-modules` and in `tests/Test.hs` under the **`Supporter badges`** path inside the `testBracket` bracket, so CI runs it (§4 rules 7 and 8): with a purchase row inserted by C1, calling the pass's apply-response function with a `BSPBadgeCredential` whose credential was signed by a test key through `Simplex.Chat.Badges.issueBadge`, against a controller started with `testCfg {badgePublicKeys = testBadgeKeys pk}` (`tests/ChatTests/Profiles.hs:295`), writes the issuance row and the statement's ledger rows and emits `CEvtBadgeChanged`; a credential signed by a different key is rejected and writes nothing; a response with `credential = Nothing` writes the ledger rows and no issuance; a second signal arriving during a pass does not run concurrently. No service is started, and no RPC is sent, so the test needs no stub point. `tests/BadgeTests.hs` cannot host this test, being a plain `Spec` (A2). The month-boundary re-issue against the live service is asserted in C5.
+**Verify:** In `tests/Bots/BadgeManagerTests.hs`, registered in the test stanza's `other-modules` and in `tests/Test.hs` under the **`Supporter badges`** path inside the `testBracket` bracket, so CI runs it (§4 rules 7 and 8): with a purchase row inserted by C1, composing the pass's two halves — `storeBadgeIssueResponse`, which the pass runs under the badge lock, and `presentBadgeChange`, which it runs with the lock released (§9) — over a `BSPBadgeCredential` whose credential was signed by a test key through `Simplex.Chat.Badges.issueBadge`, against a controller started with `testCfg {badgePublicKeys = testBadgeKeys pk}` (`tests/ChatTests/Profiles.hs:295`), writes the issuance row and the statement's ledger rows and emits `CEvtBadgeChanged`; a credential signed by a different key is rejected and writes nothing; a response with `credential = Nothing` writes the ledger rows and no issuance; a second signal arriving during a pass does not run concurrently. No service is started, and no RPC is sent, so the test needs no stub point. `tests/BadgeTests.hs` cannot host this test, being a plain `Spec` (A2). The month-boundary re-issue against the live service is asserted in C5.
 
 #### C4 — Redeem path wired end to end
 
@@ -1399,6 +1397,16 @@ Append here when a step contradicts this plan: the step id, what was wrong, and
 - **C2 — the new commands go in `undocumentedCommands`, not `cliCommands`, and neither list documents anything.** The step said to add them to `cliCommands` "so they reach `bots/api/COMMANDS.md` and both generated clients". Both lists are exemptions from `tests/APIDocs.hs:76`'s completeness check; a command reaches `COMMANDS.md` and the clients only through `chatCommandsDocs`. `cliCommands` holds the terminal-syntax commands and `undocumentedCommands` the `API*` ones, so the three `API*` commands go in the latter. The only regenerated files are therefore `bots/api/TYPES.md`, `types.ts` and `_types.py`, all three changed by `CEBadgeServiceError`/`BadgeServiceErrorCode` alone; `COMMANDS.md` and `EVENTS.md` are unchanged, and the step's Files line is corrected accordingly. Documenting the three commands properly belongs with C4, when they do something.
 - **C2 — the step's last manual check contradicts the step.** "`/_badge catalog 1` reaching the service at the overridden address" cannot hold while the same step stubs `APIGetBadgeCatalog` with `not implemented`. What was checked instead: `--badge-service-address` parses a contact link and is rejected when it is not one, `/_badge catalog 1` and `/_badge purchase 1 <json>` both return the stub `CEBadgeServiceError`, and the issuer-key override is exercised end to end through `/badge add` — a credential signed by a locally generated key at index 1 verifies with `--badge-issuer-key 1:KEY` and fails without it ("does not verify against configured key"), while a credential at index 2 fails with "unknown badge key index" when only index 1 is overridden, which is what proves REPLACE rather than merge. Verify corrected above. **C4 owns the reaching-the-service check.**
 - **C2 — `addUserBadge` reads `badgeCurrentTime`, not `getCurrentTime`.** The step introduces the field for C3 and C4 only. Wiring the one existing client-side badge clock read through it too costs nothing (the default is `getCurrentTime`, so `AddBadge` is unchanged) and means the field is load-bearing from the step that adds it rather than from the step that first needs to override it. **It has no behavioural test yet** — nothing in this step can observe a different clock — so C5 is the first place the override is proved to work.
+- **C3 — `badgeWorkers` is a `ChatController` field, not a `BadgeManager` record.** The step's code block wraps one `TMap UserId Worker` in a newtype, from core §6's five-field record; the other four fields (`badgeLocks`, `badgeReads`, `badgeBoundaries`, `badgeTimerAsync`) are all out of this step's scope — the lock is an ordinary entity lock over `entityLocks`, the timer is the worker's own loop, and the other two serve steps §6 defers — so the wrapper would wrap exactly one field and add an indirection at every use. The field sits beside `deliveryTaskWorkers` and `relayRequestWorkers`, which the same bullet says to follow.
+- **C3 — `badgeReads` is not added and `APIGetBadgeState` records nothing.** Core §6 has the command record its request time there; the only thing that reads that map is the lapsed-balance signed `getBadgeCatalog`, which this step does not send. The command signals the worker and stores nothing.
+- **C3 — the issued period is read from the statement's last `debit(badge)`, and no issuance is written without one.** The step says "`createIssuance` for the new period" without saying where the period comes from, and the wire carries neither end of it: the credential's expiry is `sundayAfter periodEnd`, which is not invertible, and `addMonths` is not additive under clamping, so stepping a month back from a balance start does not name the period either (the same trap `BadgeService.Service.resolveIssue` documents). `issue` sets `balanceStartTs` to the period's END and the service writes the `debit(badge)` last, so the statement's last entry gives `periodEnd` and the `balanceStartTs` in force immediately before it gives `periodStart` — from the entry before it in the statement, or from the last entry the client held. A statement carrying no `debit(badge)` still puts its credential on the profile, because a month the user paid for is never lost (B10), but writes no issuance row.
+- **C3 — `NewBadgeIssuance.ledgerEntryId` stays `Nothing`.** C1's entry above left this to C3. `badge_issuances.entry_id REFERENCES badge_ledger` has no `ON DELETE`, so linking issuances to local ledger rows would oblige every REPLACE to null those references before deleting — for a join nothing in this plan reads. The client's issuances therefore carry no ledger reference; the service's own rows still do.
+- **C3 — the master key of `issueBadge` is the purchase row's, never a freshly generated one.** The service does not check `badgeRequest.masterKey` against `badge_purchases.master_key` (§9, above), so a second redemption under the same purchase key with a rotated master key takes the cached-issuance path and is answered with a credential bound to the OLD key — unusable, and with no error raised anywhere. Keeping the key stable per purchase closes that from the client side, without a service change.
+- **C3 — the pass is two functions, split at the lock.** The step's Verify line names one "apply-response function", but the presentation must happen with the badge lock RELEASED (C2's `presentUserBadgeToContacts` takes `chatLock`), so the pass is `withBadgeLock … (… storeBadgeIssueResponse …) >>= presentBadgeChange`. Both halves are production functions and the tests compose them exactly as the pass does; only the stubbed send sits between them. C4's redeem path has the same obligation.
+- **C3 — the worker's timer is `race_` against `threadDelay'`, not `timeout`.** `badgePassInterval` is a `NominalDiffTime` (following `cleanupManagerInterval`) and its default of a day is 86,400,000,000 microseconds, which does not fit an `Int` on 32-bit builds; `threadDelay'` takes an `Int64` and chunks it, as the delivery and relay-request workers already use it. The loop waits on `takeTMVar doWork` racing that delay, so the signal is CONSUMED before the pass reads any state and a signal arriving during a pass runs one more pass rather than being swallowed by it.
+- **C3 — a badge request that fails is reported to the app.** Neither the step nor core §6 says what to do with a `BSPError` from a pass. It is surfaced with `eToView` as `CEBadgeServiceError`, as the delivery worker surfaces its failures, which is also what makes a pass observable to a test while `sendBadgeRequest` is a stub.
+- **C3 — `badgeCurrentTime` is proved by C3, not by C5.** C2's entry above says C5 is the first place the override is proved to work. It is proved here: `Bots.BadgeManagerTests` injects a clock that counts and gates the passes, which is what lets the worker tests be deterministic without waiting on `badgePassInterval` or on wall-clock time at all.
+- **C3 — the Postgres cross-check was not run for this step.** SQLite-only: `cabal test --test-options='-m "Supporter badges" -m "Badge service"'`, `CI` unset. The `--flags=client_postgres` cross-check B10 established is optional per-step and was skipped here rather than run; nothing in this step is guarded `#if !defined(dbPostgres)`, so there is no reason to expect a backend-specific gap, but it has not been exercised against Postgres and that remains open until it is.
 
 ## 10. End-to-end verification
 

simplex-chat.cabal

@@ -714,6 +714,7 @@ test-suite simplex-chat-test
       BadgeService.Store.Migrate
       Bots.BadgeCodeTests
       Bots.BadgeLedgerTests
+      Bots.BadgeManagerTests
       Bots.BadgeServiceTests
       Bots.BadgeStoreTests
       Broadcast.Bot

src/Simplex/Chat.hs

@@ -82,6 +82,7 @@ defaultChatConfig =
       badgeServiceAddress = Nothing,
       badgeWebBaseUrl = "",
       badgeCurrentTime = getCurrentTime,
+      badgePassInterval = nominalDay,
       confirmMigrations = MCConsole,
       -- this property should NOT use operator = Nothing
       -- non-operator servers can be passed via options
@@ -202,6 +203,7 @@ newChatController
         deliveryTaskWorkers <- TM.emptyIO
         deliveryJobWorkers <- TM.emptyIO
         relayRequestWorkers <- TM.emptyIO
+        badgeWorkers <- TM.emptyIO
         relayGroupLinkChecksAsync <- newTVarIO Nothing
         webPreviewState <- forM webPreviewConfig $ \_ -> newWebPreviewState
         chatRelayTests <- TM.emptyIO
@@ -248,6 +250,7 @@ newChatController
               deliveryTaskWorkers,
               deliveryJobWorkers,
               relayRequestWorkers,
+              badgeWorkers,
               relayGroupLinkChecksAsync,
               webPreviewState,
               chatRelayTests,

src/Simplex/Chat/Controller.hs

@@ -160,6 +160,10 @@ data ChatConfig = ChatConfig
     -- sleeping. Defaults to 'getCurrentTime'; nothing but a test ever replaces it. This is the
     -- client twin of @BadgeServiceOpts.serviceClock@.
     badgeCurrentTime :: IO UTCTime,
+    -- | How long a badge worker waits for a signal before running a pass anyway. A month
+    -- boundary is the only event the pass waits for, so a daily wake is frequent enough; a pass
+    -- with the current month already issued reads one ledger row and stops.
+    badgePassInterval :: NominalDiffTime,
     confirmMigrations :: MigrationConfirmation,
     presetServers :: PresetServers,
     shortLinkPresetServers :: NonEmpty SMPServer,
@@ -325,6 +329,10 @@ data ChatController = ChatController
     deliveryTaskWorkers :: TMap DeliveryWorkerKey Worker,
     deliveryJobWorkers :: TMap DeliveryWorkerKey Worker,
     relayRequestWorkers :: TMap Int Worker, -- single global worker with key 1 is used to fit into existing worker management framework
+    -- | The 'BadgeManager': one worker per user, because badge state is per profile. The worker
+    -- holds no queue — a trigger only signals its @doWork@, and each pass derives its work from
+    -- the stored purchase and ledger, so lost and duplicated signals are harmless.
+    badgeWorkers :: TMap UserId Worker,
     relayGroupLinkChecksAsync :: TVar (Maybe (Async ())),
     webPreviewState :: Maybe WebPreviewState,
     chatRelayTests :: TMap ConnId RelayTest,

src/Simplex/Chat/Library/Commands.hs

@@ -56,10 +56,22 @@ import Data.Type.Equality
 import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as V4
 import Simplex.Chat.Library.Subscriber
-import Simplex.Chat.Badges (BadgeCredential (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential)
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeRequest (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential)
 import Simplex.Chat.Badges.Months (addMonths)
-import Simplex.Chat.Badges.Service (BadgeServiceErrorCode (..))
-import Simplex.Chat.Badges.Types (BadgeLedgerEntry (..), UserBadge (..), UserBadgeState (..))
+import Simplex.Chat.Badges.Service
+  ( BadgeBalance (..),
+    BadgeServiceCommand (..),
+    BadgeServiceErrorCode (..),
+    BadgeServiceRequest (..),
+    BadgeServiceResponse (..),
+    BadgeStatement (..),
+    StatementCreditType (..),
+    StatementDebitType (..),
+    StatementEntry (..),
+    StatementEntryType (..),
+    currentBadgeVersion,
+  )
+import Simplex.Chat.Badges.Types (BadgeLedgerEntry (..), LedgerCreditType (..), LedgerDebitType (..), LedgerEntryType (..), UserBadge (..), UserBadgeState (..))
 import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
@@ -80,7 +92,7 @@ import Simplex.Chat.Library.Internal
 import Simplex.Chat.Stats
 import Simplex.Chat.Store
 import Simplex.Chat.Store.AppSettings
-import Simplex.Chat.Store.Badges (UserBadgePurchase (..), getLastBadgeLedgerEntry, getShownPurchase)
+import Simplex.Chat.Store.Badges (NewBadgeIssuance (..), UserBadgePurchase (..), createIssuance, getLastBadgeLedgerEntry, getShownPurchase, insertLedgerEntries)
 import Simplex.Chat.Store.ContactRequest
 import Simplex.Chat.Store.Connections
 import Simplex.Chat.Store.Delivery
@@ -99,7 +111,8 @@ import qualified Simplex.Chat.Util as U
 import Simplex.Chat.Web (webPreviewWorker)
 import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSizeHard)
 import Simplex.Messaging.Agent
-import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
+import Simplex.Messaging.Agent.Client (cancelWorker, getAgentWorker)
+import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), Worker (..), allRoles)
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.Store.Entity
 import Simplex.Messaging.Agent.Store.Interface (execSQL)
@@ -254,6 +267,7 @@ startChatController mainApp enableSndFiles serviceRequests = do
           startDeliveryWorkers
           startRelayRequestWorker_
           startCleanupManager
+          startBadgeWorkers users
           void $ forkIO $ mapM_ startExpireCIs users
           startRelayChecks users
           startWebPreview users
@@ -350,7 +364,11 @@ restoreCalls = do
   atomically $ writeTVar calls callsMap
 
 stopChatController :: ChatController -> IO ()
-stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do
+stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, badgeWorkers} = do
+  -- the map is swapped out BEFORE the workers are cancelled: 'cancelWorker' leaves a worker's
+  -- action TMVar empty, so one left in the map would make the next 'getBadgeWorker' for that
+  -- user block on it forever
+  atomically (swapTVar badgeWorkers M.empty) >>= mapM_ cancelWorker
   readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd)
   atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd)
   disconnectAgentClient smpAgent
@@ -3559,6 +3577,9 @@ processChatCommand cxt nm = \case
   APIGetBadgeState userId -> withUserId userId $ \user -> do
     badgeState <- getUserBadgeState user
     ChatConfig {badgeWebBaseUrl} <- asks config
+    -- the badge screen opening or regaining focus is one of the three triggers of a pass, so a
+    -- profile that has just crossed a month boundary re-issues without waiting for the timer
+    lift $ void $ getBadgeWorker True userId
     pure CRBadgeState {user, badgeState, badgeWebBaseUrl}
   APIGetBadgeCatalog _ -> throwChatError badgeNotImplemented
   APIPurchaseBadge {} -> throwChatError badgeNotImplemented
@@ -3664,6 +3685,7 @@ processChatCommand cxt nm = \case
         CLUserContact ucId -> "UserContact " <> tshow ucId
         CLContactRequest crId -> "ContactRequest " <> tshow crId
         CLFile fId -> "File " <> tshow fId
+        CLBadge uId -> "Badge " <> tshow uId
   DebugEvent event -> toView event >> ok_
   GetAgentSubsTotal userId -> withUserId userId $ \user -> do
     users <- withStore' $ \db -> getUsers db
@@ -5176,11 +5198,20 @@ getUserBadgeState User {userId} = withFastStore $ \db ->
 badgePaidThrough :: BadgeLedgerEntry -> UTCTime
 badgePaidThrough BadgeLedgerEntry {balanceMonths, balanceStartTs} = addMonths balanceMonths balanceStartTs
 
+-- | A badge failure that is the CLIENT's own, reported in the shape a service failure is
+-- reported in: no 'BadgeServiceErrorCode' denotes a local failure, so it is 'BSEInternal' with
+-- the reason as the message.
+localBadgeError :: Text -> ChatErrorType
+localBadgeError t = CEBadgeServiceError {badgeError = BSEInternal, badgeErrorMessage = Just t, retryAfter = Nothing}
+
 -- | The placeholder failure of the badge commands C4 implements. It is a 'CEBadgeServiceError'
 -- rather than a command error because that is the error C4 raises from them, so the stub does
 -- not train a client to expect a different shape from the one it will get.
 badgeNotImplemented :: ChatErrorType
-badgeNotImplemented = CEBadgeServiceError {badgeError = BSEInternal, badgeErrorMessage = Just "not implemented", retryAfter = Nothing}
+badgeNotImplemented = localBadgeError notImplementedMessage
+
+notImplementedMessage :: Text
+notImplementedMessage = "not implemented"
 
 -- | Checks that a credential was signed by a configured issuer key.
 --
@@ -5224,6 +5255,247 @@ addUserBadge user cred@(BadgeCredential _ _ _ info) = do
   asks currentUser >>= atomically . (`writeTVar` Just user')
   presentUserBadgeToContacts user'
 
+-- BadgeManager ----------------------------------------------------------------
+--
+-- One worker per user (badge state is per profile), over the agent 'Worker' framework the
+-- controller already uses for delivery and relay requests. The worker holds no queue: a trigger
+-- only signals its @doWork@, and each pass derives its work from the stored purchase and its
+-- ledger, so lost and duplicated signals are harmless.
+
+-- | The badge worker of one user, creating it if it has none; @hasWork@ signals a pass.
+--
+-- Two of the three triggers signal through this call — chat start ('startBadgeWorkers') and
+-- @APIGetBadgeState@ — and nothing else does. The third is the worker's own timer, which is
+-- inside 'runBadgeWorker' rather than a signal.
+getBadgeWorker :: Bool -> UserId -> CM' Worker
+getBadgeWorker hasWork userId = do
+  ws <- asks badgeWorkers
+  a <- asks smpAgent
+  getAgentWorker "badge" hasWork a userId ws $ runBadgeWorker userId
+
+-- | Signals every user's badge worker at chat start, beside the other worker starts: a profile
+-- that crossed a month boundary while the app was closed re-issues without waiting for the timer.
+startBadgeWorkers :: [User] -> CM' ()
+startBadgeWorkers = mapM_ $ \User {userId} -> void $ getBadgeWorker True userId
+
+-- | The worker loop: wait for a signal or for 'badgePassInterval' to elapse, then run one pass.
+--
+-- The signal is TAKEN rather than read, and taken before the pass reads any state, so a signal
+-- arriving while a pass runs is not consumed by it and runs one more pass afterwards. Two
+-- passes for one user therefore never overlap: the framework runs one thread per worker, and
+-- that thread is here.
+--
+-- The timer is this loop's own wait rather than a shared scheduler, and it is 'threadDelay''
+-- rather than 'timeout' because a day in microseconds does not fit an 'Int' on 32-bit builds.
+runBadgeWorker :: UserId -> Worker -> CM ()
+runBadgeWorker userId Worker {doWork} = do
+  interval <- asks $ badgePassInterval . config
+  forever $ do
+    liftIO $ race_ (atomically $ takeTMVar doWork) (threadDelay' $ diffToMicroseconds interval)
+    badgeManagerPass userId `catchAllErrors` eToView
+
+-- | One pass for one user: the signed half under the per-user badge lock, then its presentation
+-- and event OUTSIDE that lock, since 'presentUserBadgeToContacts' takes 'chatLock'.
+badgeManagerPass :: UserId -> CM ()
+badgeManagerPass userId = do
+  user <- withFastStore (`getUser` userId)
+  withBadgeLock "badgeManagerPass" userId (issueDueBadgePeriod user) >>= presentBadgeChange
+
+-- | Re-issues the shown purchase's current month when its balance funds one and the month is
+-- unissued. Everything it does — the state it reads, the request it sends and the rows it
+-- writes — happens under the per-user badge lock, so it cannot interleave with a command that
+-- sends a signed badge request for the same profile.
+issueDueBadgePeriod :: User -> CM BadgeChange
+issueDueBadgePeriod user@User {userId} = do
+  now <- liftIO =<< asks (badgeCurrentTime . config)
+  -- the purchase and its last entry are read in ONE transaction, so the balance asserted to the
+  -- service cannot be from a ledger that changed between the two reads
+  due_ <- withFastStore $ \db ->
+    getShownPurchase db userId >>= \case
+      Nothing -> pure Nothing
+      Just p@UserBadgePurchase {badgePurchaseId = pId} -> Just . (p,) <$> getLastBadgeLedgerEntry db pId
+  case due_ of
+    Just (purchase@UserBadgePurchase {purchasePrivKey}, Just lastEntry)
+      | badgePeriodDue now lastEntry -> do
+          balance <- assertedBadgeBalance lastEntry
+          resp <- sendBadgeRequest (Just purchasePrivKey) (badgeIssueRequest purchase balance)
+          storeBadgeIssueResponse now user purchase (Just lastEntry) resp
+    _ -> pure BadgeUnchanged
+
+-- | Whether the month the balance would fund is unissued: a positive balance whose coverage
+-- window has already started.
+--
+-- This is @BadgeService.Ledger.issue@'s own guard, applied to the last entry the client holds.
+-- A previous issue moved 'balanceStartTs' to the END of the period it issued, so
+-- @balanceStartTs > now@ means the current month is already issued — and that is why the two
+-- reasons not to issue must be told apart by 'balanceStartTs' and never by the balance alone:
+-- once the last funded month has been issued both hold at once.
+badgePeriodDue :: UTCTime -> BadgeLedgerEntry -> Bool
+badgePeriodDue now BadgeLedgerEntry {balanceMonths, balanceStartTs} = balanceMonths > 0 && balanceStartTs <= now
+
+-- | The balance assertion of @issueBadge@: the last entry the client holds, back in the shape it
+-- arrived in. The service matches it by @entryId@ and returns what follows it; a mismatch is
+-- healed on the service side and answered with the complete history or an @opening@ credit.
+--
+-- The three entry types that cannot be put back on the wire are refused rather than coerced:
+-- they carry a purchase KEY where the stored columns hold a purchase id, or an @Int64@ charge id
+-- against a TEXT one, exactly as 'Simplex.Chat.Store.Badges' refuses them in the other
+-- direction. Nothing can write such a row today, so this raises a chat error rather than
+-- branching the pass.
+assertedBadgeBalance :: BadgeLedgerEntry -> CM BadgeBalance
+assertedBadgeBalance BadgeLedgerEntry {entryUuid, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, serviceCreatedAt, entryType} = do
+  entryType' <- either (throwChatError . localBadgeError) pure $ wireEntryType entryType
+  pure . BadgeBalance $
+    StatementEntry
+      { entryId = entryUuid,
+        changeMonths,
+        balanceMonths,
+        balanceStartTs,
+        balanceBadgeType,
+        wasPausedSince,
+        -- the wire's createdAt is the SERVICE's clock, which is the column the replica keeps it
+        -- in; created_at is when this client replicated the row and is not the service's to read
+        createdAt = serviceCreatedAt,
+        entryType = entryType'
+      }
+
+-- | The inverse of 'Simplex.Chat.Store.Badges.storedEntryType', for the one entry the client
+-- asserts back to the service. @credit(payment)@ loses nothing on the way out: the stored
+-- @payment_id@ is a CLIENT payments id and the wire field is the SERVICE's @invoiceId@, which a
+-- replicated entry never carries.
+wireEntryType :: LedgerEntryType -> Either Text StatementEntryType
+wireEntryType = \case
+  LECredit creditType -> SECredit <$> case creditType of
+    CTPayment {} -> Right SCPayment {invoiceId = Nothing}
+    CTSupport -> Right SCSupport
+    CTOpening -> Right SCOpening
+    CTUnknown {tag, json} -> Right SCUnknown {tag, json}
+    CTCharge {} -> unsupported "credit(charge)"
+    CTTransferIn {} -> unsupported "credit(transferIn)"
+  LEDebit debitType -> SEDebit <$> case debitType of
+    DTRefund -> Right SDRefund
+    DTSupport -> Right SDSupport
+    DTBadge -> Right SDBadge
+    DTLapse -> Right SDLapse
+    DTUnknown {tag, json} -> Right SDUnknown {tag, json}
+    DTUpgrade {} -> unsupported "debit(upgrade)"
+    DTTransferOut {} -> unsupported "debit(transferOut)"
+  where
+    unsupported what = Left $ "cannot assert badge ledger " <> what <> " to the badge service"
+
+-- | The @issueBadge@ request for a purchase, signed by that purchase's key.
+--
+-- __The master key is the purchase row's, never a freshly generated one.__ The service does not
+-- check the master key of an @issueBadge@ against the one it recorded for the purchase, and a
+-- request that rotated it would take the service's cached-issuance path and be answered with a
+-- credential bound to the OLD key — unusable, with no error raised anywhere. Keeping it stable
+-- per purchase key closes that from this side.
+--
+-- 'badgeExpiry' is left absent and 'badgeExtra' empty: the service overrides the expiry with its
+-- own (the Sunday after the period it issues) and refuses a non-empty extra.
+badgeIssueRequest :: UserBadgePurchase -> BadgeBalance -> BadgeServiceRequest
+badgeIssueRequest UserBadgePurchase {purchaseKey, masterKey, currentBadgeType} balance =
+  BadgeServiceRequest
+    { version = currentBadgeVersion,
+      purchaseKey = Just purchaseKey,
+      request =
+        BSCIssueBadge
+          { badgeRequest = BadgeRequest {masterKey, badgeInfo = BadgeInfo {badgeType = currentBadgeType, badgeExpiry = Nothing, badgeExtra = ""}},
+            balance
+          }
+    }
+
+-- | The single send path to the badge service, which C4 replaces with the lazy connection and
+-- the signing. Until then every badge request fails locally, which is what the two stub command
+-- handlers already report.
+sendBadgeRequest :: Maybe C.PrivateKeyEd25519 -> BadgeServiceRequest -> CM BadgeServiceResponse
+sendBadgeRequest _signKey _request = pure BSPError {code = BSEInternal, message = Just notImplementedMessage, retryAfter = Nothing}
+
+-- | What one applied badge response changed, which is what decides what happens once the badge
+-- lock is released.
+data BadgeChange
+  = -- | Nothing was written: no work, a service error, or a credential that failed verification.
+    BadgeUnchanged
+  | -- | Ledger rows were stored and the profile's own badge is untouched — the exhausted
+    -- balance, which is not an error.
+    BadgeLedgerChanged User
+  | -- | A new credential is on the profile, so it is presented to contacts as well as reported.
+    BadgeIssued User
+
+-- | Applies one @issueBadge@ response, in ONE transaction, and reports what it changed.
+--
+-- The caller must hold the per-user badge lock and must NOT hold it while passing the result to
+-- 'presentBadgeChange'.
+--
+-- A credential that fails verification is discarded and NOTHING is written, the statement
+-- included: a response whose credential is not ours is not a response to trust the rest of. An
+-- absent credential is the opposite — the exhausted balance the service defines, whose statement
+-- is stored like any other.
+storeBadgeIssueResponse :: UTCTime -> User -> UserBadgePurchase -> Maybe BadgeLedgerEntry -> BadgeServiceResponse -> CM BadgeChange
+storeBadgeIssueResponse now user UserBadgePurchase {badgePurchaseId = pId} heldEntry_ = \case
+  BSPBadgeCredential {credential = Nothing, statement} -> do
+    withStore $ \db -> insertLedgerEntries db pId statement now
+    ledgerChange
+  BSPBadgeCredential {credential = Just cred, statement} ->
+    verifyUserBadge cred >>= \case
+      Left e -> badgeFailed e
+      Right () -> case cred of
+        BadgeCredential {badgeInfo = info@BadgeInfo {badgeType, badgeExpiry = Just expiry}} -> do
+          user' <- withStore $ \db -> do
+            insertLedgerEntries db pId statement now
+            -- the issuance is written only for a statement that carries the period it issued;
+            -- ledgerEntryId stays absent (see 'issuedBadgePeriod' and plan §9)
+            forM_ (issuedBadgePeriod heldEntry_ statement) $ \(periodStart, periodEnd) ->
+              liftIO . void $
+                createIssuance db NewBadgeIssuance {badgePurchaseId = pId, badgeType, periodStart, periodEnd, expiry, ledgerEntryId = Nothing, credential = cred} now
+            liftIO $ setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info)))
+          asks currentUser >>= atomically . (`writeTVar` Just user')
+          pure $ BadgeIssued user'
+        -- 'issueSignedBadge' always sets the expiry, so this is a malformed response rather than
+        -- a lifetime credential, and a lifetime badge has no issuance row to write anyway
+        _ -> badgeFailed "issued badge credential carries no expiry"
+  BSPError {code, message, retryAfter} ->
+    BadgeUnchanged <$ eToView (ChatError CEBadgeServiceError {badgeError = code, badgeErrorMessage = message, retryAfter})
+  r -> badgeFailed $ "unexpected badge service response to issueBadge: " <> tshow r
+  where
+    badgeFailed e = BadgeUnchanged <$ eToView (ChatError $ localBadgeError e)
+    -- the ledger the statement left, against the one that was held: nothing else the badge state
+    -- reports comes from the ledger, so an unchanged last entry is an unchanged state
+    ledgerChange = do
+      lastEntry_ <- withFastStore $ \db -> getLastBadgeLedgerEntry db pId
+      pure $ if ledgerPosition lastEntry_ == ledgerPosition heldEntry_ then BadgeUnchanged else BadgeLedgerChanged user
+    ledgerPosition = fmap $ \BadgeLedgerEntry {entryUuid, balanceMonths, balanceStartTs} -> (entryUuid, balanceMonths, balanceStartTs)
+
+-- | The period a statement issued, when it carries one.
+--
+-- The service writes the @debit(badge)@ LAST, after any lapse and credit, and @issue@ sets
+-- 'balanceStartTs' to the period's END, so the last entry's 'balanceStartTs' is the period end
+-- and the one in force immediately before it is the period start. That predecessor is the entry
+-- before it in the statement, or, for a statement that appends, the last entry the client
+-- already held. A complete history that contains a @debit(badge)@ always contains it: a balance
+-- can only have become positive through a credit entry.
+--
+-- The period is NOT derived from the credential: its expiry is the Sunday after the period end,
+-- and that is not invertible.
+issuedBadgePeriod :: Maybe BadgeLedgerEntry -> BadgeStatement -> Maybe (UTCTime, UTCTime)
+issuedBadgePeriod heldEntry_ BadgeStatement {entries} = case reverse entries of
+  StatementEntry {entryType = SEDebit SDBadge, balanceStartTs = periodEnd} : earlier -> (,periodEnd) <$> periodStart earlier
+  _ -> Nothing
+  where
+    periodStart (StatementEntry {balanceStartTs} : _) = Just balanceStartTs
+    periodStart [] = (\BadgeLedgerEntry {balanceStartTs} -> balanceStartTs) <$> heldEntry_
+
+-- | The pass's unlocked half: a new credential is presented to contacts, and any change at all
+-- is reported to the app. It must be called with the per-user badge lock RELEASED, because
+-- 'presentUserBadgeToContacts' takes 'chatLock'.
+presentBadgeChange :: BadgeChange -> CM ()
+presentBadgeChange = \case
+  BadgeUnchanged -> pure ()
+  BadgeLedgerChanged user -> badgeChanged user
+  BadgeIssued user -> presentUserBadgeToContacts user >> badgeChanged user
+  where
+    badgeChanged user = toView . CEvtBadgeChanged user =<< getUserBadgeState user
+
 assertDirectAllowed :: User -> MsgDirection -> Contact -> CMEventTag e -> CM ()
 assertDirectAllowed user dir ct event =
   unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $

src/Simplex/Chat/Library/Internal.hs

@@ -159,6 +159,18 @@ withFileLock :: Text -> Int64 -> CM a -> CM a
 withFileLock name = withEntityLock name . CLFile
 {-# INLINE withFileLock #-}
 
+-- | Serializes the signed badge operations of one profile: the 'BadgeManager' pass and every
+-- command that sends a signed badge request take it, so one such operation per user is in
+-- flight and no two of them interleave their reads and writes of that profile's badge rows.
+--
+-- It is an ordinary entity lock over the shared 'entityLocks' map, so it inherits the
+-- @chatLock@-first order rather than introducing one. A holder must RELEASE it before calling
+-- anything that takes @chatLock@ itself — 'Simplex.Chat.Library.Commands.presentUserBadgeToContacts'
+-- in particular.
+withBadgeLock :: Text -> UserId -> CM a -> CM a
+withBadgeLock name = withEntityLock name . CLBadge
+{-# INLINE withBadgeLock #-}
+
 useServerCfgs :: forall p. UserProtocol p => SProtocolType p -> RandomAgentServers -> [(Text, ServerOperator)] -> [UserServer p] -> NonEmpty (ServerCfg p)
 useServerCfgs p RandomAgentServers {smpServers, xftpServers} opDomains =
   fromMaybe (rndAgentServers p) . L.nonEmpty . agentServerCfgs p opDomains

src/Simplex/Chat/Store/Shared.hs

@@ -73,6 +73,10 @@ data ChatLockEntity
   | CLUserContact Int64
   | CLContactRequest Int64
   | CLFile Int64
+  | -- | One signed badge operation per profile at a time: the monthly issuance pass and the
+    -- commands that send signed badge requests all take it, so they cannot interleave their
+    -- reads and writes of that profile's purchase, ledger and badge rows.
+    CLBadge UserId
   deriving (Eq, Ord)
 
 -- These error type constructors must be added to mobile apps

tests/Bots/BadgeManagerTests.hs

@@ -0,0 +1,324 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | Tests for the @BadgeManager@ worker: what one pass writes when a response is applied, and
+-- that the signals arriving during a pass run one more pass rather than a concurrent one.
+--
+-- Registered under the "Supporter badges" hspec path so CI runs it (plan §4 rule 8), inside
+-- 'testBracket', which is what gives these tests a chat controller. No badge service is started
+-- and no RPC is sent: 'sendBadgeRequest' is C3's stub, so the tests apply a response to the pass
+-- directly, composing the pass's two production halves ('storeBadgeIssueResponse' under the
+-- badge lock in production, then 'presentBadgeChange' outside it) exactly as
+-- 'issueDueBadgePeriod' and 'badgeManagerPass' compose them.
+--
+-- __No test waits on 'badgePassInterval'.__ A pass is driven by @\/_badge state@ (which signals
+-- the worker) and paced by the injected 'badgeCurrentTime', which every pass reads exactly once
+-- before it reads any state — so the test can count passes and hold one open without sleeping.
+module Bots.BadgeManagerTests (badgeManagerTests) where
+
+import ChatClient
+import ChatTests.DBUtils
+import ChatTests.Profiles (testBadgeKeys)
+import ChatTests.Utils
+import Control.Concurrent.STM (retry)
+import Control.Monad (forM_, unless)
+import Control.Monad.Except (runExceptT)
+import Control.Monad.Reader (runReaderT)
+import qualified Data.Aeson as J
+import Data.ByteString (ByteString)
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Time.Calendar (fromGregorian)
+import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeRequest (..), BadgeType (..), VerifiedBadgeRequest (..), generateMasterKey, issueBadge)
+import Simplex.Chat.Badges.Months (addMonths, sundayAfter)
+import Simplex.Chat.Badges.Service
+  ( BadgeServiceResponse (..),
+    BadgeStatement (..),
+    StatementCreditType (..),
+    StatementDebitType (..),
+    StatementEntry (..),
+    StatementEntryType (..),
+  )
+import Simplex.Chat.Badges.Types (BadgeLedgerEntry (..))
+import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), CM)
+import Simplex.Chat.Library.Commands (presentBadgeChange, storeBadgeIssueResponse)
+import Simplex.Chat.Store.Badges (UserBadgePurchase (..), createCodePayment, createPurchase, getLastBadgeLedgerEntry, insertLedgerEntries, setShownPurchase)
+import Simplex.Chat.Types (User (..))
+import Simplex.Messaging.Agent.Store.Common (withTransaction)
+import Simplex.Messaging.Agent.Store.DB (Binary (..))
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen)
+import Test.Hspec hiding (it)
+import System.Timeout (timeout)
+import UnliftIO.STM
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (Only (..))
+#else
+import Database.SQLite.Simple (Only (..))
+#endif
+
+badgeManagerTests :: SpecWith TestParams
+badgeManagerTests = do
+  describe "applying an issueBadge response" $ do
+    it "stores the statement, writes the issuance, sets the profile badge and reports the change" testIssuedCredentialApplied
+    it "discards a credential signed by another key and writes nothing at all" testForeignCredentialRejected
+    it "an exhausted balance stores the statement, writes no issuance and keeps the badge" testExhaustedBalanceApplied
+  describe "the badge worker" $
+    it "collapses the signals that arrive during a pass into one more pass, never a concurrent one" testSignalsDuringPassRunOnePass
+
+-- Fixtures --------------------------------------------------------------------
+
+-- | The instant the fixture's balance starts running, and the start of the period the pass
+-- issues. Whole seconds: Postgres @TIMESTAMPTZ@ keeps microseconds while 'getCurrentTime' has
+-- nanosecond resolution on Linux, so only a rounded instant survives both backends.
+periodStart :: UTCTime
+periodStart = UTCTime (fromGregorian 2026 3 1) (secondsToDiffTime 0)
+
+-- | The end of that period, which is where @issue@ leaves @balanceStartTs@.
+periodEnd :: UTCTime
+periodEnd = addMonths 1 periodStart
+
+-- | Inside the period, so the fixture's balance funds an unissued month at this instant.
+passNow :: UTCTime
+passNow = UTCTime (fromGregorian 2026 3 15) (secondsToDiffTime 0)
+
+heldEntryUuid :: Text
+heldEntryUuid = "held-credit"
+
+-- | The purchase's ledger before the pass: two months credited, running from 'periodStart'.
+creditEntry :: StatementEntry
+creditEntry = fixtureEntry heldEntryUuid 2 2 periodStart (SECredit SCPayment {invoiceId = Nothing})
+
+-- | The @debit(badge)@ an issue writes, and the only thing the client can read the issued period
+-- back from: one month spent, and @balanceStartTs@ moved to the END of the period issued.
+issuedDebitEntry :: StatementEntry
+issuedDebitEntry = fixtureEntry "issued-debit" (-1) 1 periodEnd (SEDebit SDBadge)
+
+fixtureEntry :: Text -> Int -> Int -> UTCTime -> StatementEntryType -> StatementEntry
+fixtureEntry entryId changeMonths balanceMonths balanceStartTs entryType =
+  StatementEntry
+    { entryId,
+      changeMonths,
+      balanceMonths,
+      balanceStartTs,
+      balanceBadgeType = BTSupporter,
+      wasPausedSince = Nothing,
+      -- the service's clock, identical for every entry of one statement
+      createdAt = passNow,
+      entryType
+    }
+
+-- | Counts and paces the badge passes of a controller. Every pass reads 'badgeCurrentTime'
+-- exactly once, before it reads any state, so 'passes' is the number of passes that have STARTED
+-- and a pass gets no further until the test grants a permit.
+--
+-- Tests that apply a response themselves grant none: that parks the pass chat start signals
+-- before it can read the store, so it can never race their fixtures.
+data BadgeGate = BadgeGate {passes :: TVar Int, permits :: TVar Int}
+
+gatedClock :: BadgeGate -> IO UTCTime
+gatedClock BadgeGate {passes, permits} = do
+  atomically $ modifyTVar' passes (+ 1)
+  atomically $ readTVar permits >>= \n -> if n > 0 then writeTVar permits (n - 1) else retry
+  pure passNow
+
+allowPass :: BadgeGate -> IO ()
+allowPass BadgeGate {permits} = atomically $ modifyTVar' permits (+ 1)
+
+-- | Waits for @n@ passes to have started. Bounded, so a worker that never runs fails the example
+-- instead of hanging it; it is not a wait on badge time.
+waitPasses :: HasCallStack => BadgeGate -> Int -> Expectation
+waitPasses BadgeGate {passes} n =
+  timeout 10000000 (atomically $ readTVar passes >>= \m -> unless (m >= n) retry) >>= \case
+    Just () -> pure ()
+    Nothing -> expectationFailure $ "timed out waiting for badge pass " <> show n
+
+-- | Nothing more is reported: the assertion that a pass emitted no event and raised no error.
+reportsNothing :: HasCallStack => TestCC -> Expectation
+reportsNothing cc = cc <// 500000
+
+-- | A controller with the test issuer key at index 1 and a gated badge clock.
+withBadgeChat :: HasCallStack => TestParams -> BBSPublicKey -> (BadgeGate -> TestCC -> IO ()) -> IO ()
+withBadgeChat ps pk test = do
+  gate <- BadgeGate <$> newTVarIO 0 <*> newTVarIO 0
+  let cfg = testCfg {badgePublicKeys = testBadgeKeys pk, badgeCurrentTime = gatedClock gate}
+  withNewTestChatCfg ps cfg "alice" aliceProfile $ test gate
+
+-- | A shown, issued purchase with two months credited, and the last ledger entry a pass would
+-- assert to the service.
+setupShownPurchase :: TestCC -> IO (UserBadgePurchase, BadgeLedgerEntry)
+setupShownPurchase cc = do
+  User {userId} <- testUser cc
+  drg <- C.newRandom
+  (pubKey, privKey) <- atomically $ C.generateKeyPair drg
+  mk <- generateMasterKey drg
+  r <- withChatStore cc $ \db -> do
+    paymentId <- createCodePayment db periodStart
+    p@UserBadgePurchase {badgePurchaseId = pId} <- createPurchase db userId pubKey privKey mk BTSupporter paymentId periodStart
+    runExceptT $ do
+      setShownPurchase db userId pId
+      insertLedgerEntries db pId BadgeStatement {entries = [creditEntry], previousEntryId = Nothing} periodStart
+      (p,) <$> getLastBadgeLedgerEntry db pId
+  case r of
+    Right (p, Just e) -> pure (p, e)
+    _ -> fail "badge fixture: the purchase or its credit entry was not stored"
+
+testUser :: TestCC -> IO User
+testUser TestCC {chatController = ChatController {currentUser}} =
+  readTVarIO currentUser >>= maybe (fail "no current user") pure
+
+withChatStore :: TestCC -> (DB.Connection -> IO a) -> IO a
+withChatStore TestCC {chatController = ChatController {chatStore}} = withTransaction chatStore
+
+runCM :: TestCC -> CM a -> IO a
+runCM TestCC {chatController} action = runReaderT (runExceptT action) chatController >>= either (fail . show) pure
+
+-- | The pass's second half, composed exactly as 'badgeManagerPass' composes it: the response is
+-- stored (in production under the per-user badge lock) and the change it made is then presented
+-- and reported (in production with that lock released).
+applyIssueResponse :: TestCC -> UserBadgePurchase -> Maybe BadgeLedgerEntry -> BadgeServiceResponse -> IO ()
+applyIssueResponse cc purchase heldEntry_ resp = do
+  user <- testUser cc
+  runCM cc $ storeBadgeIssueResponse passNow user purchase heldEntry_ resp >>= presentBadgeChange
+
+-- | A credential for the fixture's period, signed by the given issuer key. The master key is the
+-- PURCHASE's, as the request the worker sends carries it.
+issuedCredential :: BBSSecretKey -> UserBadgePurchase -> IO BadgeCredential
+issuedCredential sk UserBadgePurchase {masterKey} = do
+  let badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Just (sundayAfter periodEnd), badgeExtra = ""}
+  issueBadge 1 sk (VerifiedBadgeRequest BadgeRequest {masterKey, badgeInfo}) >>= either fail pure
+
+badgeCredentialResponse :: Maybe BadgeCredential -> BadgeStatement -> BadgeServiceResponse
+badgeCredentialResponse credential statement = BSPBadgeCredential {credential, receipt = Nothing, statement}
+
+-- Assertions ------------------------------------------------------------------
+
+lastLedgerEntry :: TestCC -> Int64 -> IO (Maybe BadgeLedgerEntry)
+lastLedgerEntry cc pId =
+  withChatStore cc (\db -> runExceptT $ getLastBadgeLedgerEntry db pId) >>= either (fail . show) pure
+
+ledgerUuids :: TestCC -> Int64 -> IO [Text]
+ledgerUuids cc pId =
+  map fromOnly
+    <$> withChatStore cc (\db -> DB.query db "SELECT entry_uuid FROM badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id ASC" (Only pId))
+
+-- | @(badge_purchase_id, badge_type, period_start, period_end, expiry, entry_id)@ of every
+-- issuance, read from the table rather than from what 'createIssuance' returned.
+issuanceRows :: TestCC -> IO [(Int64, Text, UTCTime, UTCTime, UTCTime, Maybe Int64)]
+issuanceRows cc =
+  withChatStore cc $ \db ->
+    DB.query_ db "SELECT badge_purchase_id, badge_type, period_start, period_end, expiry, entry_id FROM badge_issuances ORDER BY period_start ASC"
+
+-- | The credential stored with the only issuance, decoded from the JSON it is stored as.
+storedCredential :: TestCC -> IO BadgeCredential
+storedCredential cc = do
+  rows <- withChatStore cc $ \db -> DB.query_ db "SELECT credential FROM badge_issuances"
+  case rows of
+    [Only (Binary bs)] -> maybe (fail "stored badge credential does not decode") pure (J.decodeStrict (bs :: ByteString))
+    _ -> fail $ "expected exactly one badge issuance, got " <> show (length rows)
+
+hasNoBadge :: HasCallStack => TestCC -> Expectation
+hasNoBadge cc = do
+  cc ##> "/p"
+  cc <## "user profile: alice (Alice)"
+  cc <## "use /p <name> [<bio>] to change it"
+
+hasSupporterBadge :: HasCallStack => TestCC -> Expectation
+hasSupporterBadge cc = do
+  cc ##> "/p"
+  cc <## "user profile: alice (Alice, * supporter)"
+  cc <## "use /p <name> [<bio>] to change it"
+
+-- Tests -----------------------------------------------------------------------
+
+-- | The whole write set of one issued period, in one place: the statement's rows, the issuance
+-- naming the period the @debit(badge)@ implies, the credential on the profile, and the event.
+testIssuedCredentialApplied :: HasCallStack => TestParams -> IO ()
+testIssuedCredentialApplied ps = do
+  Right (pk, sk) <- bbsKeyGen
+  withBadgeChat ps pk $ \_gate alice -> do
+    (purchase@UserBadgePurchase {badgePurchaseId = pId}, heldEntry) <- setupShownPurchase alice
+    cred <- issuedCredential sk purchase
+    let statement = BadgeStatement {entries = [issuedDebitEntry], previousEntryId = Just heldEntryUuid}
+    applyIssueResponse alice purchase (Just heldEntry) (badgeCredentialResponse (Just cred) statement)
+    -- the balance left, and the date it is paid through: one month from the END of the period
+    -- just issued, never the credential's expiry
+    alice <## "supporter badge 1 (shown): issued, 1 month(s) left, paid through 2026-05-01"
+    ledgerUuids alice pId `shouldReturn` [heldEntryUuid, "issued-debit"]
+    -- period_start is the balanceStartTs in force before the debit(badge) and period_end is the
+    -- one the debit left; entry_id stays NULL (plan §9)
+    issuanceRows alice `shouldReturn` [(pId, "supporter", periodStart, periodEnd, sundayAfter periodEnd, Nothing)]
+    storedCredential alice `shouldReturn` cred
+    hasSupporterBadge alice
+
+-- | The credential verifies against a key the controller is not configured with, so the whole
+-- response is discarded — the statement included, since a response whose credential is not ours
+-- is not one to trust the rest of.
+testForeignCredentialRejected :: HasCallStack => TestParams -> IO ()
+testForeignCredentialRejected ps = do
+  Right (pk, _sk) <- bbsKeyGen
+  Right (_otherPk, otherSk) <- bbsKeyGen
+  withBadgeChat ps pk $ \_gate alice -> do
+    (purchase@UserBadgePurchase {badgePurchaseId = pId}, heldEntry) <- setupShownPurchase alice
+    cred <- issuedCredential otherSk purchase
+    let statement = BadgeStatement {entries = [issuedDebitEntry], previousEntryId = Just heldEntryUuid}
+    applyIssueResponse alice purchase (Just heldEntry) (badgeCredentialResponse (Just cred) statement)
+    alice <## "badge service error: internal, badge credential does not verify against configured key"
+    ledgerUuids alice pId `shouldReturn` [heldEntryUuid]
+    issuanceRows alice `shouldReturn` []
+    hasNoBadge alice
+    reportsNothing alice
+
+-- | @credential = Nothing@ is the exhausted balance, not an error: the statement is stored, no
+-- issuance is written, the profile's badge is left alone, and the event is emitted only because
+-- the stored state actually changed — re-delivering the same statement emits nothing.
+testExhaustedBalanceApplied :: HasCallStack => TestParams -> IO ()
+testExhaustedBalanceApplied ps = do
+  Right (pk, _sk) <- bbsKeyGen
+  withBadgeChat ps pk $ \_gate alice -> do
+    (purchase@UserBadgePurchase {badgePurchaseId = pId}, heldEntry) <- setupShownPurchase alice
+    let lapsed = fixtureEntry "lapse-1" (-2) 0 (addMonths 2 periodStart) (SEDebit SDLapse)
+        statement = BadgeStatement {entries = [lapsed], previousEntryId = Just heldEntryUuid}
+    applyIssueResponse alice purchase (Just heldEntry) (badgeCredentialResponse Nothing statement)
+    alice <## "supporter badge 1 (shown): issued, 0 month(s) left, paid through 2026-05-01"
+    ledgerUuids alice pId `shouldReturn` [heldEntryUuid, "lapse-1"]
+    issuanceRows alice `shouldReturn` []
+    hasNoBadge alice
+    -- the same statement again changes nothing, so nothing is reported
+    heldEntry' <- lastLedgerEntry alice pId
+    applyIssueResponse alice purchase heldEntry' (badgeCredentialResponse Nothing statement)
+    ledgerUuids alice pId `shouldReturn` [heldEntryUuid, "lapse-1"]
+    reportsNothing alice
+
+-- | Three signals arriving while a pass runs leave the worker with ONE more pass to run, not
+-- three and not a concurrent one. The gated clock is what makes this deterministic: the pass
+-- chat start signalled is parked at its first line, so every signal below provably arrives
+-- while it is still running.
+testSignalsDuringPassRunOnePass :: HasCallStack => TestParams -> IO ()
+testSignalsDuringPassRunOnePass ps = do
+  Right (pk, _sk) <- bbsKeyGen
+  withBadgeChat ps pk $ \gate alice -> do
+    waitPasses gate 1
+    _ <- setupShownPurchase alice
+    forM_ [1 :: Int .. 3] $ \_ -> do
+      alice ##> "/_badge state 1"
+      alice <## "supporter badge 1 (shown): issued, 2 month(s) left, paid through 2026-05-01"
+      alice <## "badge site: not configured"
+    -- the three signals did not start a pass of their own: the first one is still running
+    readTVarIO (passes gate) `shouldReturn` 1
+    -- released, it finds the month due and reports what C3's stub send path answers
+    allowPass gate
+    alice <## "badge service error: internal, not implemented"
+    waitPasses gate 2
+    allowPass gate
+    alice <## "badge service error: internal, not implemented"
+    -- and that is the only pass the three signals bought, however many they were
+    reportsNothing alice
+    readTVarIO (passes gate) `shouldReturn` 2

tests/Test.hs

@@ -5,6 +5,7 @@
 
 import Bots.BadgeCodeTests
 import Bots.BadgeLedgerTests
+import Bots.BadgeManagerTests
 import Bots.BadgeServiceTests
 import Bots.BadgeStoreTests
 import Bots.BroadcastTests
@@ -90,6 +91,7 @@ main = do
           describe "Mobile API Tests" mobileTests
 #endif
           describe "Supporter badges store" badgeStoreTests
+          describe "Supporter badges manager" badgeManagerTests
           describe "SimpleX chat client" chatTests
           xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
           xdescribe'' "SimpleX Directory service bot" directoryServiceTests