core: redeem badge codes and issue credentials

2026-09-27 15:48:54 +00:00 · 2026-08-27 10:28:26 +00:00
parent 05d4724d41
commit 89e9bf4be7
5 changed files with 598 additions and 119 deletions
@@ -16,23 +16,46 @@ module BadgeService.Service
 where

 import BadgeService.Catalog (catalogTotals, seedCatalog)
-import BadgeService.Config (BadgeServiceEnv (..), checkFailureBuckets, newBadgeServiceEnv, readBadgeServiceConfig, takeCatalogBucket)
-import BadgeService.Ledger (LedgerState (..), advance)
+import BadgeService.Codes (RedeemOutcome (..), classifyRedemption, codeHash, normalizeCode)
+import BadgeService.Config
+  ( BadgeServiceConfig (issuer),
+    BadgeServiceEnv (..),
+    IssuerConfig (issuerKeyIdx),
+    checkFailureBuckets,
+    debitFailureBuckets,
+    newBadgeServiceEnv,
+    readBadgeServiceConfig,
+    sweepSignerBucketsIO,
+    takeCatalogBucket,
+  )
+import BadgeService.Credentials (issueSignedBadge)
+import BadgeService.Ledger (LedgerState (..), advance, credit, initialLedgerState, issue)
 import BadgeService.Options
 import BadgeService.Store
  ( BadgePurchaseRow (..),
+    NewIssuance (..),
    ServiceError (..),
    appendLedgerEntry,
+    attachPurchasePayment,
+    createCodePayment,
+    createIssuance,
+    createPurchase,
    getActiveCatalog,
+    getCodeByHash,
+    getIssuanceForPeriod,
+    getIssuanceForRedeemedCode,
    getLastLedgerEntry,
+    getLedgerEntryIdByUuid,
    getLedgerSince,
    getPurchaseByKey,
+    markCodeRedeemed,
    withServiceTransaction,
  )
 import BadgeService.Store.Migrate (runBadgeServiceMigrations)
+import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM
 import Control.Exception (SomeException, catch, evaluate)
-import Control.Monad.Except (ExceptT, throwError)
+import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
 import Control.Monad.IO.Class (liftIO)
 import Control.Logger.Simple
 import Control.Monad
@@ -40,14 +63,17 @@ import qualified Data.Aeson as J
 import qualified Data.Aeson.Types as JT
 import qualified Data.ByteString.Lazy as LBS
 import Data.Int (Int64)
+import Data.Maybe (isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime)
 import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as UUID
 import Data.Word (Word32)
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeRequest (..), BadgeType)
 import Simplex.Chat.Badges.Service
-  ( BadgeCatalog (..),
+  ( BadgeBalance (..),
+    BadgeCatalog (..),
    BadgeOffer (..),
    BadgePrice (..),
    BadgeServiceCommand (..),
@@ -55,18 +81,23 @@ import Simplex.Chat.Badges.Service
    BadgeServiceRequest (..),
    BadgeServiceResponse (..),
    BadgeStatement (..),
+    BadgeUpgrade,
    StatementCreditType (..),
    StatementDebitType (..),
    StatementEntry (..),
-    StatementEntryType (..),
+    -- 'StatementEntryType' and 'LedgerEntryType' import their constructors only: their fields
+    -- are both named 'credit'\/'debit' and would collide with each other and with
+    -- 'BadgeService.Ledger.credit', which this module calls.
+    StatementEntryType (SECredit, SEDebit),
    minSupportedBadgeVersion,
  )
 import Simplex.Chat.Badges.Types
-  ( BadgeLedgerEntry (..),
+  ( BadgeIssuance (..),
+    BadgeLedgerEntry (..),
    BadgeOfferId (..),
    LedgerCreditType (..),
    LedgerDebitType (..),
-    LedgerEntryType (..),
+    LedgerEntryType (LECredit, LEDebit),
  )
 import Simplex.Chat.Bot (initializeBotAddress')
 import Simplex.Chat.Controller
@@ -114,16 +145,20 @@ badgeService opts cfg = do
          { preStartHook = Just $ badgePreStartHook opts env,
            postStartHook = Just $ badgePostStartHook opts env
          }
-  simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> do
-    -- preStartHook (badgePreStartHook) already ran and populated serviceEnv by the time this
-    -- callback starts (Core.hs runs it before postStartHook, which runs before this), so a
-    -- single read here is safe -- the value never changes again for the life of the process.
-    bsEnv <- atomically $ readTMVar $ serviceEnv env
-    forever $ do
-      (_, event) <- atomically . readTBQueue $ outputQ cc
-      case event of
-        Right (CEvtServiceRequest u reqId sigKey_ reqData) -> handleServiceRequest bsEnv cc u reqId sigKey_ reqData
-        _ -> pure ()
+  simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc ->
+    raceAny_ [processServiceEvents env cc, sweepSignerBucketsLoop env]
+
+processServiceEvents :: ServiceState -> ChatController -> IO ()
+processServiceEvents env cc = do
+  -- preStartHook (badgePreStartHook) already ran and populated serviceEnv by the time this
+  -- callback starts (Core.hs runs it before postStartHook, which runs before this), so a
+  -- single read here is safe -- the value never changes again for the life of the process.
+  bsEnv <- atomically $ readTMVar $ serviceEnv env
+  forever $ do
+    (_, event) <- atomically . readTBQueue $ outputQ cc
+    case event of
+      Right (CEvtServiceRequest u reqId sigKey_ reqData) -> handleServiceRequest bsEnv cc u reqId sigKey_ reqData
+      _ -> pure ()

 badgeServiceCLI :: BadgeServiceOpts -> IO ()
 badgeServiceCLI opts = do
@@ -142,7 +177,8 @@ badgeServiceCLI opts = do
          }
  raceAny_
    [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing,
-      processQueuedRequests env
+      processQueuedRequests env,
+      sweepSignerBucketsLoop env
    ]

 processQueuedRequests :: ServiceState -> IO ()
@@ -153,6 +189,29 @@ processQueuedRequests env = do
    (u, reqId, sigKey_, reqData) <- atomically $ readTQueue $ serviceRequestQ env
    handleServiceRequest bsEnv cc u reqId sigKey_ reqData

+-- | How often the per-signer failure-bucket map is swept. Ten minutes is short against the
+-- hour a default bucket takes to refill and long against how often a bucket is created (only a
+-- classified redemption failure creates one), so the sweep is close to free while keeping the
+-- map's steady-state size well under the growth cap 'debitFailureBuckets' already guarantees.
+signerBucketSweepIntervalSeconds :: Int
+signerBucketSweepIntervalSeconds = 600
+
+-- | Runs the per-signer bucket sweep on a timer, as a third arm of the service's 'raceAny_'
+-- alongside the bot and (in the CLI path) the terminal. B5 built 'sweepSignerBucketsIO' and
+-- left it unscheduled because nothing there could create a map entry; B7 is the first step
+-- whose redemptions can fail, so it is the first that needs the sweep to actually run (plan
+-- \'9). The interval is real time -- 'threadDelay', not 'BadgeServiceEnv.now' -- because it
+-- schedules the sweep rather than deciding anything; the eviction itself reads the injectable
+-- clock through 'sweepSignerBucketsIO', so a test proves eviction by calling that directly
+-- rather than waiting on this loop.
+sweepSignerBucketsLoop :: ServiceState -> IO ()
+sweepSignerBucketsLoop env = do
+  bsEnv <- atomically $ readTMVar $ serviceEnv env
+  forever $ do
+    threadDelay $ signerBucketSweepIntervalSeconds * 1000000
+    evicted <- sweepSignerBucketsIO bsEnv
+    when (evicted > 0) $ logInfo $ "badge service swept " <> tshow evicted <> " recovered signer failure buckets"
+
 -- Seeded here, after migrations and before badgePostStartHook starts the bot: every start
 -- of the service must see the catalog before it can serve a request. B8's operator
 -- subcommand (not yet implemented) will need to call seedCatalog the same way, so operator
@@ -233,8 +292,15 @@ responseObject resp = case J.toJSON resp of
 errorResponse :: BadgeServiceErrorCode -> Maybe Text -> Maybe Word32 -> BadgeServiceResponse
 errorResponse code message retryAfter = BSPError {code, message, retryAfter}

-notImplemented :: BadgeServiceResponse
-notImplemented = errorResponse BSEInternal (Just "not implemented") Nothing
+badRequest :: BadgeServiceResponse
+badRequest = errorResponse BSEBadRequest Nothing Nothing
+
+-- | A store error is never repeated back to the client: it is logged with the command that
+-- produced it and answered with 'internal', like every other unexpected failure.
+storeFailed :: Text -> ServiceError -> IO BadgeServiceResponse
+storeFailed what e = do
+  logError $ what <> " failed: " <> tshow e
+  pure $ errorResponse BSEInternal Nothing Nothing

 -- | Decode, version gate, and the signer\/record precondition (RPC doc "Identity"), then
 -- dispatch. Order matches badges-rpc.md and the B5 brief: a decode failure is 'bad_request'
@@ -286,39 +352,47 @@ requirePurchaseRecord BadgeServiceEnv {store} key =

 -- | Dispatch on the command, once the signer\/record precondition already passed.
 -- 'getBadgeInvoice', 'upgradeBadgeSubscription' and 'pauseBadge' are out of scope (decision 5
-- \/ §6) and always 'bad_request'; 'issueBadge' is B7's command and answers 'internal'
-- \"not implemented\" until that step lands. 'getBadgeCatalog' (B6) and, later, 'issueBadge'
-- are the two commands that use the 'Maybe' 'BadgePurchaseRow' 'checkSignerRecord' already
-- looked up; every other clause below ignores it.
+-- \/ §6) and always 'bad_request'. 'getBadgeCatalog' (B6) and 'issueBadge' (B7) are the two
+-- commands that use the 'Maybe' 'BadgePurchaseRow' 'checkSignerRecord' already looked up;
+-- every other clause below ignores it.
 dispatchCommand :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> Maybe BadgePurchaseRow -> BadgeServiceCommand -> IO BadgeServiceResponse
-dispatchCommand _ _ _ (BSCGetBadgeInvoice {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
-dispatchCommand _ _ _ (BSCUpgradeBadgeSubscription {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
-dispatchCommand _ _ _ BSCPauseBadge = pure $ errorResponse BSEBadRequest Nothing Nothing
+dispatchCommand _ _ _ (BSCGetBadgeInvoice {}) = pure badRequest
+dispatchCommand _ _ _ (BSCUpgradeBadgeSubscription {}) = pure badRequest
+dispatchCommand _ _ _ BSCPauseBadge = pure badRequest
 dispatchCommand bsEnv _ purchaseRow BSCGetBadgeCatalog = handleGetBadgeCatalog bsEnv purchaseRow
-dispatchCommand _ _ _ (BSCIssueBadge {}) = pure notImplemented
-dispatchCommand bsEnv purchaseKey _ (BSCPurchaseBadge {payment}) = dispatchPurchase bsEnv purchaseKey payment
+dispatchCommand bsEnv _ purchaseRow (BSCIssueBadge {badgeRequest, balance}) = case purchaseRow of
+  Just row -> handleIssueBadge bsEnv row badgeRequest balance
+  -- unreachable: 'checkSignerRecord' answers 'unknown_purchase_key' for an 'issueBadge' whose
+  -- key has no row, so the row is always 'Just' here; this clause only keeps the case total.
+  Nothing -> pure $ errorResponse BSEUnknownPurchaseKey Nothing Nothing
+dispatchCommand bsEnv purchaseKey _ (BSCPurchaseBadge {badgeRequest, payment, upgrade}) =
+  dispatchPurchase bsEnv purchaseKey badgeRequest payment upgrade

 -- | 'checkSignerRecord' already requires a signature for every 'purchaseBadge', so
 -- 'purchaseKey' is 'Just' here in every reachable case; the 'Nothing' clause only keeps this
 -- function total.
 --
 -- Only 'SPCode' is implemented (B7); the others verify store evidence or transfer a receipt,
-- both out of scope (§6), so they are 'bad_request' permanently, not \"not implemented\".
+-- both out of scope (§6), so they are 'bad_request' permanently. So is a purchase carrying an
+-- @upgrade@: the store one-time upgrade it proves eligibility for needs store evidence, and
+-- tier upgrades are out of scope too (§6), so it is refused before the payment is even looked
+-- at rather than silently ignored while the code is consumed.
 --
 -- The throttle (B5 decision 5) runs before 'SPCode' is processed: an empty per-signer or
-- global-failure bucket rejects the request with 'rate_limited' before it would otherwise
-- reach B7's (not yet implemented) code classifier. Neither bucket is debited here --
-- 'checkFailureBuckets' only peeks; only a classified failure debits, which is B7's job.
-dispatchPurchase :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> ServicePayment -> IO BadgeServiceResponse
-dispatchPurchase bsEnv (Just signerKey) (SPCode _code) =
+-- global-failure bucket rejects the request with 'rate_limited' before it reaches the code
+-- classifier. Neither bucket is debited here -- 'checkFailureBuckets' only peeks; only a
+-- classified failure debits, which 'handlePurchaseCode' does.
+dispatchPurchase :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> BadgeRequest -> ServicePayment -> Maybe BadgeUpgrade -> IO BadgeServiceResponse
+dispatchPurchase _ _ _ _ (Just _) = pure badRequest
+dispatchPurchase bsEnv (Just signerKey) badgeRequest (SPCode code) Nothing =
  checkFailureBuckets bsEnv signerKey >>= \case
    Left retryAfter -> pure $ errorResponse BSERateLimited Nothing (Just retryAfter)
-    Right () -> pure notImplemented
-dispatchPurchase _ Nothing (SPCode _) = pure $ errorResponse BSEBadRequest Nothing Nothing
-dispatchPurchase _ _ (SPApple {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
-dispatchPurchase _ _ (SPGoogle {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
-dispatchPurchase _ _ (SPInvoice {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
-dispatchPurchase _ _ (SPReceipt {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
+    Right () -> handlePurchaseCode bsEnv signerKey badgeRequest code
+dispatchPurchase _ Nothing _ (SPCode _) Nothing = pure badRequest
+dispatchPurchase _ _ _ (SPApple {}) Nothing = pure badRequest
+dispatchPurchase _ _ _ (SPGoogle {}) Nothing = pure badRequest
+dispatchPurchase _ _ _ (SPInvoice {}) Nothing = pure badRequest
+dispatchPurchase _ _ _ (SPReceipt {}) Nothing = pure badRequest

 -- getBadgeCatalog (B6) --------------------------------------------------------

@@ -361,7 +435,7 @@ handleGetBadgeCatalog bsEnv@BadgeServiceEnv {store, now} purchaseRow = case purc
      -- (decision 8): the site, the RPC catalog and the charge all read this one result.
      catalog <- catalogTotals <$> getActiveCatalog db
      -- getBadgeCatalog carries no cursor, so this is always the full ledger (Nothing).
-      statement <- mapM (purchaseStatement now' db Nothing) row
+      statement <- mapM (\BadgePurchaseRow {badgePurchaseId} -> purchaseStatement now' db Nothing badgePurchaseId) row
      pure (catalog, statement)

 -- | An offer that is pinned to a price the catalog also returned, yet still has no total,
@@ -378,9 +452,20 @@ logUnpricedOffers BadgeCatalog {prices, offers} =
            logWarn $ "catalog offer " <> oid <> " has a pinned price but no chargeable total"
      _ -> pure ()

+-- | A resolved statement cursor: the wire @entryId@ the client asserted, and the local
+-- @entry_id@ it resolved to. The two travel together so 'previousEntryId' always echoes the
+-- value the client actually sent, and is never spelled independently of the id the query runs
+-- on. A cursor exists only when the assertion resolved to an entry of this very purchase
+-- ('getLedgerEntryIdByUuid'); an assertion naming nothing yields no cursor, and the RPC's
+-- other permitted answer -- the complete history -- is what follows.
+data StatementCursor = StatementCursor
+  { cursorEntryId :: Int64,
+    cursorEntryUuid :: Text
+  }
+
 -- | Heals the purchase's ledger to @now@, then reads it back as a statement -- the whole
-- ledger when @sinceEntryId@ is 'Nothing', or only entries strictly after it otherwise
-- (matches 'getLedgerSince'\'s own semantics).
+-- ledger when there is no cursor, or only entries strictly after it otherwise (matches
+-- 'getLedgerSince'\'s own semantics).
 --
 -- @advance@ is run against the last stored entry's state and, when it yields months, ONE
 -- @debit(lapse)@ row is written for them (B2's calling convention: one row, whatever @k@ is).
@@ -388,53 +473,42 @@ logUnpricedOffers BadgeCatalog {prices, offers} =
 -- balance to lapse from -- so it returns an empty statement rather than inventing an opening
 -- entry.
 --
-- Takes the purchase row directly rather than a key: every caller has already looked it up
-- once (B6's 'handleGetBadgeCatalog' via 'checkSignerRecord'; B7's future 'issueBadge' the
-- same way), and looking it up again here would open a second transaction reading the same
-- row -- so there is no "signer has no purchase row" case to handle any more.
+-- Called at the end of the same transaction that wrote the command's entries, so the balance a
+-- client is told is always the balance the database holds; a command with nothing to write
+-- calls it in a transaction of its own that then writes nothing (the heal above is the only
+-- write it could make, and it makes none when @advance@ yields nothing).
 --
-- @sinceEntryId@ is also threaded through rather than hardcoded, so a future cursor-carrying
-- caller (B7) can reuse this function instead of duplicating it. 'getBadgeCatalog' (B6)
-- always passes 'Nothing' -- it carries no cursor -- for which 'previousEntryId' being
-- 'Nothing' below is exactly correct (RPC: "absent for the full ledger"). 'previousEntryId'
-- is meant to echo the client's *asserted* (wire, 'Text') entryId, which this function is
-- never given, only the resolved 'Int64' to query on -- a real cursor caller needs to carry
-- that wire value through separately to fill it in for real; nothing today constructs one.
-purchaseStatement :: UTCTime -> DB.Connection -> Maybe Int64 -> BadgePurchaseRow -> ExceptT ServiceError IO BadgeStatement
-purchaseStatement now' db sinceEntryId BadgePurchaseRow {badgePurchaseId} = do
+-- 'getBadgeCatalog' (B6) and 'purchaseBadge' (B7) pass no cursor -- neither command carries an
+-- asserted entry -- for which 'previousEntryId' being 'Nothing' is exactly right (RPC: "absent
+-- for the full ledger"). 'issueBadge' carries @balance.lastEntry@ and passes the cursor that
+-- resolved from it.
+purchaseStatement :: UTCTime -> DB.Connection -> Maybe StatementCursor -> Int64 -> ExceptT ServiceError IO BadgeStatement
+purchaseStatement now' db cursor badgePurchaseId = do
  healLedger now' db badgePurchaseId
-  entries <- mapM (liftEither' . toStatementEntry) =<< getLedgerSince db badgePurchaseId sinceEntryId
-  pure BadgeStatement {entries, previousEntryId = Nothing}
+  entries <- mapM (liftEither' . toStatementEntry) =<< getLedgerSince db badgePurchaseId (cursorEntryId <$> cursor)
+  pure BadgeStatement {entries, previousEntryId = cursorEntryUuid <$> cursor}
  where
    liftEither' = either throwError pure

+-- | The lapse half of a plan on its own: @advance@ against the last stored entry, written
+-- through the same 'writeLedgerPlan' every command uses, so the @debit(lapse)@ row a heal
+-- appends is constructed in exactly one place. A purchase with no ledger has nothing to heal.
 healLedger :: UTCTime -> DB.Connection -> Int64 -> ExceptT ServiceError IO ()
 healLedger now' db badgePurchaseId =
  getLastLedgerEntry db badgePurchaseId >>= \case
    Nothing -> pure ()
-    Just BadgeLedgerEntry {balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince} ->
-      case advance now' LedgerState {balanceMonths, balanceStartTs, balanceBadgeType} of
-        Nothing -> pure ()
-        Just (k, LedgerState {balanceMonths = balanceMonths', balanceStartTs = balanceStartTs'}) -> do
-          entryUuid <- liftIO (UUID.toText <$> UUID.nextRandom)
-          void $
-            appendLedgerEntry
-              db
-              BadgeLedgerEntry
-                { entryId = 0, -- assigned by the database
-                  entryUuid,
-                  badgePurchaseId,
-                  changeMonths = negate k,
-                  balanceMonths = balanceMonths',
-                  -- the entry's balance_start_ts is the state advance left, NOT the time the
-                  -- row was created; created_at/service_created_at carry that (B2)
-                  balanceStartTs = balanceStartTs',
-                  balanceBadgeType,
-                  wasPausedSince,
-                  serviceCreatedAt = now',
-                  createdAt = now',
-                  entryType = LEDebit DTLapse
-                }
+    Just entry@BadgeLedgerEntry {balanceBadgeType, wasPausedSince} ->
+      writeLedgerPlan
+        db
+        now'
+        badgePurchaseId
+        balanceBadgeType
+        LedgerPlan
+          { lpLapse = advance now' (ledgerStateOf entry),
+            lpCredit = Nothing,
+            lpIssue = IssuedNone,
+            lpWasPausedSince = wasPausedSince
+          }

 -- | The stored ledger row as the client sees it. 'entryId' on the wire is the row's
 -- @entry_uuid@, not its @entry_id@: the uuid is what the service authors and the client
@@ -444,10 +518,10 @@ healLedger now' db badgePurchaseId =
 -- Four entry types are refused rather than converted, and none of them can be reached by
 -- anything in this milestone:
 --
--   * @CTPayment@ and @CTCharge@ carry 'Int64' ids against @TEXT@ columns -- the unresolved
--     mismatch §9 records as needing a decision before C1. 'BadgeService.Store' already
--     refuses to read or write them, so a row of either type cannot exist; inventing a
--     numeric-to-text coercion here is exactly what that refusal exists to prevent.
+--   * @CTCharge@ carries an 'Int64' id against a @TEXT@ column -- the unresolved mismatch §9
+--     records. 'BadgeService.Store' already refuses to read or write it, so a row of that type
+--     cannot exist; inventing a numeric-to-text coercion here is exactly what that refusal
+--     exists to prevent. Subscriptions are out of scope (§6), so nothing writes one.
 --   * @CTTransferIn@, @DTUpgrade@ and @DTTransferOut@ store a purchase *id* while the wire
 --     types carry a purchase *key*. Converting needs an id-to-key lookup the store does not
 --     expose, and transfers and upgrades are out of scope (§6), so nothing writes them.
@@ -476,7 +550,12 @@ statementEntryType = \case
    CTSupport -> Right SCSupport
    CTOpening -> Right SCOpening
    CTUnknown {tag, json} -> Right SCUnknown {tag, json}
-    CTPayment {} -> unresolved "credit(payment)" "invoiceId is Int64 against a TEXT column (§9, open before C1)"
+    -- The stored id is the PAYMENT's, and the wire field is the INVOICE's. Every payment this
+    -- milestone writes is a code payment, which has no invoice at all (brief B7 step 4), so
+    -- 'Nothing' is the right and only answer today. An invoice-funded payment (D-phase) reaches
+    -- its invoice through @payments.invoice_id@, which is a join this pure function cannot do:
+    -- whichever step first credits one must resolve the invoice id before building the entry.
+    CTPayment {} -> Right SCPayment {invoiceId = Nothing}
    CTCharge {} -> unresolved "credit(charge)" "chargeId is Int64 against a TEXT column (§9, open before C1)"
    CTTransferIn {} -> unresolved "credit(transfer_in)" "stores a purchase id, the wire carries a purchase key; transfers are out of scope (§6)"
  LEDebit debitType -> SEDebit <$> case debitType of
@@ -489,3 +568,352 @@ statementEntryType = \case
    DTTransferOut {} -> unresolved "debit(transfer_out)" "stores a purchase id, the wire carries a purchase key; transfers are out of scope (§6)"
  where
    unresolved what why = Left $ SEDecodeError ("cannot put " <> what <> " in a statement: " <> why)
+
+-- purchaseBadge{code} and issueBadge (B7) -------------------------------------
+
+-- | One retry of the whole redemption. A code claimed by a concurrent request between the
+-- classification and the write ('SECodeConflict') is re-classified from the top, and that
+-- second pass reaches a terminal answer -- a replay for the same key, @code_used@ for another
+-- -- because the code is now redeemed and cannot become unredeemed by itself.
+redemptionAttempts :: Int
+redemptionAttempts = 1
+
+-- | What @issue@ (B2) says should happen, computed in memory before anything is signed or
+-- written.
+data IssuePlan
+  = -- | A period to issue: it is signed, then recorded as one @debit(badge)@ entry and one
+    -- issuance row. Carries the state @issue@ left, the period start and the period end.
+    IssuePeriod LedgerState UTCTime UTCTime
+  | -- | The current month is already issued -- a positive balance whose @balanceStartTs@ a
+    -- previous @issue@ moved past @now@. Its credential is fetched, not signed, and neither a
+    -- @debit(badge)@ entry nor an issuance row is written: that month's pair already exists and
+    -- B2's property 3 keeps them 1:1.
+    IssueCached
+  | -- | Nothing to issue: the balance is exhausted. Not an error -- the statement shows why.
+    IssueExhausted
+
+-- | An 'IssuePlan' with its credential resolved.
+data IssueResult
+  = IssuedPeriod LedgerState UTCTime UTCTime BadgeCredential
+  | IssuedCached BadgeCredential
+  | IssuedNone
+
+issuedCredential :: IssueResult -> Maybe BadgeCredential
+issuedCredential = \case
+  IssuedPeriod _ _ _ cred -> Just cred
+  IssuedCached cred -> Just cred
+  IssuedNone -> Nothing
+
+-- | Every ledger row a command will append, computed with B2's pure functions before any IO
+-- happens. Parameterised over the issue step so one value carries first the plan
+-- (@LedgerPlan IssuePlan@) and then, once the credential is resolved, the write set
+-- (@LedgerPlan IssueResult@) -- the two can never drift apart into separate values.
+data LedgerPlan a = LedgerPlan
+  { -- | @advance@'s @debit(lapse)@: the months lapsed and the state it left. ONE row, whatever
+    -- @k@ is (B2's calling convention). It belongs to the write set even when the command has
+    -- nothing else to write.
+    lpLapse :: Maybe (Int, LedgerState),
+    -- | The @credit(payment)@ a funded command records: the months, the entry type naming the
+    -- payment row it references, and the state after crediting. 'issueBadge' credits nothing.
+    lpCredit :: Maybe (Int, LedgerCreditType, LedgerState),
+    lpIssue :: a,
+    -- | Carried forward from the last stored entry onto every row this plan appends: it marks
+    -- the entry ending a pause, and pausing is out of scope (§6), so nothing here sets or
+    -- clears it.
+    lpWasPausedSince :: Maybe UTCTime
+  }
+
+-- | Step 4, entirely pure: @advance@, then the command's credit if it has one, then @issue@ --
+-- in that order and against one timestamp, which is B2's calling convention. Nothing here
+-- touches the database, so the whole prospective state is known before a signature is asked
+-- for and before a transaction is opened.
+planLedger :: UTCTime -> Maybe (Int, LedgerCreditType) -> Maybe UTCTime -> LedgerState -> LedgerPlan IssuePlan
+planLedger now' creditWith wasPaused st0 =
+  LedgerPlan {lpLapse = lapse, lpCredit = credited, lpIssue = issuePlan, lpWasPausedSince = wasPaused}
+  where
+    lapse = advance now' st0
+    st1 = maybe st0 snd lapse
+    -- 'credit' ignores the 'StatementCreditType' it takes (B2); it only names the transition,
+    -- and 'SCPayment Nothing' is right for every credit this step records -- a code payment has
+    -- no invoice (brief step 4).
+    credited = (\(n, creditType) -> (n, creditType, credit now' n (SCPayment Nothing) st1)) <$> creditWith
+    st2 = maybe st1 (\(_, _, st) -> st) credited
+    issuePlan = case issue now' st2 of
+      Just (st3, periodStart, periodEnd) -> IssuePeriod st3 periodStart periodEnd
+      Nothing -> case st2 of
+        LedgerState {balanceMonths = 0} -> IssueExhausted
+        _ -> IssueCached
+
+-- | Step 5: the only IO between the pure plan and the write, and the only place a credential is
+-- produced. A fresh period is SIGNED (B4); an already-issued month has its credential FETCHED;
+-- an exhausted balance has none. A signing failure returns its error code with nothing written
+-- at all, so a redeemed-nothing code stays retryable (brief step 5).
+--
+-- @badgePurchaseId_@ is 'Nothing' only for a purchase that does not exist yet, which cannot be
+-- in the 'IssueCached' state -- that state needs a stored ledger entry, which needs a purchase.
+resolveIssue :: BadgeServiceEnv -> UTCTime -> Maybe Int64 -> BadgeRequest -> IssuePlan -> IO (Either BadgeServiceErrorCode IssueResult)
+resolveIssue BadgeServiceEnv {config = bsConfig, store, issuerKey} now' badgePurchaseId_ badgeRequest = \case
+  IssuePeriod st periodStart periodEnd ->
+    issueSignedBadge (issuerKeyIdx (issuer bsConfig)) issuerKey badgeRequest periodEnd >>= \case
+      Left code -> pure $ Left code
+      Right cred -> pure $ Right $ IssuedPeriod st periodStart periodEnd cred
+  IssueCached -> case badgePurchaseId_ of
+    Nothing -> do
+      logError "issue reported the current month as already issued for a purchase that does not exist"
+      pure $ Left BSEInternal
+    -- The already-issued month is the one containing @now@: the previous 'issue' set
+    -- 'balanceStartTs' to that period's END (> now), and its START is at or before the instant
+    -- that issue ran, which is at or before now. Probing at @now@ therefore names exactly that
+    -- period. Stepping a month back from 'balanceStartTs' would not: 'addMonths' is not
+    -- additive under clamping (31 Jan + 1 month = 28 Feb, and 28 Feb - 1 month = 28 Jan), so
+    -- from a clamped boundary it can fall short of the very period it came from and pick up the
+    -- issuance before it.
+    Just pid ->
+      withServiceTransaction store (\db -> getIssuanceForPeriod db pid now') >>= \case
+        Right (Just issuance) -> pure $ Right $ IssuedCached (issuanceCredential issuance)
+        Right Nothing -> do
+          logError $ "no badge issuance covers the already-issued period of purchase " <> tshow pid
+          pure $ Left BSEInternal
+        Left e -> do
+          logError $ "reading the cached badge issuance failed: " <> tshow e
+          pure $ Left BSEInternal
+  IssueExhausted -> pure $ Right IssuedNone
+
+-- | Step 6's ledger writes, in the order the brief fixes: the @debit(lapse)@ @advance@ produced,
+-- the @credit(payment)@, the @debit(badge)@, then the issuance carrying the signed credential
+-- and pointing at that debit. A cached or exhausted issue writes neither of the last two.
+--
+-- Every entry this service appends is built here, including 'healLedger''s, so a column added
+-- to 'BadgeLedgerEntry' cannot be filled correctly in one writer and forgotten in another.
+writeLedgerPlan :: DB.Connection -> UTCTime -> Int64 -> BadgeType -> LedgerPlan IssueResult -> ExceptT ServiceError IO ()
+writeLedgerPlan db now' pid badgeType LedgerPlan {lpLapse, lpCredit, lpIssue, lpWasPausedSince} = do
+  forM_ lpLapse $ \(k, st) -> void $ appendEntry (negate k) st (LEDebit DTLapse)
+  forM_ lpCredit $ \(n, creditType, st) -> void $ appendEntry n st (LECredit creditType)
+  case lpIssue of
+    IssuedPeriod st periodStart periodEnd cred -> do
+      BadgeLedgerEntry {entryId} <- appendEntry (-1) st (LEDebit DTBadge)
+      expiry <- either throwError pure (credentialExpiry cred)
+      issuanceId <- liftIO (UUID.toText <$> UUID.nextRandom)
+      void $
+        createIssuance
+          db
+          NewIssuance
+            { issuanceId,
+              badgePurchaseId = pid,
+              badgeType,
+              periodStart,
+              periodEnd,
+              expiry,
+              ledgerEntryId = Just entryId,
+              credential = cred
+            }
+          now'
+    IssuedCached _ -> pure ()
+    IssuedNone -> pure ()
+  where
+    appendEntry changeMonths LedgerState {balanceMonths, balanceStartTs, balanceBadgeType} entryType = do
+      entryUuid <- liftIO (UUID.toText <$> UUID.nextRandom)
+      appendLedgerEntry
+        db
+        BadgeLedgerEntry
+          { entryId = 0, -- assigned by the database
+            entryUuid,
+            badgePurchaseId = pid,
+            changeMonths,
+            balanceMonths,
+            -- the entry's balance_start_ts is the state the transition left, NOT the time the
+            -- row was created; created_at/service_created_at carry that (B2)
+            balanceStartTs,
+            balanceBadgeType,
+            wasPausedSince = lpWasPausedSince,
+            serviceCreatedAt = now',
+            createdAt = now',
+            entryType
+          }
+
+-- | The issuance row's @expiry@, read back from the credential rather than recomputed with
+-- 'sundayAfter', so the stored expiry can never disagree with the one actually signed.
+-- 'issueSignedBadge' always sets it (B4), so 'Nothing' is unreachable and is refused rather
+-- than defaulted -- an issuance whose expiry does not match its credential is a wrong record.
+credentialExpiry :: BadgeCredential -> Either ServiceError UTCTime
+credentialExpiry BadgeCredential {badgeInfo = BadgeInfo {badgeExpiry}} =
+  maybe (Left $ SEDecodeError "signed credential carries no badgeExpiry") Right badgeExpiry
+
+ledgerStateOf :: BadgeLedgerEntry -> LedgerState
+ledgerStateOf BadgeLedgerEntry {balanceMonths, balanceStartTs, balanceBadgeType} =
+  LedgerState {balanceMonths, balanceStartTs, balanceBadgeType}
+
+-- Accessors for fields whose names several records in scope share, so they are spelled once
+-- here instead of as an ambiguous bare selector at every use.
+
+entryWasPausedSince :: BadgeLedgerEntry -> Maybe UTCTime
+entryWasPausedSince BadgeLedgerEntry {wasPausedSince} = wasPausedSince
+
+rowPurchaseId :: BadgePurchaseRow -> Int64
+rowPurchaseId BadgePurchaseRow {badgePurchaseId} = badgePurchaseId
+
+rowPaymentId :: BadgePurchaseRow -> Maybe Text
+rowPaymentId BadgePurchaseRow {paymentId} = paymentId
+
+issuanceCredential :: BadgeIssuance -> BadgeCredential
+issuanceCredential BadgeIssuance {credential} = credential
+
+requestedBadgeType :: BadgeRequest -> BadgeType
+requestedBadgeType BadgeRequest {badgeInfo = BadgeInfo {badgeType}} = badgeType
+
+requestMasterKey :: BadgeRequest -> BadgeMasterKey
+requestMasterKey BadgeRequest {masterKey} = masterKey
+
+assertedEntryId :: BadgeBalance -> Text
+assertedEntryId BadgeBalance {lastEntry = StatementEntry {entryId}} = entryId
+
+-- | Resolves the client's asserted @balance.lastEntry.entryId@ against this purchase's ledger.
+-- An assertion naming an entry the service holds is a prefix and becomes the cursor; one naming
+-- anything else -- an unknown uuid, or an entry belonging to a different purchase -- yields no
+-- cursor, and the complete history follows, which is the other answer the RPC permits
+-- ("Statement and balance"). Its third answer, one @opening@ credit restating the balance,
+-- needs opening entries, which nothing in this milestone writes.
+resolveCursor :: DB.Connection -> Int64 -> Text -> ExceptT ServiceError IO (Maybe StatementCursor)
+resolveCursor db pid entryUuid =
+  fmap (\eid -> StatementCursor {cursorEntryId = eid, cursorEntryUuid = entryUuid}) <$> getLedgerEntryIdByUuid db pid entryUuid
+
+-- | Redeems a code into a credential. The ordering is the contract, not a preference: the
+-- classification reads, the plan is computed in memory, the credential is signed, and only then
+-- is a transaction opened and written. Nothing is written before a signature succeeds or the
+-- plan proves none is needed, so a failing signature leaves the code unredeemed and retryable.
+--
+-- Only a classified failure debits the throttle buckets (@code_invalid@, @code_used@,
+-- @code_expired@, including a checksum rejection that never reached the database). A success
+-- and the same-key replay debit nothing: they are not failures, and an honest client that
+-- repeats a request after a timeout must not be throttled for it.
+handlePurchaseCode :: BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeRequest -> Text -> IO BadgeServiceResponse
+handlePurchaseCode bsEnv@BadgeServiceEnv {store, now} signerKey badgeRequest presentedCode = attempt redemptionAttempts
+  where
+    hash = codeHash (normalizeCode presentedCode)
+    attempt attemptsLeft = do
+      now' <- now
+      runExceptT (classifyRedemption now' signerKey lookupCode presentedCode) >>= \case
+        Left e -> storeFailed "purchaseBadge{code} classification" e
+        Right outcome -> case outcome of
+          -- a revoked code must read exactly like one that never existed (B3), so a guesser
+          -- cannot learn that a code once existed
+          RedeemInvalid -> failedRedemption BSECodeInvalid
+          RedeemRevoked -> failedRedemption BSECodeInvalid
+          RedeemUsedByOther -> failedRedemption BSECodeUsed
+          RedeemExpired -> failedRedemption BSECodeExpired
+          RedeemAlreadyRedeemedBySameKey pid -> replay now' pid
+          RedeemOk badgeType months -> redeem attemptsLeft now' badgeType months
+    -- Passed as an action so 'classifyRedemption' can reject a bad check character without ever
+    -- forcing it: 31 of every 32 random guesses cost no database round trip, and this read
+    -- transaction is not even opened for them (B3).
+    lookupCode h = ExceptT $ withServiceTransaction store (\db -> getCodeByHash db h)
+    failedRedemption code = do
+      debitFailureBuckets bsEnv signerKey
+      pure $ errorResponse code Nothing Nothing
+    -- RPC "Idempotency": the same code presented again by the same key returns the credential it
+    -- was already issued and records no second redemption. Healing the ledger is the only row
+    -- this path can append, and only when months have genuinely lapsed since -- the RPC has the
+    -- service heal its own ledger before answering any statement ("Statement and balance"), and
+    -- a statement that showed a balance the database does not hold would be worse than the row.
+    replay now' pid =
+      withServiceTransaction store (replayTxn now' pid) >>= \case
+        Left e -> storeFailed "purchaseBadge{code} replay" e
+        Right (credential, statement) -> do
+          when (isNothing credential) $
+            logWarn $ "no badge issuance found for the redemption being replayed by purchase " <> tshow pid
+          pure BSPBadgeCredential {credential, receipt = Nothing, statement}
+    replayTxn now' pid db = do
+      issuance <- getIssuanceForRedeemedCode db hash
+      statement <- purchaseStatement now' db Nothing pid
+      pure (issuanceCredential <$> issuance, statement)
+    redeem attemptsLeft now' badgeType months
+      -- The service signs exactly the content the client sent (RPC "Commands"), so a request
+      -- naming a tier the code does not fund is refused rather than silently signed as the
+      -- code's tier or, worse, as the tier asked for.
+      | requestedBadgeType badgeRequest /= badgeType = pure badRequest
+      | otherwise = do
+          -- minted before the plan, so the credit entry can name the payment row it references,
+          -- and before the transaction, so nothing but writes happens inside it
+          paymentUuid <- UUID.toText <$> UUID.nextRandom
+          withServiceTransaction store (planTxn now' badgeType months paymentUuid) >>= \case
+            Left e -> storeFailed "purchaseBadge{code} planning" e
+            Right (Left code) -> pure $ errorResponse code Nothing Nothing
+            Right (Right (row_, plan)) ->
+              resolveIssue bsEnv now' (rowPurchaseId <$> row_) badgeRequest (lpIssue plan) >>= \case
+                Left code -> pure $ errorResponse code Nothing Nothing
+                Right result ->
+                  withServiceTransaction store (writeTxn now' badgeType paymentUuid row_ plan {lpIssue = result}) >>= \case
+                    -- another request redeemed this code between the classification and this
+                    -- write; nothing of ours committed, so re-classify and answer what the code
+                    -- now is (a replay for this key, code_used for any other)
+                    Left SECodeConflict | attemptsLeft > 0 -> attempt (attemptsLeft - 1)
+                    Left e -> storeFailed "purchaseBadge{code} write" e
+                    Right statement ->
+                      pure BSPBadgeCredential {credential = issuedCredential result, receipt = Nothing, statement}
+    planTxn now' badgeType months paymentUuid db =
+      getPurchaseByKey db signerKey >>= \case
+        -- the normal case: C4 mints a fresh key per redemption, so there is no purchase row and
+        -- no ledger to read. Creating it is planned for the write transaction, not done here.
+        Nothing -> pure $ Right (Nothing, planLedger now' creditWith Nothing (initialLedgerState now' badgeType))
+        Just row@BadgePurchaseRow {badgePurchaseId, currentBadgeType}
+          -- a repeated key is only produced by a non-standard client; a code of a different tier
+          -- would have to convert the existing balance, and tier upgrades are out of scope (§6)
+          | currentBadgeType /= badgeType -> pure $ Left BSEBadRequest
+          | otherwise -> do
+              lastEntry <- getLastLedgerEntry db badgePurchaseId
+              let st0 = maybe (initialLedgerState now' badgeType) ledgerStateOf lastEntry
+              pure $ Right (Just row, planLedger now' creditWith (lastEntry >>= entryWasPausedSince) st0)
+      where
+        creditWith = Just (months, CTPayment paymentUuid)
+    writeTxn now' badgeType paymentUuid row_ plan db = do
+      row <- maybe (createPurchase db signerKey (requestMasterKey badgeRequest) badgeType now') pure row_
+      let pid = rowPurchaseId row
+      createCodePayment db paymentUuid now'
+      -- badge_purchases.payment_id is UNIQUE and holds at most one payment: a repeated key's
+      -- second code still gets its own payments row, which the credit entry references, but
+      -- leaves the purchase's pointer at the first one rather than repointing it
+      when (isNothing (rowPaymentId row)) $ attachPurchasePayment db pid paymentUuid now'
+      writeLedgerPlan db now' pid badgeType plan
+      -- last, so a code claimed in between rolls back everything above with it
+      markCodeRedeemed db hash pid now'
+      purchaseStatement now' db Nothing pid
+
+-- | Issues the next period from an existing balance: steps 4 to 6 with no code and no credit.
+-- It is the only command that re-issues, and C3's worker is its only caller.
+--
+-- An exhausted balance is not an error: the response carries no credential and the statement
+-- shows the zero balance. A repeat inside an already-issued month returns that month's cached
+-- credential and writes nothing (RPC "Idempotency").
+handleIssueBadge :: BadgeServiceEnv -> BadgePurchaseRow -> BadgeRequest -> BadgeBalance -> IO BadgeServiceResponse
+handleIssueBadge bsEnv@BadgeServiceEnv {store, now} row badgeRequest badgeBalance
+  -- as for purchaseBadge: the service signs the content it was sent, so a request naming a tier
+  -- other than the purchase's own is refused rather than signed
+  | requestedBadgeType badgeRequest /= currentType = pure badRequest
+  | otherwise = do
+      now' <- now
+      withServiceTransaction store (planTxn now') >>= \case
+        Left e -> storeFailed "issueBadge planning" e
+        Right (cursor, plan) ->
+          resolveIssue bsEnv now' (Just pid) badgeRequest (lpIssue plan) >>= \case
+            Left code -> pure $ errorResponse code Nothing Nothing
+            Right result ->
+              -- One transaction either way: an issued period writes its rows and reads the
+              -- statement back inside them, while a cached or exhausted issue writes nothing and
+              -- the same call is a plain read. Neither can report a balance the database does
+              -- not hold.
+              withServiceTransaction store (writeTxn now' cursor plan {lpIssue = result}) >>= \case
+                Left e -> storeFailed "issueBadge write" e
+                Right statement ->
+                  pure BSPBadgeCredential {credential = issuedCredential result, receipt = Nothing, statement}
+  where
+    BadgePurchaseRow {badgePurchaseId = pid, currentBadgeType = currentType} = row
+    planTxn now' db = do
+      cursor <- resolveCursor db pid (assertedEntryId badgeBalance)
+      lastEntry <- getLastLedgerEntry db pid
+      -- a purchase with no ledger at all has a zero balance, which 'planLedger' turns into
+      -- 'IssueExhausted': no credential, and an empty statement rather than an invented entry
+      let st0 = maybe (initialLedgerState now' currentType) ledgerStateOf lastEntry
+      pure (cursor, planLedger now' Nothing (lastEntry >>= entryWasPausedSince) st0)
+    writeTxn now' cursor plan db = do
+      writeLedgerPlan db now' pid currentType plan
+      purchaseStatement now' db cursor pid
@@ -28,11 +28,13 @@ module BadgeService.Store
    getPurchaseByKey,
    createPurchase,
    createCodePayment,
+    attachPurchasePayment,

    -- * Ledger
    getLastLedgerEntry,
    appendLedgerEntry,
    getLedgerSince,
+    getLedgerEntryIdByUuid,

    -- * Issuances
    NewIssuance (..),
@@ -108,8 +110,11 @@ data ServiceError
  | SECodeNotFound
  | SEPriceNotFound
  | SEOfferNotFound
-  | -- | 'createCodePayment' only: the purchase already has a payment attached.
+  | -- | 'attachPurchasePayment' only: the purchase already has a payment attached.
    SEPaymentConflict
+  | -- | 'markCodeRedeemed' only: the code was redeemed by a concurrent request between the
+    -- caller's classification and its write. The caller re-classifies from the code row.
+    SECodeConflict
  | SEDecodeError Text
  deriving (Eq, Show)

@@ -211,14 +216,14 @@ createPurchase db purchaseKey masterKey@(BadgeMasterKey mk) badgeType now = do
 codePaymentProviderText :: Text
 codePaymentProviderText = "code"

-- | Writes the @payments@ row (caller-minted UUID as @payment_id@, @provider = 'code'@,
-- @invoice_id@ NULL, @status = 'settled'@ via 'PSSettled'\'s 'ToField'), then points
-- the purchase's @payment_id@ at it. The second write is guarded by @payment_id IS NULL@ so a
-- purchase that already has a payment is never silently repointed; on no rows affected, a
-- follow-up existence check distinguishes an unknown purchase ('SEPurchaseNotFound') from one
-- that already has a payment ('SEPaymentConflict').
-createCodePayment :: DB.Connection -> Int64 -> Text -> UTCTime -> ExceptT ServiceError IO ()
-createCodePayment db badgePurchaseId paymentId now = do
+-- | Writes the @payments@ row alone (caller-minted UUID as @payment_id@, @provider = 'code'@,
+-- @invoice_id@ NULL, @status = 'settled'@ via 'PSSettled'\'s 'ToField'). Attaching it
+-- to the purchase is 'attachPurchasePayment', a separate call because the two are not always
+-- paired: @badge_purchases.payment_id@ is @UNIQUE@ and holds at most one payment, so a second
+-- code redeemed under a purchase key that already has one still needs its @payments@ row (the
+-- @credit(payment)@ ledger entry references it) but must not repoint the purchase.
+createCodePayment :: DB.Connection -> Text -> UTCTime -> ExceptT ServiceError IO ()
+createCodePayment db paymentId now =
  liftIO $
    DB.execute
      db
@@ -227,6 +232,13 @@ createCodePayment db badgePurchaseId paymentId now = do
        VALUES (?,?,?,?,?,?)
      |]
      (paymentId, Nothing :: Maybe Text, codePaymentProviderText, PSSettled, now, now)
+
+-- | Points the purchase's @payment_id@ at an existing payment. Guarded by @payment_id IS NULL@
+-- so a purchase that already has a payment is never silently repointed; on no rows affected, a
+-- follow-up existence check distinguishes an unknown purchase ('SEPurchaseNotFound') from one
+-- that already has a payment ('SEPaymentConflict').
+attachPurchasePayment :: DB.Connection -> Int64 -> Text -> UTCTime -> ExceptT ServiceError IO ()
+attachPurchasePayment db badgePurchaseId paymentId now = do
  attached <-
    liftIO $
      DB.query
@@ -265,18 +277,16 @@ ledgerSelectColumns =
  "entry_id, entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_badge_type, was_paused_since, service_created_at, created_at, "
    <> "entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id, from_purchase_id, to_purchase_id"

-- | @'CTPayment' {invoiceId}@ and @'CTCharge' {chargeId}@ are typed 'Int64' in
-- "Simplex.Chat.Badges.Types", but the columns they would persist through (@payment_id@,
-- @charge_id@) are the referenced tables' TEXT primary keys. This is not this step's
-- decision to paper over: it is already recorded as an open finding awaiting a human ruling
-- (SDD progress log, Phase A: "LedgerCreditType CTPayment.invoiceId/CTCharge.chargeId left
-- alone -- wrong against TEXT columns but marked confirmed... needs a human decision"). Both
-- directions reject the two constructors explicitly rather than inventing a silent, possibly
-- wrong, numeric<->text coercion.
+-- | @'CTCharge' {chargeId}@ is typed 'Int64' in "Simplex.Chat.Badges.Types", but the column it
+-- would persist through (@charge_id@) is @subscription_charges@\' TEXT primary key. Both
+-- directions reject that constructor explicitly rather than inventing a silent, possibly
+-- wrong, numeric<->text coercion; subscriptions are out of scope (plan \'6), so nothing writes
+-- one. @'CTPayment' {paymentId}@ had the same defect and is now 'Text', matching
+-- @badge_ledger.payment_id TEXT REFERENCES payments@ (B7, plan \'9).
 encodeLedgerEntryType :: LedgerEntryType -> ExceptT ServiceError IO LedgerTypeRow
 encodeLedgerEntryType = \case
  LECredit creditType -> case creditType of
-    CTPayment {} -> throwError $ SEDecodeError "CTPayment.invoiceId (Int64) does not fit the payment_id TEXT column; unresolved type mismatch, see SDD progress log"
+    CTPayment {paymentId} -> pure ("credit", Just "payment", Nothing, Just paymentId, Nothing, Nothing, Nothing)
    CTCharge {} -> throwError $ SEDecodeError "CTCharge.chargeId (Int64) does not fit the charge_id TEXT column; unresolved type mismatch, see SDD progress log"
    CTSupport -> pure ("credit", Just "support", Nothing, Nothing, Nothing, Nothing, Nothing)
    CTTransferIn {fromPurchaseId} -> pure ("credit", Just "transfer_in", Nothing, Nothing, Nothing, fromPurchaseId, Nothing)
@@ -293,6 +303,7 @@ encodeLedgerEntryType = \case

 decodeLedgerEntryType :: LedgerTypeRow -> Either ServiceError LedgerEntryType
 decodeLedgerEntryType row = case row of
+  ("credit", Just "payment", _, Just paymentId, _, _, _) -> Right $ LECredit (CTPayment paymentId)
  ("credit", Just "support", _, _, _, _, _) -> Right $ LECredit CTSupport
  ("credit", Just "transfer_in", _, _, _, fromPurchaseId, _) -> Right $ LECredit (CTTransferIn fromPurchaseId)
  ("credit", Just "opening", _, _, _, _, _) -> Right $ LECredit CTOpening
@@ -361,6 +372,21 @@ getLedgerSince db badgePurchaseId sinceEntryId = do
          (badgePurchaseId, sinceId)
  liftEither $ mapM rowToLedgerEntry rows

+-- | Resolves the wire @entryId@ (the row's @entry_uuid@, which is what a client asserts) to the
+-- local @entry_id@ 'getLedgerSince' queries on, scoped to one purchase: an entry belonging to a
+-- different purchase resolves to 'Nothing', so an asserted uuid cannot be used to probe another
+-- purchase's ledger. 'Nothing' also covers a uuid the service simply does not hold, which the
+-- RPC treats as an assertion that names nothing and answers with the complete history.
+getLedgerEntryIdByUuid :: DB.Connection -> Int64 -> Text -> ExceptT ServiceError IO (Maybe Int64)
+getLedgerEntryIdByUuid db badgePurchaseId entryUuid = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        "SELECT entry_id FROM sx_badge_service_badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?"
+        (badgePurchaseId, entryUuid)
+  pure $ fromOnly <$> listToMaybe rows
+
 -- Issuances ---------------------------------------------------------------------

 -- | Fields needed to create one @badge_issuances@ row. Unlike the shared 'BadgeIssuance',
@@ -525,6 +551,10 @@ getCodeByHash db codeHash = do
      code <- liftEither $ rowToCode codeRow
      pure $ Just (code, redeemerKey)

+-- | Claims an unredeemed code for a purchase. Guarded by @redeemed_purchase_id IS NULL@ so a
+-- redemption is never overwritten by a second one racing it: on no rows affected, a follow-up
+-- existence check distinguishes an unknown code ('SECodeNotFound') from one another request
+-- redeemed in between ('SECodeConflict'), which the caller answers by re-classifying.
 markCodeRedeemed :: DB.Connection -> ByteString -> Int64 -> UTCTime -> ExceptT ServiceError IO ()
 markCodeRedeemed db codeHash badgePurchaseId now = do
  rows <-
@@ -534,11 +564,18 @@ markCodeRedeemed db codeHash badgePurchaseId now = do
        [sql|
          UPDATE sx_badge_service_codes
          SET redeemed_purchase_id = ?, redeemed_at = ?
-          WHERE code_hash = ?
+          WHERE code_hash = ? AND redeemed_purchase_id IS NULL
          RETURNING code_hash
        |]
        (badgePurchaseId, now, Binary codeHash)
-  when (null (rows :: [Only (Binary ByteString)])) $ throwError SECodeNotFound
+  when (null (rows :: [Only (Binary ByteString)])) $ do
+    exists <-
+      liftIO $
+        DB.query
+          db
+          "SELECT 1 FROM sx_badge_service_codes WHERE code_hash = ?"
+          (Only (Binary codeHash))
+    throwError $ if null (exists :: [Only Int]) then SECodeNotFound else SECodeConflict

 -- | Clears both redemption columns and sets @unredeemed_at@, which both re-enables
 -- redemption and reopens E4's disclosure window.
@@ -140,7 +140,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat
 | B4 | Issuer key loading and credential signing | A5, A6, B2 | ☑ |
 | B5 | RPC dispatcher: envelope, version, signer, throttle | A2, A6, B1 | ☑ |
 | B6 | `getBadgeCatalog` | A4, B1, B2, B5 | ☑ |
-| B7 | `purchaseBadge{code}` and `issueBadge` | B1, B2, B3, B4, B5 | ☐ |
+| B7 | `purchaseBadge{code}` and `issueBadge` | B1, B2, B3, B4, B5 | ☑ |
 | B8 | `codes` operator subcommand | A4, B1, B3 | ☑ |
 | B9 | Service address publication | A6, B5 | ☐ |
 | B10 | Service integration tests | B7, B8 | ☐ |
@@ -551,7 +551,7 @@ Keep the existing `sendChatCmd cc (APISendServiceResponse …)` reply path.

 #### B7 — `purchaseBadge{code}` and `issueBadge`

-**Files:** `apps/simplex-badge-service/src/BadgeService/Service.hs`
+**Files:** `apps/simplex-badge-service/src/BadgeService/Service.hs`, `apps/simplex-badge-service/src/BadgeService/Store.hs`, `src/Simplex/Chat/Badges/Types.hs`, `tests/Bots/BadgeServiceTests.hs`

 **Do:** Signing is an IO action, so it is performed **before** any write and no transaction is held open across it.

@@ -560,14 +560,14 @@ Keep the existing `sendChatCmd cc (APISendServiceResponse …)` reply path.
 3. Resolve the purchase with `getPurchaseByKey`. If it is absent, which is the normal case since C4 mints a fresh key per redemption, plan its creation for step 6 rather than writing it here; nothing is written before the signature. A repeated key is only produced by a non-standard client: credit the months to that purchase's existing ledger, write no second purchase row, and return `bad_request` if the code's `badge_type` differs from that purchase's, until tier upgrades land (§6).
 4. Compute the prospective ledger state in memory with B2's pure functions: `advance now`, then `credit now months (SCPayment Nothing)`, then `issue now`. A purchase absent in step 3 has no ledger entry to read, so its state is B2's `initialLedgerState now` seeded with the code's `badge_type`. `invoiceId` is absent for code payments (`Badges/Service.hs:162`). `advance` may yield one `debit(lapse)` entry; it belongs to the write set, not to a computation that is discarded.

-   `issue` returns `Nothing` in two cases, and the answer also depends on the command. With a zero balance, which only `issueBadge` reaches since every code credits at least one month (B8), go to step 6 if `advance` produced a `debit(lapse)`, writing that entry alone, and otherwise straight to step 7. When step 6 runs, the `statement` is read back inside its transaction; when nothing is written, it is read in a single read transaction. Either way it never shows a balance the database does not hold. With a positive balance the current month is already issued. Take `balanceStartTs` from the state `advance` left, and fetch the credential for the period `[addMonths (-1) balanceStartTs, balanceStartTs)` with B1's `getIssuanceForPeriod`. That period is the current month because the previous `issue` moved `balanceStartTs` to the start of the next unissued month, which is past `now`; `advance` therefore returns `Nothing` here. For `issueBadge` there is nothing to record, so return it and write nothing (RPC §Idempotency). For `purchaseBadge{code}` the credit must still be recorded, so go to step 6 with the fetched credential in place of a fresh signature and with neither a `debit(badge)` entry nor an issuance row to write, since that month's issuance and its debit already exist and B2 property 3 keeps them 1:1; only the code redemption, the payment row, any `debit(lapse)` and the `credit(payment)` entry are recorded. Neither case reaches step 5.
+   `issue` returns `Nothing` in two cases, and the answer also depends on the command. With a zero balance, which only `issueBadge` reaches since every code credits at least one month (B8), go to step 6 if `advance` produced a `debit(lapse)`, writing that entry alone, and otherwise straight to step 7. When step 6 runs, the `statement` is read back inside its transaction; when nothing is written, it is read in a single read transaction. Either way it never shows a balance the database does not hold. With a positive balance the current month is already issued. Fetch its credential with B1's `getIssuanceForPeriod` probed **at `now`**, not at `addMonths (-1) balanceStartTs` (§9): `now` is inside that period because the previous `issue` moved `balanceStartTs` to the start of the next unissued month, which is past `now`, while its own period start is at or before the instant that issue ran; `advance` therefore returns `Nothing` here. For `issueBadge` there is nothing to record, so return it and write nothing (RPC §Idempotency). For `purchaseBadge{code}` the credit must still be recorded, so go to step 6 with the fetched credential in place of a fresh signature and with neither a `debit(badge)` entry nor an issuance row to write, since that month's issuance and its debit already exist and B2 property 3 keeps them 1:1; only the code redemption, the payment row, any `debit(lapse)` and the `credit(payment)` entry are recorded. Neither case reaches step 5.
 5. Sign the resulting period with B4. **A signing failure returns `internal` and writes nothing**; the code stays unredeemed and the client may retry it.
-6. No write happens before a signature succeeds or step 4 proves one unnecessary. Then open one transaction and write, in order: the `badge_purchases` row if absent, through `createPurchase`; the `payments` row through `createCodePayment`; the `debit(lapse)` entry `advance` produced in step 4, if any; the `credit(payment)` entry; the `debit(badge)` entry; the issuance row carrying the signed credential; and `redeemed_purchase_id` with `redeemed_at` on the code. A conflict on the code's redemption columns aborts the transaction and re-classifies from step 1.
+6. No write happens before a signature succeeds or step 4 proves one unnecessary. Then open one transaction and write, in order: the `badge_purchases` row if absent, through `createPurchase`; the `payments` row through `createCodePayment`, pointed at by the purchase through `attachPurchasePayment` only when the purchase has no payment yet (§9); the `debit(lapse)` entry `advance` produced in step 4, if any; the `credit(payment)` entry; the `debit(badge)` entry; the issuance row carrying the signed credential; and `redeemed_purchase_id` with `redeemed_at` on the code. A conflict on the code's redemption columns aborts the transaction and re-classifies from step 1.

   `@payments` has no `price_id` or `offer_id` columns (`M20260731_user_badges.hs:42-56`), so core §5's "price_id and offer_id NULL" does not apply. A code purchase writes no `@badge_invoices` row.
 7. Respond `BSPBadgeCredential {credential, receipt, statement}` with `receipt = Nothing`. The receipt is the transfer instrument for unissued months and belongs to the `SPReceipt` payment this plan defers (§6); the service writes no `receipt_hash` (A3) and C4 stores nothing for it. An exhausted balance is not an error: `credential = Nothing`, with the statement showing the zero balance.

-`issueBadge` performs steps 4 to 6 against an existing balance, with no code involved. It is the only command that re-issues, and C3's worker is its only caller.
+`issueBadge` performs steps 4 to 6 against an existing balance, with no code involved. It is the only command that re-issues, and C3's worker is its only caller. It is also the only command carrying an asserted cursor (`balance.lastEntry.entryId`): resolve it against this purchase's ledger and return the entries after it with `previousEntryId` echoing it, or the complete history when it names nothing (§9).

 **Verify:** covered by B10.

@@ -1342,16 +1342,27 @@ Append here when a step contradicts this plan: the step id, what was wrong, and
  - `relay_request_execute_at`'s default, which the dump renders in the server's timezone: `'1970-01-01 01:00:00+01'` in the committed file versus `'1970-01-01 00:00:00+00'` here. The same instant; the committed rendering was kept to avoid a spurious flip.
 - **The Postgres schema-dump spec cannot pass on Linux as written. Pre-existing, unrelated to badges.** Two independent causes, and together they explain why this dump had drifted. First, `tests/PostgresSchemaDump.hs:71` selects `sed -i ''` — BSD/macOS syntax — unless `envCI` is true, and `envCI` is `lookupEnv "CI" == Just "true"` (`tests/ChatTests/Utils.hs:117`). A developer on Linux running locally, without `CI=true`, gets the macOS branch and the spec dies on `sed: can't read /^--/d`. The flag conflates "running in CI" with "has GNU sed". Second, even with `CI=true`, the spec compares a freshly dumped schema against the committed file without stripping `\restrict`/`\unrestrict`, so any patched `pg_dump` fails the comparison non-deterministically. Fixing either is outside this plan; note both before relying on that spec.
 - **A2 — three more `Int64` id fields need the same correction the step already mandates.** The step lists `BadgePurchase.paymentId`, `BadgePayment.paymentId` and `BadgeIssuance.issuanceId`. An audit of `badges-rpc.schema.json` against all four modules found the same defect in three further places, all `TEXT` columns typed as `Int64`: `StatementCreditType.SCCharge {chargeId}` (`Badges/Service.hs:163`, against `subscription_charges.charge_id TEXT NOT NULL PRIMARY KEY`), and `BadgeCharge.chargeId` and `BadgeCharge.paymentId` (`Badges/Types.hs:163-164`). `SCCharge` is the load-bearing one: it is a wire type whose `taggedObjectJSON` instance A2 writes, the schema declares `chargeId` as `string` (`badges-rpc.schema.json:230`), and Aeson would encode an `Int64` as a JSON number — so leaving it ships a payload that fails its own schema. Its sibling `SCPayment` already carries `Maybe InvoiceId`, a newtype over `Text`. A2 corrects all six.
- **`LedgerCreditType.CTPayment {invoiceId :: Int64}` and `CTCharge {chargeId :: Int64}` are wrong against their columns but are marked `-- confirmed`. OPEN — needs a decision, not a mechanical fix.** `invoices.invoice_id` and `subscription_charges.charge_id` are both `TEXT`. These are the DB-side twins of the wire types above, and `CTTransferIn {fromPurchaseId :: Maybe Int64}` beside them is correct because `from_purchase_id` really is `INTEGER`. A2 does not touch them: they sit outside its tagged-sum list, and altering a type someone marked confirmed is above a mechanical step. C1's `insertLedgerEntries` is the first code that would persist them, so this must be settled before C1.
+- **`LedgerCreditType.CTPayment {invoiceId :: Int64}` and `CTCharge {chargeId :: Int64}` are wrong against their columns but are marked `-- confirmed`. `CTPayment` RESOLVED by B7 below; `CTCharge` still OPEN — needs a decision, not a mechanical fix.** `invoices.invoice_id` and `subscription_charges.charge_id` are both `TEXT`. These are the DB-side twins of the wire types above, and `CTTransferIn {fromPurchaseId :: Maybe Int64}` beside them is correct because `from_purchase_id` really is `INTEGER`. A2 does not touch them: they sit outside its tagged-sum list, and altering a type someone marked confirmed is above a mechanical step. C1's `insertLedgerEntries` is the first code that would persist them, so this must be settled before C1.
 - **A4 — `offerTotal` calls `error` on an impossible offer, which B6 and D4 must not let reach a request thread.** `chargeableMonths` (`BadgeService/Catalog.hs`) rejects `freeMonths >= months` with `error` rather than wrapping a `Word8` subtraction, and `seedCatalog` forces it at startup so a bad catalog kills the process before the service accepts traffic. That fences it for Phase A, where `seedCatalog` is the only writer. It stops being fenced the moment `offerTotal`/`catalogTotals` run inside request handling over rows read from the database, which is B6 (`getBadgeCatalog`) and D4 (`/api/catalog`). The bot's `processQueuedRequests` is a single-threaded `forever` loop (`BadgeService/Service.hs:96-99`), so an uncaught `error` there would take the whole service down for every user rather than failing one request — strictly worse than the mispricing the guard prevents. Before B6, either give `BadgeOffer` a smart constructor so `freeMonths >= months` is unrepresentable, or catch at the request boundary so the blast radius is one response.
 - **B6 — resolves the A4 `offerTotal`/`error` hazard above with a third option: a typed absence, not either option this plan named.** Neither a smart constructor (would change `BadgeOffer`'s shape and every construction site, including the seeded defaults) nor a request-boundary catch (relies on `runHandler`'s catch-all reaching every caller, including D4's future HTTP path, which does not share that catch-all) was taken. Instead `chargeableMonths :: Word8 -> Word8 -> Maybe Word8` and `offerTotal :: BadgePrice -> Maybe BadgeOffer -> Maybe CurrencyAmount` (`BadgeService/Catalog.hs`): `freeMonths >= months` now answers `Nothing`, which A2 already defines on the wire as "no computed total, render unavailable" — so the blast radius of one bad row is one offer, not one response and not one process, and the fix is shared by every caller of `offerTotal`, present or future, not just ones inside a `catch`. `seedCatalog` still fails the process at startup, by name (`requireTotal`), for a bad *default* catalog, so the Phase A guarantee is unchanged. `handleGetBadgeCatalog` additionally logs (`logUnpricedOffers`) when a *database* row reaches this state, since nothing else would ever say why a live offer reads as unavailable. **Fix round 1** found the same hazard on `ODDiscount`'s sibling arm, which the original pass missed: `100 - percent` on a bare `Word8` wraps for `percent > 100` (a `Store.decodeDiscount` value is not range-checked on the way in), producing a 2.55x *overcharge* rather than a crash — worse than the `freeMonths` case, since it inflates the price instead of merely reading as unavailable. `discountedPercent :: Word8 -> Maybe Word8` closes it the same way, `percent > 100 -> Nothing`.
 - **B6 fix round 1 — `seedCatalog`'s `requireTotal` is stricter than the `forceTotal` it replaced: an unpinned offer's `total = Nothing` is now also rejected at startup, not just an unchargeable one.** The predecessor (`forceTotal`, pre-B6) accepted `total = Nothing` unconditionally — its Haddock read "an offer whose price isn't found... gets `total = Nothing` rather than a crash, same as an unpinned offer" — because at the time nothing distinguished "unpinned" from "not chargeable" and neither was thought worth failing startup over. B6's `requireTotal` rejects `total = Nothing` for either reason: correct for today's `defaultCatalog` (every seeded offer is pinned, so only "not chargeable" is reachable), but a real behaviour change per §4 rule 6 — a future unpinned *default* offer would now fail the service at startup rather than silently seed with no total. Recorded rather than re-litigated, since the stricter behaviour is the one actually wanted (an unpinned default offer is exactly the kind of bad row `seedCatalog` should catch by name, not seed silently).
 - **B6 — `BadgeService/Config.hs` is touched, outside the step's stated file list (`Service.hs`, `tests/Bots/BadgeServiceTests.hs`).** `takeCatalogBucket` (the peek-and-debit STM action for the unsigned-`getBadgeCatalog` bucket B5 added but never wired) had to be added there to satisfy the Verify line's throttle case — B5 built the bucket itself but not a way to spend from it, and that action belongs beside `checkFailureBuckets`/`debitFailureBuckets`, the other bucket operations, not in `Service.hs`. §4 rule 6 was applied to the `Catalog.hs` deviation (the two entries above) but missed this one in the original pass; recorded here on the same rule.
 - **§4 — the stated build command did not work; corrected in place.** `cabal build simplex-chat simplex-badge-service` fails with `Ambiguous target 'simplex-chat'`, because `simplex-chat` names both a library and an executable component. It is now `cabal build lib:simplex-chat exe:simplex-chat simplex-badge-service`, which was run and succeeds. The test command beside it was correct as written and passes: 41 examples, 0 failures across both `Supporter badges` and `Badge service`.
 - **B1 — two vocabularies are now spelled only in `BadgeService/Store.hs`, with nothing tying them to a future codec.** The ledger's `entry_credit_type`/`entry_debit_type` values (`support`, `opening`, `transfer_in`, …) and the payment provider literal `code` are written as bare strings, because no `ToField`/`FromField` instance exists for `LedgerCreditType`, `LedgerDebitType` or `PaymentProvider` anywhere in the repo. Neither is a *duplicate* spelling today, so neither is a defect. Both become one the moment a later step adds a codec: D0, E2 and F1 need a real `PaymentProvider` encoding, and whoever resolves the `LedgerCreditType` question above will need the entry-type spellings to match what B1 already wrote. Reuse these spellings rather than inventing a second set, and prefer deriving both directions from one instance, as `BadgePurchaseStatus` and `BadgeItemStatus` do.
- **B5 — the per-signer bucket sweeper is built and tested but nothing schedules it. B7 must wire it to a timer. OPEN.** The original hazard is closed: `peekSignerBucket` no longer creates an entry for an unseen key, so a freshly minted keypair costs nothing, and an entry is created only by a classified failure — which also spends a token from the single shared global bucket, capping new entries per window at that bucket's capacity however many keys an attacker mints. `sweepSignerBuckets` evicts recovered entries and `sweepSignerBucketsIO` takes the injectable clock so eviction is provable without sleeping. What is missing is a caller: nothing runs the sweep on an interval, so the map only shrinks when something asks it to. This costs nothing during B5, where `debitFailureBuckets` has no caller at all and the map is provably empty on every reachable path. **B7 is the first step that makes a redemption fail, so B7 owns wiring the sweep onto a timer** — a third arm of the service's `raceAny_` alongside the bot and the reconciliation pass is the natural place.
+- **B5 — the per-signer bucket sweeper is built and tested but nothing schedules it. B7 must wire it to a timer. RESOLVED by B7 below.** The original hazard is closed: `peekSignerBucket` no longer creates an entry for an unseen key, so a freshly minted keypair costs nothing, and an entry is created only by a classified failure — which also spends a token from the single shared global bucket, capping new entries per window at that bucket's capacity however many keys an attacker mints. `sweepSignerBuckets` evicts recovered entries and `sweepSignerBucketsIO` takes the injectable clock so eviction is provable without sleeping. What is missing is a caller: nothing runs the sweep on an interval, so the map only shrinks when something asks it to. This costs nothing during B5, where `debitFailureBuckets` has no caller at all and the map is provably empty on every reachable path. **B7 is the first step that makes a redemption fail, so B7 owns wiring the sweep onto a timer** — a third arm of the service's `raceAny_` alongside the bot and the reconciliation pass is the natural place.
 - **A6 — a duplicated ini section or key is silently accepted, keeping only one of the two. OPEN.** `Data.Ini`'s `parseIni` is `parseOnly iniParser` over a `many`-based parser, so it essentially cannot fail on malformed-but-textual input: `many` never fails and `parseOnly` does not require full input consumption, so trailing garbage is dropped without error. `readIniFile` therefore returns `Left` only on I/O errors. Two consequences the config parser does not check for. A repeated `[section]` header discards the earlier block entirely, because `iniSections` is a `HashMap.fromList` and the last value wins; a repeated key within one section keeps the first, because the lookup takes the first match. If the surviving block is itself valid, the service starts with a silently wrong configuration — including, for instance, a secret-file path from the wrong block. Add a duplicate-section and duplicate-key check to `Config.hs`, and until then say so in the operator documentation at H5.
 - **A6 — `seedCatalog` calls `getCurrentTime` directly, against the rule that only `BadgeServiceEnv.now` reads the clock.** This is structurally forced rather than an oversight: `seedCatalog` runs before `newBadgeServiceEnv` exists, since the env is built after migrations and seeding. Either seed later, or give `seedCatalog` a clock parameter, whenever a step first needs to control service time across startup.
+- **B7 — `CTPayment` is now `{paymentId :: Text}`, closing the open item above.** The column it persists through is `badge_ledger.payment_id TEXT REFERENCES @payments` (`M20260731_user_badges.hs:148`), and `@payments.payment_id` is a `TEXT` primary key (`:43`) — so the field is the *payment's* id, not the invoice's, and `Text` is the only type that fits. `BadgeService.Store`'s `encodeLedgerEntryType`/`decodeLedgerEntryType` now persist and read `credit`/`payment` rows instead of refusing them, and B6's `statementEntryType` converts one to `SCPayment {invoiceId = Nothing}` instead of refusing it. The wire field is the *invoice's* id, which a code payment does not have (B7 step 4), so `Nothing` is correct for every payment this milestone writes. It stops being correct for an invoice-funded payment: `payments.invoice_id` is the join that resolves it, which `statementEntryType` (pure, connection-free) cannot do — **whichever step first credits an invoice-funded payment must resolve the invoice id before the entry reaches the statement.** `CTCharge` is untouched and still refused in both directions: subscriptions are out of scope (§6), so nothing writes one.
+- **B7 — the per-signer bucket sweep now runs on a timer, closing B5's open item above.** `sweepSignerBucketsLoop` is a third arm of `raceAny_` in **both** entry points — `badgeService` (the default, which the test harness and the shipped binary use, and which had no `raceAny_` at all before: its event loop moved into `processServiceEvents`) and `badgeServiceCLI`. The interval is a named constant, `signerBucketSweepIntervalSeconds = 600`, and it is real time (`threadDelay`), not `BadgeServiceEnv.now`: it schedules the sweep rather than deciding anything, and the eviction itself still reads the injectable clock through `sweepSignerBucketsIO`, so B10 proves eviction by calling that directly rather than waiting on the loop.
+- **B7 — the already-issued month's credential is fetched by probing `getIssuanceForPeriod` at `now`, not at `addMonths (-1) balanceStartTs` as step 4 said.** `addMonths` is deliberately not additive under clamping (`Badges/Months.hs`: 31 Jan + 1 month = 28 Feb, and 28 Feb − 1 month = 28 **Jan**), so stepping a month back from a clamped period boundary can land *before* the period it came from and match the issuance for the month before — returning the wrong credential, not merely none. `now` is inside the period by construction (`balanceStartTs > now` is why `issue` returned `Nothing`, and the period's start is at or before the instant that issue ran, hence at or before `now`), so it names exactly one issuance with no arithmetic at all. Step 4 corrected in place.
+- **B7 — B1's `createCodePayment` is split into `createCodePayment` (the `@payments` row) and `attachPurchasePayment` (the purchase's pointer).** Step 3 requires a second code redeemed under a key that already has a purchase to credit that purchase's existing ledger, and step 6 requires the `payments` row for the `credit(payment)` entry to reference — but `@badge_purchases.payment_id` is `UNIQUE` and holds at most one payment (`M20260731_user_badges.hs:99,104`), so the combined function could only answer `SEPaymentConflict` there. The second code now gets its own `payments` row while the purchase's pointer stays on the first. `createCodePayment` had no caller before B7, so nothing else changed. Step 6 corrected in place.
+- **B7 — `markCodeRedeemed` is now guarded and a new `SECodeConflict` exists.** Step 6's "a conflict on the code's redemption columns aborts the transaction and re-classifies from step 1" had nothing to detect a conflict with: B1's `UPDATE` was unguarded and would have silently overwritten another key's redemption. It is now `WHERE code_hash = ? AND redeemed_purchase_id IS NULL`, with an existence check separating `SECodeNotFound` from `SECodeConflict`. The handler retries the whole redemption exactly once on `SECodeConflict` (`redemptionAttempts = 1`); the second pass is terminal, because a redeemed code cannot become unredeemed by itself.
+- **B7 — a `badgeRequest` naming a different tier than the funding is refused with `bad_request`. Not in the step, and it is a security boundary.** RPC "Commands": "the service signs exactly this content or rejects the command". Without the check, a client could present a `supporter` code (or hold a `supporter` balance) and be handed a signed **`legend`** credential, since `issueSignedBadge` overrides only `badgeExpiry` and signs the `badgeInfo` it is given. `purchaseBadge{code}` now requires `badgeRequest.badgeInfo.badgeType` to equal the code's `badge_type`, and `issueBadge` requires it to equal the purchase's `current_badge_type`.
+- **B7 — `purchaseBadge` carrying an `upgrade` is `bad_request`, before the payment is looked at.** `BSCPurchaseBadge.upgrade` is the store one-time upgrade (RPC "Upgrades"), which needs store evidence, and tier upgrades are out of scope (§6). Ignoring the field would consume the code while silently dropping what the client asked for.
+- **B7 — `issueBadge` honours the asserted cursor, closing B6's "`previousEntryId` cannot be populated" gap.** `issueBadge` is the only implemented command carrying `balance.lastEntry.entryId`. A new store function, `getLedgerEntryIdByUuid`, resolves that wire uuid to the local `entry_id`, scoped to the purchase so an asserted uuid cannot probe another purchase's ledger; `purchaseStatement` now takes a `Maybe StatementCursor` carrying both halves, so `previousEntryId` always echoes the value the client actually sent and is never spelled independently of the id the query runs on. An assertion naming nothing yields the complete history, which is the RPC's other permitted answer; its third — one `opening` credit restating the balance — needs opening entries, which nothing in this milestone writes. `purchaseStatement` also takes the `badge_purchase_id` rather than the whole `BadgePurchaseRow`, since the replay path has only the id. `getBadgeCatalog` and `purchaseBadge` carry no cursor and pass `Nothing`.
+- **B7 — the same-key replay path does heal the ledger, which step 2's "writes nothing" reads as forbidding.** "Writes nothing" is kept for everything the redemption would record — no second purchase, payment, credit, debit, issuance or redemption — but the statement is still read through `purchaseStatement`, which appends one `debit(lapse)` when months have genuinely lapsed since. The RPC has the service heal its own ledger before answering any statement ("Statement and balance"), B6's read-only `getBadgeCatalog` already does exactly this, and the alternative is telling the client a balance the database does not hold. A replay immediately after a timeout — the case §Idempotency is about — lapses nothing and so writes nothing.
+- **B7 — two transactions per command, not one.** "One transaction per command" is kept for *writing*: the classification and the plan are read in a transaction that writes nothing, signing happens with no transaction open (which the step requires), and one further transaction does every write and reads the statement back inside it. `IssueCached` adds a third, read-only, to fetch the cached credential. A command with nothing to write opens exactly one, and writes nothing in it.
+- **B7 — an existing B5 test's expected code changed.** `testBadgeServicePurchaseBadgeUnknownKeyIsNotUnknownPurchaseKey` asserted `internal` because `purchaseBadge` was unimplemented; `"UNKNOWN-CODE"` now reaches the classifier, normalizes to 11 characters and fails the check character, so it is `code_invalid`. Its load-bearing assertion — never `unknown_purchase_key` — is unchanged. B10 replaces the surrounding suite.
 - **A1 — `chat_lint.sql` gains 5 fkey-index advisories, left unfixed by design.** The badge migration introduces unindexed foreign keys: `badge_invoices.offer_id`, `badge_invoices.price_id`, `badge_offers.price_id`, `badge_issuances.entry_id`, `users.shown_badge_id`. The lint output is committed literally rather than adding indexes, since index design is outside A1's scope and the repo has precedent for this (`9e000d6bc`). The first three point at rarely-mutated reference tables. The last two are the ones likely to matter under load — `badge_issuances.entry_id` for issuance lookup by ledger entry, and `users.shown_badge_id` for per-user badge display (C1's `getShownPurchase`). Decide on indexes for those two before release.

 ## 10. End-to-end verification
@@ -80,7 +80,10 @@ data LedgerEntryType = LECredit {credit :: LedgerCreditType} | LEDebit {debit ::

 -- confirmed
 data LedgerCreditType
-  = CTPayment {invoiceId :: Int64}
+  = -- | badge_ledger.payment_id TEXT REFERENCES payments -- the payment's own id, not the
+    -- invoice's: a code payment has no invoice at all, and an invoice-funded payment reaches
+    -- its invoice through payments.invoice_id.
+    CTPayment {paymentId :: Text}
  | CTCharge {chargeId :: Int64}
  | CTSupport
  | CTTransferIn {fromPurchaseId :: Maybe Int64}
@@ -362,9 +362,9 @@ testBadgeServiceIssueBadgeUnknownKey ps =
    client <## "service response: {\"code\":\"unknown_purchase_key\",\"type\":\"error\"}"

 -- The rule easy to get backwards (B5 brief): purchaseBadge from an unknown key is the normal
-- first-purchase case, not an identity error. Before B7 lands it reaches the not-implemented
-- handler (internal); after B7 the code classifier answers it -- either way, the assertion
-- that must hold across that later change is that it is never unknown_purchase_key.
+-- first-purchase case, not an identity error. B7's code classifier now answers it: "UNKNOWN-CODE"
+-- normalizes to 11 characters and fails the check character, so it is code_invalid -- reached
+-- only because the identity check let an unknown key through in the first place.
 testBadgeServicePurchaseBadgeUnknownKeyIsNotUnknownPurchaseKey :: HasCallStack => TestParams -> IO ()
 testBadgeServicePurchaseBadgeUnknownKeyIsNotUnknownPurchaseKey ps =
  withBadgeService ps $ \client bsLink -> do
@@ -374,7 +374,7 @@ testBadgeServicePurchaseBadgeUnknownKeyIsNotUnknownPurchaseKey ps =
    sendSignedServiceRequest client bsLink priv req
    respObj <- getServiceResponseObject client
    KM.lookup "code" respObj `shouldNotBe` Just (J.String "unknown_purchase_key")
-    KM.lookup "code" respObj `shouldBe` Just (J.String "internal")
+    KM.lookup "code" respObj `shouldBe` Just (J.String "code_invalid")

 -- pauseBadge is always bad_request (decision 5 / §6), but ONLY once the signer/record
 -- precondition passes -- a signer with a real purchase row (B1's createPurchase) must reach