core: badge service rpc dispatcher

apps/simplex-badge-service/src/BadgeService/Config.hs

@@ -13,23 +13,34 @@ module BadgeService.Config
     StripeConfig (..),
     ServiceConfig (..),
     ReconcileConfig (..),
+    BucketLimits (..),
+    ThrottleConfig (..),
     BadgeServiceConfig (..),
     readBadgeServiceConfig,
+    TokenBucket (..),
+    SignerBucketFamily (..),
     BadgeServiceEnv (..),
     newBadgeServiceEnv,
+    checkFailureBuckets,
+    debitFailureBuckets,
   )
 where
 
 import BadgeService.Codes (loadCodeSecret)
 import BadgeService.Credentials (loadIssuerKey)
+import Control.Concurrent.STM
 import Data.ByteString (ByteString)
 import Data.Ini (Ini, keys, lookupValue, readIniFile, sections)
+import qualified Data.Map.Strict as M
 import Data.Maybe (isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
+import Data.Word (Word32)
 import Simplex.Messaging.Agent.Store.Common (DBStore)
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (BBSSecretKey)
+import Simplex.Messaging.Encoding.String (strEncode)
 import Simplex.Messaging.Util (eitherToMaybe)
 import System.Directory (doesFileExist)
 import Text.Read (readMaybe)
@@ -83,6 +94,32 @@ newtype ReconcileConfig = ReconcileConfig
   }
   deriving (Eq, Show)
 
+-- | One bucket family's fixed shape (B5 decision 5): capacity doubles as the hourly refill
+-- rate -- every bucket this service specifies is "N per hour, burst N", so there is no case
+-- that needs the two to differ -- and 'blStartTokens' is the token count a freshly created
+-- bucket starts with. Both overridable via '[throttle]' below, so a test can shrink a bucket
+-- to a size that empties predictably, or start it pre-drained, without waiting on real time.
+-- Capacity 0 is meaningless (never refills, so 'retryAfter' has no finite answer) and is
+-- never used by any caller.
+data BucketLimits = BucketLimits
+  { blCapacity :: Word32,
+    blStartTokens :: Word32
+  }
+  deriving (Eq, Show)
+
+-- | The three RPC token buckets' sizes (B5 decision 5): 'signerFailure' is keyed per signer
+-- and only shapes an honest client's retries -- a purchase key is self-asserted and cheap to
+-- mint. 'globalFailure' is the real control against a distributed guesser (the code's 95
+-- bits of entropy is the load-bearing defence, this bucket only bounds the attempt rate).
+-- 'catalog' bounds unsigned 'getBadgeCatalog', which has no signer to key on (B6). Defaults
+-- match the plan exactly; '[throttle]' overrides them at startup for B5/B6/B10's tests.
+data ThrottleConfig = ThrottleConfig
+  { signerFailure :: BucketLimits,
+    globalFailure :: BucketLimits,
+    catalog :: BucketLimits
+  }
+  deriving (Eq, Show)
+
 data BadgeServiceConfig = BadgeServiceConfig
   { issuer :: IssuerConfig,
     codes :: CodesConfig,
@@ -90,7 +127,8 @@ data BadgeServiceConfig = BadgeServiceConfig
     btcpay :: Maybe BtcPayConfig,
     stripe :: Maybe StripeConfig,
     service :: Maybe ServiceConfig,
-    reconcile :: Maybe ReconcileConfig
+    reconcile :: Maybe ReconcileConfig,
+    throttle :: ThrottleConfig
   }
   deriving (Eq, Show)
 
@@ -118,6 +156,7 @@ parseBadgeServiceConfig path ini = do
   stripeCfg <- parseStripe path ini
   serviceCfg <- parseService path ini
   reconcileCfg <- parseReconcile path ini
+  throttleCfg <- parseThrottle path ini
   if (isJust btcPayCfg || isJust stripeCfg) && not (isJust webCfg)
     then configError path "[web] section is required when a provider (btcpay or stripe) is configured"
     else
@@ -129,7 +168,8 @@ parseBadgeServiceConfig path ini = do
             btcpay = btcPayCfg,
             stripe = stripeCfg,
             service = serviceCfg,
-            reconcile = reconcileCfg
+            reconcile = reconcileCfg,
+            throttle = throttleCfg
           }
 
 issuerKeys :: [Text]
@@ -251,6 +291,48 @@ parseReconcile path ini
       intervalSeconds <- requiredInt path "reconcile" "interval_seconds" ini
       pure $ Just ReconcileConfig {reconcileIntervalSeconds = intervalSeconds}
 
+defaultSignerFailureLimits :: BucketLimits
+defaultSignerFailureLimits = BucketLimits {blCapacity = 10, blStartTokens = 10}
+
+defaultGlobalFailureLimits :: BucketLimits
+defaultGlobalFailureLimits = BucketLimits {blCapacity = 600, blStartTokens = 600}
+
+defaultCatalogLimits :: BucketLimits
+defaultCatalogLimits = BucketLimits {blCapacity = 600, blStartTokens = 600}
+
+throttleKeys :: [Text]
+throttleKeys =
+  [ "signer_failure_capacity",
+    "signer_failure_start_tokens",
+    "global_failure_capacity",
+    "global_failure_start_tokens",
+    "catalog_capacity",
+    "catalog_start_tokens"
+  ]
+
+-- | '[throttle]' is entirely optional, and so is every key within it: an absent section or
+-- key falls back to the production default (B5 decision 5), so B5's own config files (which
+-- never mention '[throttle]') get exactly those defaults, and only a test that wants a small
+-- or pre-drained bucket needs to write this section at all.
+parseThrottle :: FilePath -> Ini -> Either String ThrottleConfig
+parseThrottle path ini
+  | "throttle" `notElem` sections ini =
+      Right ThrottleConfig {signerFailure = defaultSignerFailureLimits, globalFailure = defaultGlobalFailureLimits, catalog = defaultCatalogLimits}
+  | otherwise = do
+      checkKnownKeys path "throttle" throttleKeys ini
+      signerCapacity <- optionalWord32 path "throttle" "signer_failure_capacity" (blCapacity defaultSignerFailureLimits) ini
+      signerStart <- optionalWord32 path "throttle" "signer_failure_start_tokens" (blStartTokens defaultSignerFailureLimits) ini
+      globalCapacity <- optionalWord32 path "throttle" "global_failure_capacity" (blCapacity defaultGlobalFailureLimits) ini
+      globalStart <- optionalWord32 path "throttle" "global_failure_start_tokens" (blStartTokens defaultGlobalFailureLimits) ini
+      catalogCapacity <- optionalWord32 path "throttle" "catalog_capacity" (blCapacity defaultCatalogLimits) ini
+      catalogStart <- optionalWord32 path "throttle" "catalog_start_tokens" (blStartTokens defaultCatalogLimits) ini
+      pure
+        ThrottleConfig
+          { signerFailure = BucketLimits {blCapacity = signerCapacity, blStartTokens = signerStart},
+            globalFailure = BucketLimits {blCapacity = globalCapacity, blStartTokens = globalStart},
+            catalog = BucketLimits {blCapacity = catalogCapacity, blStartTokens = catalogStart}
+          }
+
 -- Validation helpers ---------------------------------------------------------
 
 configError :: FilePath -> String -> Either String a
@@ -305,6 +387,19 @@ optionalInt path section key def ini = case lookupValue section key ini of
     Just n -> Right n
     Nothing -> configError path ("key '" <> T.unpack key <> "' in section [" <> T.unpack section <> "] must be an integer, got: " <> T.unpack v)
 
+-- | 'Word32's 'Read' instance wraps a negative literal instead of rejecting it (@"-1" ->
+-- 4294967295@), so a leading '-' is rejected by hand before 'readMaybe' ever sees it.
+optionalWord32 :: FilePath -> Text -> Text -> Word32 -> Ini -> Either String Word32
+optionalWord32 path section key def ini = case lookupValue section key ini of
+  Left _ -> Right def
+  Right v
+    | T.isPrefixOf "-" v -> badValue v
+    | otherwise -> case readMaybe (T.unpack v) of
+        Just n -> Right n
+        Nothing -> badValue v
+  where
+    badValue v = configError path ("key '" <> T.unpack key <> "' in section [" <> T.unpack section <> "] must be a non-negative integer, got: " <> T.unpack v)
+
 optionalBool :: FilePath -> Text -> Text -> Bool -> Ini -> Either String Bool
 optionalBool path section key def ini = case lookupValue section key ini of
   Left _ -> Right def
@@ -312,6 +407,82 @@ optionalBool path section key def ini = case lookupValue section key ini of
   Right "off" -> Right False
   Right v -> configError path ("key '" <> T.unpack key <> "' in section [" <> T.unpack section <> "] must be 'on' or 'off', got: " <> T.unpack v)
 
+-- Token buckets ---------------------------------------------------------
+
+-- | An in-memory token bucket (B5 decision 5): the token count as of 'tbUpdatedAt', refilled
+-- lazily from elapsed time whenever it is next read rather than ticked by a timer, so an idle
+-- bucket costs nothing. 'tbCapacity' is carried alongside the mutable fields because it is
+-- fixed per-bucket at creation (from that family's 'BucketLimits') and both the refill and the
+-- 'retryAfter' calculation need it.
+data TokenBucket = TokenBucket
+  { tbCapacity :: Word32,
+    tbTokens :: Double,
+    tbUpdatedAt :: UTCTime
+  }
+  deriving (Eq, Show)
+
+newTokenBucket :: BucketLimits -> UTCTime -> TokenBucket
+newTokenBucket BucketLimits {blCapacity, blStartTokens} now' =
+  TokenBucket {tbCapacity = blCapacity, tbTokens = fromIntegral blStartTokens, tbUpdatedAt = now'}
+
+-- | Refills 'tb' up to 'now'', capped at capacity. Pure and total: capacity 0 simply never
+-- adds anything (see 'bucketStatus' for where that would bite instead).
+refillBucket :: UTCTime -> TokenBucket -> TokenBucket
+refillBucket now' tb@TokenBucket {tbCapacity, tbTokens, tbUpdatedAt}
+  | elapsedHours <= 0 = tb
+  | otherwise = tb {tbTokens = min (fromIntegral tbCapacity) (tbTokens + elapsedHours * fromIntegral tbCapacity), tbUpdatedAt = now'}
+  where
+    elapsedHours = realToFrac (diffUTCTime now' tbUpdatedAt) / 3600
+
+-- | Refills to 'now'' and reports whether >=1 token is available and, if not, the seconds
+-- until one will be ('retryAfter'). Never debits -- only 'debitBucket' does that -- so calling
+-- this to decide whether to proceed costs an honest, successful caller nothing.
+bucketStatus :: UTCTime -> TokenBucket -> (Bool, Word32, TokenBucket)
+bucketStatus now' tb0 =
+  let tb@TokenBucket {tbCapacity, tbTokens} = refillBucket now' tb0
+   in if tbTokens >= 1
+        then (True, 0, tb)
+        else (False, retryAfter tbCapacity tbTokens, tb)
+  where
+    -- capacity 0 never refills and has no finite retryAfter; BucketLimits' Haddock says no
+    -- caller uses it, so this is an honest crash rather than a silently wrong number.
+    retryAfter 0 _ = error "bucketStatus: capacity 0 bucket has no finite retryAfter"
+    retryAfter capacity tokens = ceiling $ (1 - tokens) * 3600 / fromIntegral capacity
+
+debitBucket :: TokenBucket -> TokenBucket
+debitBucket tb@TokenBucket {tbTokens} = tb {tbTokens = max 0 (tbTokens - 1)}
+
+-- | The per-signer failure-bucket family: every signer key gets its own 'TokenBucket', built
+-- from 'sbLimits' the first time that key is seen. Keyed by the key's encoded bytes rather
+-- than 'C.PublicKeyEd25519' itself, which has no 'Ord' instance.
+data SignerBucketFamily = SignerBucketFamily
+  { sbLimits :: BucketLimits,
+    sbBuckets :: TVar (M.Map ByteString TokenBucket)
+  }
+
+newSignerBucketFamily :: BucketLimits -> IO SignerBucketFamily
+newSignerBucketFamily limits = SignerBucketFamily limits <$> newTVarIO M.empty
+
+peekSignerBucket :: UTCTime -> C.PublicKeyEd25519 -> SignerBucketFamily -> STM (Either Word32 ())
+peekSignerBucket now' signerKey SignerBucketFamily {sbLimits, sbBuckets} = do
+  buckets <- readTVar sbBuckets
+  let keyBytes = strEncode signerKey
+      tb0 = M.findWithDefault (newTokenBucket sbLimits now') keyBytes buckets
+      (ok, retryAfter, tb') = bucketStatus now' tb0
+  writeTVar sbBuckets $! M.insert keyBytes tb' buckets
+  pure $ if ok then Right () else Left retryAfter
+
+debitSignerBucket :: C.PublicKeyEd25519 -> SignerBucketFamily -> STM ()
+debitSignerBucket signerKey SignerBucketFamily {sbBuckets} =
+  modifyTVar' sbBuckets $ M.adjust debitBucket (strEncode signerKey)
+
+peekGlobalBucket :: UTCTime -> TVar TokenBucket -> STM (Either Word32 ())
+peekGlobalBucket now' var = do
+  tb <- readTVar var
+  let (ok, retryAfter, tb') = bucketStatus now' tb
+  writeTVar var tb'
+  pure $ if ok then Right () else Left retryAfter
+
 -- Runtime environment ---------------------------------------------------------
 
 -- | The single runtime value every badge service handler receives. A6 defines only the
@@ -329,11 +500,50 @@ data BadgeServiceEnv = BadgeServiceEnv
     codeSecret :: ByteString,
     -- | The issuer BBS secret key loaded from '[issuer] key_file' (B4): loaded once at
     --   startup, alongside 'config', so a malformed or absent key file fails fast.
-    issuerKey :: BBSSecretKey
+    issuerKey :: BBSSecretKey,
+    -- | B5 decision 5, keyed on the request's 'purchaseKey': 10 failed 'purchaseBadge{code}'
+    -- redemptions per hour, burst 10. Shapes an honest client's retries only.
+    signerFailureBucket :: SignerBucketFamily,
+    -- | B5 decision 5: 600 failed redemptions per hour, burst 600, service-wide. The real
+    -- control against a distributed guesser -- see 'signerFailureBucket''s Haddock.
+    globalFailureBucket :: TVar TokenBucket,
+    -- | B5 decision 5: bounds unsigned 'getBadgeCatalog' (no signer to key on), 600/hour,
+    -- burst 600, service-wide. Unused until B6 wires 'getBadgeCatalog' itself.
+    catalogBucket :: TVar TokenBucket
   }
 
 newBadgeServiceEnv :: BadgeServiceConfig -> DBStore -> IO BadgeServiceEnv
 newBadgeServiceEnv cfg st = do
   codeSecret <- loadCodeSecret (codesSecretFile (codes cfg))
   issuerKey <- loadIssuerKey (issuerKeyFile (issuer cfg)) (issuerKeyIdx (issuer cfg))
-  pure BadgeServiceEnv {config = cfg, store = st, now = getCurrentTime, codeSecret, issuerKey}
+  now0 <- getCurrentTime
+  signerFailureBucket <- newSignerBucketFamily (signerFailure (throttle cfg))
+  globalFailureBucket <- newTVarIO (newTokenBucket (globalFailure (throttle cfg)) now0)
+  catalogBucket <- newTVarIO (newTokenBucket (catalog (throttle cfg)) now0)
+  pure BadgeServiceEnv {config = cfg, store = st, now = getCurrentTime, codeSecret, issuerKey, signerFailureBucket, globalFailureBucket, catalogBucket}
+
+-- | The pre-processing gate for a signed 'purchaseBadge{code}' (B5 decision 5): peeks both
+-- the caller's per-signer bucket and the service-wide failure budget, WITHOUT debiting either
+-- -- only a failed redemption does that, via 'debitFailureBuckets'. 'Left' carries the
+-- retryAfter of whichever bucket is empty (the signer bucket takes precedence when both are,
+-- an arbitrary but deterministic choice).
+checkFailureBuckets :: BadgeServiceEnv -> C.PublicKeyEd25519 -> IO (Either Word32 ())
+checkFailureBuckets BadgeServiceEnv {now, signerFailureBucket, globalFailureBucket} signerKey = do
+  now' <- now
+  atomically $ do
+    signerResult <- peekSignerBucket now' signerKey signerFailureBucket
+    globalResult <- peekGlobalBucket now' globalFailureBucket
+    pure $ case signerResult of
+      Left _ -> signerResult
+      Right () -> globalResult
+
+-- | Debits one token from both failure buckets after a failed 'purchaseBadge{code}'
+-- redemption (code_invalid / code_used / code_expired, including a checksum rejection that
+-- never reached the database). Not called from B5: no code classifier exists yet, so no
+-- redemption can fail here. B7 calls this after a failed classification; B10 asserts the
+-- accounting.
+debitFailureBuckets :: BadgeServiceEnv -> C.PublicKeyEd25519 -> IO ()
+debitFailureBuckets BadgeServiceEnv {signerFailureBucket, globalFailureBucket} signerKey =
+  atomically $ do
+    debitSignerBucket signerKey signerFailureBucket
+    modifyTVar' globalFailureBucket debitBucket

apps/simplex-badge-service/src/BadgeService/Service.hs

@@ -2,32 +2,50 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module BadgeService.Service
   ( welcomeGetOpts,
     badgeService,
     badgeServiceCLI,
+    -- * Exposed for BadgeServiceTests: the catch-all's forcing behaviour is proved directly
+    -- against a lazily-thunked pure exception, not just observed indirectly through the RPC
+    -- round trip (which cannot yet construct one -- see B5's report).
+    runHandler,
   )
 where
 
 import BadgeService.Catalog (seedCatalog)
-import BadgeService.Config (BadgeServiceEnv, newBadgeServiceEnv, readBadgeServiceConfig)
+import BadgeService.Config (BadgeServiceEnv (..), checkFailureBuckets, newBadgeServiceEnv, readBadgeServiceConfig)
 import BadgeService.Options
+import BadgeService.Store (getPurchaseByKey, withServiceTransaction)
 import BadgeService.Store.Migrate (runBadgeServiceMigrations)
 import Control.Concurrent.STM
+import Control.Exception (SomeException, catch, evaluate)
 import Control.Logger.Simple
 import Control.Monad
 import qualified Data.Aeson as J
-import qualified Data.Aeson.KeyMap as KM
+import qualified Data.Aeson.Types as JT
+import qualified Data.ByteString.Lazy as LBS
+import Data.Text (Text)
 import qualified Data.Text as T
-import Simplex.Chat.Badges.Service (BadgeServiceErrorCode (..))
+import Data.Word (Word32)
+import Simplex.Chat.Badges.Service
+  ( BadgeServiceCommand (..),
+    BadgeServiceErrorCode (..),
+    BadgeServiceRequest (..),
+    BadgeServiceResponse (..),
+    minSupportedBadgeVersion,
+  )
 import Simplex.Chat.Bot (initializeBotAddress')
 import Simplex.Chat.Controller
 import Simplex.Chat.Core (sendChatCmd, simplexChatCore)
 import Simplex.Chat.Options (printDbOpts)
+import Simplex.Chat.PaymentService (ServicePayment (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
 import Simplex.Chat.Types (AgentInvId (..), User (..))
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (strEncode)
 import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow)
 import System.Directory (getAppUserDataDirectory)
@@ -36,7 +54,7 @@ import System.Exit (exitFailure)
 data ServiceState = ServiceState
   { serviceCC :: TMVar ChatController,
     serviceEnv :: TMVar BadgeServiceEnv,
-    serviceRequestQ :: TQueue (User, AgentInvId, J.Object)
+    serviceRequestQ :: TQueue (User, AgentInvId, Maybe C.PublicKeyEd25519, J.Object)
   }
 
 newServiceState :: IO ServiceState
@@ -64,12 +82,15 @@ badgeService opts cfg = do
           { preStartHook = Just $ badgePreStartHook opts env,
             postStartHook = Just $ badgePostStartHook opts env
           }
-  simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc ->
+  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
-        -- TODO enforce _sigKey == BadgeServiceRequest.purchaseKey (docs/protocol/badges-rpc.md).
-        Right (CEvtServiceRequest u reqId _sigKey reqData) -> handleServiceRequest cc u reqId reqData
+        Right (CEvtServiceRequest u reqId sigKey_ reqData) -> handleServiceRequest bsEnv cc u reqId sigKey_ reqData
         _ -> pure ()
 
 badgeServiceCLI :: BadgeServiceOpts -> IO ()
@@ -77,8 +98,8 @@ badgeServiceCLI opts = do
   env <- newServiceState
   let eventHook _cc ev = do
         case ev of
-          Right (CEvtServiceRequest u reqId _sigKey reqData) ->
-            atomically $ writeTQueue (serviceRequestQ env) (u, reqId, reqData)
+          Right (CEvtServiceRequest u reqId sigKey_ reqData) ->
+            atomically $ writeTQueue (serviceRequestQ env) (u, reqId, sigKey_, reqData)
           _ -> pure ()
         pure ev
       chatHooks =
@@ -95,9 +116,10 @@ badgeServiceCLI opts = do
 processQueuedRequests :: ServiceState -> IO ()
 processQueuedRequests env = do
   cc <- atomically $ readTMVar $ serviceCC env
+  bsEnv <- atomically $ readTMVar $ serviceEnv env
   forever $ do
-    (u, reqId, reqData) <- atomically $ readTQueue $ serviceRequestQ env
-    handleServiceRequest cc u reqId reqData
+    (u, reqId, sigKey_, reqData) <- atomically $ readTQueue $ serviceRequestQ env
+    handleServiceRequest bsEnv cc u reqId sigKey_ reqData
 
 -- 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
@@ -128,11 +150,128 @@ badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do
       unless noAddress $ initializeBotAddress' (not testing) (Just True) False cc
       void $ atomically $ tryPutTMVar (serviceCC env) cc
 
-handleServiceRequest :: ChatController -> User -> AgentInvId -> J.Object -> IO ()
-handleServiceRequest cc User {userId} reqId _reqData = do
+handleServiceRequest :: BadgeServiceEnv -> ChatController -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO ()
+handleServiceRequest bsEnv cc User {userId} reqId signerKey reqData = do
   let reqIdT = safeDecodeUtf8 (strEncode reqId)
-      respObj = KM.fromList [("type", J.String "error"), ("code", J.toJSON BSEUnsupportedVersion)]
   logInfo $ "badge service request " <> reqIdT
+  respObj <- runHandler reqIdT (dispatchRequest bsEnv signerKey reqData)
   sendChatCmd cc (APISendServiceResponse userId reqId respObj) >>= \case
     Right _ -> pure ()
     Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e
+
+-- | Runs 'action' and converts its result to a wire object, forcing that object fully
+-- (encoding it and demanding the whole encoded length) before returning, all still inside the
+-- 'catch' below. Laziness would otherwise let an exception escape uncaught: 'action' finishing
+-- and returning a lazily-built 'BadgeServiceResponse' does not itself throw, even if a field
+-- deep inside is an unevaluated 'error' thunk (as 'BadgeService.Catalog.chargeableMonths'
+-- produces for a malformed offer, once B6\/B7 wire catalog totals into request handling) --
+-- that thunk would only be forced later, by 'sendChatCmd''s own JSON encoding, OUTSIDE this
+-- function, where nothing would catch it. Forcing the encoding here, inside the 'catch',
+-- is what makes this a genuine catch-all rather than one that only covers IO exceptions.
+--
+-- 'processQueuedRequests' is a single-threaded 'forever' loop: an exception that got out of
+-- here would kill the service for every user, not just fail the one request that caused it.
+-- Every exception, IO or pure, is logged with the request id and turned into 'internal',
+-- never repeating its message back to the client.
+runHandler :: Text -> IO BadgeServiceResponse -> IO J.Object
+runHandler reqIdT action =
+  buildResponse `catch` \(e :: SomeException) -> do
+    logError $ "badge service internal error for " <> reqIdT <> ": " <> tshow e
+    pure $ responseObject BSPError {code = BSEInternal, message = Nothing, retryAfter = Nothing}
+  where
+    buildResponse = do
+      resp <- action
+      let obj = responseObject resp
+      _ <- evaluate (LBS.length (J.encode (J.Object obj)))
+      pure obj
+
+-- | 'BadgeServiceResponse's four constructors are all records, so 'taggedObjectJSON' always
+-- encodes them as a JSON object (never a bare string) -- the wildcard case cannot be hit by
+-- any value of this type; it exists only so this function is total.
+responseObject :: BadgeServiceResponse -> J.Object
+responseObject resp = case J.toJSON resp of
+  J.Object o -> o
+  _ -> error "BadgeServiceResponse always encodes to a JSON object"
+
+errorResponse :: BadgeServiceErrorCode -> Maybe Text -> Maybe Word32 -> BadgeServiceResponse
+errorResponse code message retryAfter = BSPError {code, message, retryAfter}
+
+notImplemented :: BadgeServiceResponse
+notImplemented = errorResponse BSEInternal (Just "not implemented") 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'
+-- before anything else is even looked at; then the version gate; then the signer check
+-- (badges-rpc.md: "the service rejects a purchaseKey that differs from [the verified signer]
+-- with bad_request"); then the per-command signer\/record rule; only then dispatch.
+dispatchRequest :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse
+dispatchRequest bsEnv signerKey reqData =
+  case decodeRequest reqData of
+    Left _ -> pure $ errorResponse BSEBadRequest Nothing Nothing
+    Right BadgeServiceRequest {version, purchaseKey, request}
+      | version < minSupportedBadgeVersion -> pure $ errorResponse BSEUnsupportedVersion Nothing Nothing
+      | signerKey /= purchaseKey -> pure $ errorResponse BSEBadRequest Nothing Nothing
+      | otherwise ->
+          checkSignerRecord bsEnv request purchaseKey >>= \case
+            Left err -> pure $ errorResponse err Nothing Nothing
+            Right () -> dispatchCommand bsEnv purchaseKey request
+
+decodeRequest :: J.Object -> Either String BadgeServiceRequest
+decodeRequest = JT.parseEither J.parseJSON . J.Object
+
+-- | The signer\/record precondition, applied to every command before dispatch:
+--   * 'getBadgeCatalog' may be unsigned (no key at all); nothing further is required of it.
+--   * 'purchaseBadge' requires a signature but NOT a pre-existing record -- an unknown key is
+--     the normal first-purchase case, because B7 is what creates the purchase row. Getting
+--     this inverted would make first purchases impossible.
+--   * every other command, including a *signed* 'getBadgeCatalog', requires both a signature
+--     and an existing purchase row: no key at all is 'bad_request' (nothing was signed), an
+--     unknown key is 'unknown_purchase_key'.
+checkSignerRecord :: BadgeServiceEnv -> BadgeServiceCommand -> Maybe C.PublicKeyEd25519 -> IO (Either BadgeServiceErrorCode ())
+checkSignerRecord _ BSCGetBadgeCatalog Nothing = pure $ Right ()
+checkSignerRecord bsEnv BSCGetBadgeCatalog (Just key) = requirePurchaseRecord bsEnv key
+checkSignerRecord _ (BSCPurchaseBadge {}) Nothing = pure $ Left BSEBadRequest
+checkSignerRecord _ (BSCPurchaseBadge {}) (Just _) = pure $ Right ()
+checkSignerRecord _ _ Nothing = pure $ Left BSEBadRequest
+checkSignerRecord bsEnv _ (Just key) = requirePurchaseRecord bsEnv key
+
+requirePurchaseRecord :: BadgeServiceEnv -> C.PublicKeyEd25519 -> IO (Either BadgeServiceErrorCode ())
+requirePurchaseRecord BadgeServiceEnv {store} key =
+  withServiceTransaction store (\db -> getPurchaseByKey db key) >>= \case
+    Right (Just _) -> pure $ Right ()
+    Right Nothing -> pure $ Left BSEUnknownPurchaseKey
+    Left _ -> pure $ Left BSEInternal
+
+-- | 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'; 'getBadgeCatalog' and 'issueBadge' are B6\/B7's commands and
+-- answer 'internal' \"not implemented\" until those steps land.
+dispatchCommand :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> 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 _ _ BSCGetBadgeCatalog = pure notImplemented
+dispatchCommand _ _ (BSCIssueBadge {}) = pure notImplemented
+dispatchCommand bsEnv purchaseKey (BSCPurchaseBadge {payment}) = dispatchPurchase bsEnv purchaseKey payment
+
+-- | '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\".
+--
+-- 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) =
+  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

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

@@ -137,7 +137,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat
 | B2 | `Ledger.hs`: pure transitions and property tests | A5 | ☑ |
 | B3 | `Codes.hs`: derive, encode, hash, classify | A5, A6, B1 | ☑ |
 | B4 | Issuer key loading and credential signing | A5, A6, B2 | ☑ |
-| B5 | RPC dispatcher: envelope, version, signer, throttle | A2, A6, B1 | ☐ |
+| 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 | ☐ |
 | B8 | `codes` operator subcommand | A4, B1, B3 | ☐ |

src/Simplex/Chat/Badges/Service.hs

@@ -12,6 +12,8 @@ module Simplex.Chat.Badges.Service
     BadgeServiceVersion,
     VersionBadgeService,
     pattern VersionBadgeService,
+    minSupportedBadgeVersion,
+    currentBadgeVersion,
     BadgeUpgrade (..),
     BadgeServiceResponse (..),
     BadgeServiceErrorCode (..),
@@ -52,6 +54,20 @@ type VersionBadgeService = Version BadgeServiceVersion
 pattern VersionBadgeService :: Word16 -> VersionBadgeService
 pattern VersionBadgeService v = Version v
 
+-- | The oldest client version the service still answers (badges-rpc.md:9): a request below
+-- this gets 'BSEUnsupportedVersion'. Below 'currentBadgeVersion' only because a version bump
+-- is expected to stay backwards compatible for a while, not because the service itself has
+-- ever spoken more than one version yet.
+minSupportedBadgeVersion :: VersionBadgeService
+minSupportedBadgeVersion = VersionBadgeService 1
+
+-- | The newest version this service deployment speaks. A response answers within
+-- @min(request.version, currentBadgeVersion)@; at version 1 there is no version-conditional
+-- field, so this constant has no runtime effect yet -- it exists so a later version bump has
+-- something to gate on from day one.
+currentBadgeVersion :: VersionBadgeService
+currentBadgeVersion = VersionBadgeService 1
+
 data BadgeServiceRequest = BadgeServiceRequest
   { version :: VersionBadgeService,
     purchaseKey :: Maybe C.PublicKeyEd25519, -- optional for BSCGetBadgeCatalog, required for other commands

tests/Bots/BadgeServiceTests.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Bots.BadgeServiceTests where
@@ -19,20 +20,42 @@ import ChatTests.Utils
 import Control.Concurrent (forkIO, killThread, threadDelay)
 import Control.Concurrent.STM (atomically)
 import Control.Exception (SomeException, evaluate, finally, try)
+import Control.Monad (void)
 import Crypto.Random (getRandomBytes)
 import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as KM
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy.Char8 as LBC
 import Data.List (find, isInfixOf)
 import Data.Maybe (fromJust, isJust)
 import Data.String (fromString)
 import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Time.Calendar (fromGregorian)
 import Data.Time.Calendar.WeekDate (toWeekDate)
 import Data.Time.Clock (DiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay, secondsToDiffTime)
 import Data.Word (Word32)
 import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeRequest (..), BadgeType (..), verifyCredential)
-import Simplex.Chat.Badges.Service (BadgeCatalog (..), BadgeOffer (..), BadgePrice (..), BadgeServiceErrorCode (..))
+import Simplex.Chat.Badges.Service
+  ( -- 'BadgeBalance', 'StatementEntry' and 'StatementEntryType' import only their
+    -- constructors, not '(..)': their field names (entryId, changeMonths, balanceMonths,
+    -- createdAt, ...) duplicate 'BadgeLedgerEntry''s (Badges.Types), which the existing B1
+    -- ledger tests below already use as bare selectors -- importing the field selectors here
+    -- too would make those pre-existing, untouched uses ambiguous.
+    BadgeBalance (BadgeBalance),
+    BadgeCatalog (..),
+    BadgeOffer (..),
+    BadgePrice (..),
+    BadgeServiceCommand (..),
+    BadgeServiceErrorCode (..),
+    BadgeServiceRequest (..),
+    BadgeServiceResponse (..),
+    StatementCreditType (SCOpening),
+    StatementEntry (StatementEntry),
+    StatementEntryType (SECredit),
+    pattern VersionBadgeService,
+  )
 import Simplex.Chat.Badges.Types
   ( BadgeItemStatus (..),
     BadgeLedgerEntry (..),
@@ -43,9 +66,10 @@ import Simplex.Chat.Badges.Types
     LedgerEntryType (..),
     OfferDiscount (..),
   )
-import Simplex.Chat.Controller (ChatConfig)
+import Simplex.Chat.Controller (ChatConfig, ChatController (chatStore))
 import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
+import Simplex.Chat.PaymentService (ServicePayment (..))
 import Simplex.Chat.PaymentService.Types (CurrencyAmount (..))
 import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore, withConnection)
@@ -70,7 +94,16 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 
 badgeServiceTests :: SpecWith TestParams
 badgeServiceTests = do
-  it "should respond with unsupported_version to redeem" testBadgeServiceRedeemUnsupported
+  it "should respond unsupported_version to a request below minSupportedBadgeVersion" testBadgeServiceUnsupportedVersion
+  it "should respond bad_request to a request that fails to decode" testBadgeServiceMalformedRequest
+  it "should respond bad_request when purchaseKey differs from the verified signer" testBadgeServiceSignerMismatch
+  it "should respond unknown_purchase_key to issueBadge from an unknown key" testBadgeServiceIssueBadgeUnknownKey
+  it "should never respond unknown_purchase_key to purchaseBadge from an unknown key" testBadgeServicePurchaseBadgeUnknownKeyIsNotUnknownPurchaseKey
+  it "should respond bad_request to pauseBadge from a signer with an existing purchase" testBadgeServicePauseBadgeKnownSignerBadRequest
+  it "should respond unknown_purchase_key to pauseBadge from an unknown key" testBadgeServicePauseBadgeUnknownKey
+  it "should respond bad_request to purchaseBadge funded by apple" testBadgeServicePurchaseBadgeAppleBadRequest
+  it "should reject purchaseBadge{code} with rate_limited before processing when the per-signer bucket is drained" testBadgeServicePurchaseCodeThrottlePreCheck
+  it "should turn a pure exception forced only during response encoding into internal, without escaping runHandler" testBadgeServiceCatchAllContainsPureException
   it "should migrate web_orders, codes and provider_events up and down" testBadgeServiceWebOrderSchemaMigration
   it "should seed the catalog idempotently and preserve a deprecated price" testBadgeServiceCatalogSeeding
   it "should price 3 months at 2x and 12 months at 6x the monthly price" testBadgeCatalogOfferTotal
@@ -164,13 +197,19 @@ writeTestBadgeServiceConfig TestParams {tmpPath} = do
   writeFile (badgeServiceConfigPath tmpPath) $ unlines (issuerCodesIniLines issuerKeyFile codeSecretFile)
 
 withBadgeService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()) -> IO ()
-withBadgeService ps = withBadgeServiceConfig ps (writeTestBadgeServiceConfig ps)
+withBadgeService ps = withBadgeServiceConfig ps (writeTestBadgeServiceConfig ps) (pure ())
 
 -- Shared by withBadgeService and testBadgeServiceCompleteConfigStarts: the two-phase startup
 -- dance (CreateMyAddress, then ShowMyAddress) is the same regardless of what the config looks
--- like, as long as it's valid; writeConfig is what varies.
-withBadgeServiceConfig :: HasCallStack => TestParams -> IO () -> (TestCC -> String -> IO ()) -> IO ()
-withBadgeServiceConfig ps writeConfig test = do
+-- like, as long as it's valid; writeConfig is what varies. 'betweenPhases' runs after the
+-- first phase's badge service has been killed and before the second one starts: the ONLY
+-- window where nothing holds the database open, so a test that needs to seed a row directly
+-- (e.g. B1's createPurchase, for a "known signer" case) must do it here, via a fresh
+-- 'withFreshBadgeStore' -- opening a second connection to the SAME sqlite file WHILE the
+-- service's own phase is running deadlocks against its writer lock (verified: reliably fails
+-- 'createDBStore' with a pattern-match-on-Right, i.e. sqlite busy, when tried in that window).
+withBadgeServiceConfig :: HasCallStack => TestParams -> IO () -> IO () -> (TestCC -> String -> IO ()) -> IO ()
+withBadgeServiceConfig ps writeConfig betweenPhases test = do
   let opts = mkBadgeServiceOpts ps
   writeConfig
   withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure ()
@@ -183,6 +222,7 @@ withBadgeServiceConfig ps writeConfig test = do
     (sLink, _) <- getContactLinks bs False
     bs <## "auto_accept off"
     pure sLink
+  betweenPhases
   -- Second start: badge service takes the ShowMyAddress branch, then serves the test body.
   runBadgeService testCfg opts $
     withNewTestChatCfg ps testCfg "client" bobProfile $ \client ->
@@ -194,14 +234,188 @@ runBadgeService cfg opts action = do
   threadDelay 500000
   action `finally` killThread t
 
-testBadgeServiceRedeemUnsupported :: HasCallStack => TestParams -> IO ()
-testBadgeServiceRedeemUnsupported ps =
+-- B5 RPC dispatcher -----------------------------------------------------------
+
+-- Sends the JSON-encoded 'BadgeServiceRequest' unsigned.
+sendServiceRequest :: TestCC -> String -> BadgeServiceRequest -> IO ()
+sendServiceRequest client bsLink req =
+  client ##> ("/_service_request 1 " <> bsLink <> " " <> LBC.unpack (J.encode req))
+
+-- Sends the JSON-encoded 'BadgeServiceRequest' signed with 'priv' (the agent verifies the
+-- signature and delivers the corresponding public key as CEvtServiceRequest's signerKey).
+sendSignedServiceRequest :: TestCC -> String -> C.PrivateKeyEd25519 -> BadgeServiceRequest -> IO ()
+sendSignedServiceRequest client bsLink priv req =
+  client
+    ##> ( "/_service_request 1 " <> bsLink <> " sign_key=" <> BC.unpack (strEncode (C.StoredPrivateKey priv))
+            <> " "
+            <> LBC.unpack (J.encode req)
+        )
+
+-- Reads one raw "service response: {...}" line and returns the decoded JSON object, for
+-- assertions that can't be pinned to one exact line (e.g. a retryAfter whose value depends on
+-- wall-clock timing).
+getServiceResponseObject :: HasCallStack => TestCC -> IO J.Object
+getServiceResponseObject client = do
+  line <- getTermLine client
+  case T.stripPrefix "service response: " (T.pack line) of
+    Just json | Just (J.Object o) <- J.decode (LBC.pack (T.unpack json)) -> pure o
+    _ -> expectationFailure ("expected a service response line, got: " <> line) >> error "unreachable"
+
+testBadgeRequestCommand :: BadgeMasterKey -> ServicePayment -> BadgeServiceCommand
+testBadgeRequestCommand masterKey payment =
+  BSCPurchaseBadge {badgeRequest = testBadgeRequest masterKey, payment, upgrade = Nothing}
+
+-- StatementEntry/BadgeBalance/StatementEntryType are constructed positionally: only their
+-- constructors are imported (see the import list above), not their field selectors, to avoid
+-- colliding with BadgeLedgerEntry's identically-named fields used elsewhere in this file.
+-- Field order: entryId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType,
+-- wasPausedSince, createdAt, entryType.
+testIssueBadgeCommand :: BadgeMasterKey -> UTCTime -> BadgeServiceCommand
+testIssueBadgeCommand masterKey now =
+  BSCIssueBadge
+    { badgeRequest = testBadgeRequest masterKey,
+      balance = BadgeBalance (StatementEntry "test-entry" 1 1 now BTSupporter Nothing now (SECredit SCOpening))
+    }
+
+-- version 0 is below minSupportedBadgeVersion (1): the version gate must reject it before
+-- looking at the command at all, so 'getBadgeCatalog' (which needs no other fields) is enough
+-- to isolate the gate.
+testBadgeServiceUnsupportedVersion :: HasCallStack => TestParams -> IO ()
+testBadgeServiceUnsupportedVersion ps =
   withBadgeService ps $ \client bsLink -> do
-    let redeemReq =
-          "{\"version\":1,\"request\":{\"type\":\"purchaseBadge\",\"payment\":{\"type\":\"code\",\"code\":\"TEST-CODE\"}}}"
-    client ##> ("/_service_request 1 " <> bsLink <> " " <> redeemReq)
+    client ##> ("/_service_request 1 " <> bsLink <> " {\"version\":0,\"request\":{\"type\":\"getBadgeCatalog\"}}")
     client <## "service response: {\"code\":\"unsupported_version\",\"type\":\"error\"}"
 
+-- A syntactically valid JSON object that does not decode into BadgeServiceRequest (missing
+-- version and request) must fail at step 1, before the version gate ever runs.
+testBadgeServiceMalformedRequest :: HasCallStack => TestParams -> IO ()
+testBadgeServiceMalformedRequest ps =
+  withBadgeService ps $ \client bsLink -> do
+    client ##> ("/_service_request 1 " <> bsLink <> " {\"foo\":\"bar\"}")
+    client <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}"
+
+-- A request signed by one key but asserting a different key as purchaseKey must be rejected
+-- regardless of what it asks for.
+testBadgeServiceSignerMismatch :: HasCallStack => TestParams -> IO ()
+testBadgeServiceSignerMismatch ps =
+  withBadgeService ps $ \client bsLink -> do
+    (_signerPub, signerPriv) <- mkTestKeyPair
+    (assertedPub, _assertedPriv) <- mkTestKeyPair
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just assertedPub, request = BSCGetBadgeCatalog}
+    sendSignedServiceRequest client bsLink signerPriv req
+    client <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}"
+
+-- issueBadge always requires an existing purchase record; a fresh, never-purchased key must
+-- be rejected with unknown_purchase_key before it ever reaches the (not yet implemented) B7
+-- handler.
+testBadgeServiceIssueBadgeUnknownKey :: HasCallStack => TestParams -> IO ()
+testBadgeServiceIssueBadgeUnknownKey ps =
+  withBadgeService ps $ \client bsLink -> do
+    (pub, priv) <- mkTestKeyPair
+    masterKey <- BadgeMasterKey <$> getRandomBytes 32
+    now <- getCurrentTime
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = testIssueBadgeCommand masterKey now}
+    sendSignedServiceRequest client bsLink priv req
+    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.
+testBadgeServicePurchaseBadgeUnknownKeyIsNotUnknownPurchaseKey :: HasCallStack => TestParams -> IO ()
+testBadgeServicePurchaseBadgeUnknownKeyIsNotUnknownPurchaseKey ps =
+  withBadgeService ps $ \client bsLink -> do
+    (pub, priv) <- mkTestKeyPair
+    masterKey <- BadgeMasterKey <$> getRandomBytes 32
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = testBadgeRequestCommand masterKey (SPCode "UNKNOWN-CODE")}
+    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")
+
+-- 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
+-- that bad_request, not an identity error.
+testBadgeServicePauseBadgeKnownSignerBadRequest :: HasCallStack => TestParams -> IO ()
+testBadgeServicePauseBadgeKnownSignerBadRequest ps = do
+  (pub, priv) <- mkTestKeyPair
+  masterKey <- BadgeMasterKey <$> getRandomBytes 32
+  now <- getCurrentTime
+  -- The purchase row is seeded in the gap between withBadgeServiceConfig's two startup
+  -- phases, reopening the SAME already-migrated store the harness itself reopens there to
+  -- read the invite link (chatStore, via a plain TestCC) -- NOT a fresh createDBStore with
+  -- just badgeServiceSchemaMigrations, which builds an isolated, from-scratch database (as
+  -- withFreshBadgeStore's other callers rely on) and mismatches against the real one, already
+  -- carrying the full chat/agent migration history the live service ran.
+  let seedPurchase =
+        withTestChat ps serviceDbPrefix $ \bs -> do
+          bs <## "subscribed 1 connections on server localhost" -- consume, as the harness's own reopen does
+          void $ expectRight $ withServiceTransaction (chatStore (chatController bs)) $ \db -> createPurchase db pub masterKey BTSupporter now
+  withBadgeServiceConfig ps (writeTestBadgeServiceConfig ps) seedPurchase $ \client bsLink -> do
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = BSCPauseBadge}
+    sendSignedServiceRequest client bsLink priv req
+    client <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}"
+
+-- The same command from a key with no purchase row at all must fail the identity check
+-- instead, before pauseBadge's own (always bad_request) handling ever runs.
+testBadgeServicePauseBadgeUnknownKey :: HasCallStack => TestParams -> IO ()
+testBadgeServicePauseBadgeUnknownKey ps =
+  withBadgeService ps $ \client bsLink -> do
+    (pub, priv) <- mkTestKeyPair
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = BSCPauseBadge}
+    sendSignedServiceRequest client bsLink priv req
+    client <## "service response: {\"code\":\"unknown_purchase_key\",\"type\":\"error\"}"
+
+-- Store-evidence verification is out of scope (§6): every non-code payment method is
+-- permanently bad_request, not "not implemented".
+testBadgeServicePurchaseBadgeAppleBadRequest :: HasCallStack => TestParams -> IO ()
+testBadgeServicePurchaseBadgeAppleBadRequest ps =
+  withBadgeService ps $ \client bsLink -> do
+    (pub, priv) <- mkTestKeyPair
+    masterKey <- BadgeMasterKey <$> getRandomBytes 32
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = testBadgeRequestCommand masterKey (SPApple {jws = "test-jws"})}
+    sendSignedServiceRequest client bsLink priv req
+    client <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}"
+
+-- With the per-signer bucket started at capacity 1 and zero tokens ([throttle] override, B5
+-- decision 5), a single purchaseBadge{code} must be rejected BEFORE processing, with
+-- rate_limited and a non-zero retryAfter -- the accounting (debit-on-failure) is B10's, this
+-- step only asserts the pre-processing check.
+testBadgeServicePurchaseCodeThrottlePreCheck :: HasCallStack => TestParams -> IO ()
+testBadgeServicePurchaseCodeThrottlePreCheck ps = do
+  (issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets (tmpPath ps)
+  let writeConfig =
+        writeFile (badgeServiceConfigPath (tmpPath ps)) $
+          unlines $
+            issuerCodesIniLines issuerKeyFile codeSecretFile
+              ++ ["", "[throttle]", "signer_failure_capacity = 1", "signer_failure_start_tokens = 0"]
+  withBadgeServiceConfig ps writeConfig (pure ()) $ \client bsLink -> do
+    (pub, priv) <- mkTestKeyPair
+    masterKey <- BadgeMasterKey <$> getRandomBytes 32
+    let req = BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = testBadgeRequestCommand masterKey (SPCode "TEST-CODE")}
+    sendSignedServiceRequest client bsLink priv req
+    respObj <- getServiceResponseObject client
+    KM.lookup "code" respObj `shouldBe` Just (J.String "rate_limited")
+    case KM.lookup "retryAfter" respObj of
+      Just (J.Number n) -> n `shouldSatisfy` (> 0)
+      other -> expectationFailure $ "expected a positive retryAfter, got: " <> show other
+
+-- The convincing form (B5 brief): forces a genuine 'error' thunk hidden behind a Just, so it
+-- is NOT forced by constructing or returning the response -- only by fully encoding it, which
+-- is exactly the laziness gap a "catch around only the IO action" would miss. runHandler must
+-- catch it, respond internal, and remain usable for the next call (proving the exception did
+-- not corrupt anything or propagate past this function -- the property that keeps
+-- processQueuedRequests' single-threaded forever loop alive for every other user).
+testBadgeServiceCatchAllContainsPureException :: HasCallStack => TestParams -> IO ()
+testBadgeServiceCatchAllContainsPureException _ps = do
+  let boom = error "boom: pure exception forced only during response encoding, not before" :: Text
+      badResponse = BSPError {code = BSEInternal, message = Just boom, retryAfter = Nothing}
+  caughtObj <- runHandler "test-req-pure-exception" (pure badResponse)
+  KM.lookup "code" caughtObj `shouldBe` Just (J.String "internal")
+  KM.lookup "message" caughtObj `shouldBe` Nothing -- never leaks the caught exception's own text
+  goodObj <- runHandler "test-req-after-pure-exception" (pure $ BSPError {code = BSEBadRequest, message = Nothing, retryAfter = Nothing})
+  KM.lookup "code" goodObj `shouldBe` Just (J.String "bad_request")
+
 -- Applies every migration except 20260821_badge_service_web, then exercises that one
 -- migration's up/down/up cycle directly, checking the three new tables appear and
 -- disappear as expected.
@@ -454,11 +668,15 @@ testBadgeServiceConfigMinimalStarts TestParams {tmpPath} = do
 -- service end to end, not just that readBadgeServiceConfig accepts it.
 testBadgeServiceCompleteConfigStarts :: HasCallStack => TestParams -> IO ()
 testBadgeServiceCompleteConfigStarts ps@TestParams {tmpPath} =
-  withBadgeServiceConfig ps writeCompleteConfig $ \client bsLink -> do
+  withBadgeServiceConfig ps writeCompleteConfig (pure ()) $ \client bsLink -> do
+    -- What matters here is that the service starts and answers at all; the request omits
+    -- purchaseBadge's required badgeRequest on purpose, so the real dispatcher's decode step
+    -- (B5) fails it with bad_request -- a stable, step-independent response, unlike e.g.
+    -- getBadgeCatalog's answer, which will change once B6 lands.
     let redeemReq =
           "{\"version\":1,\"request\":{\"type\":\"purchaseBadge\",\"payment\":{\"type\":\"code\",\"code\":\"TEST-CODE\"}}}"
     client ##> ("/_service_request 1 " <> bsLink <> " " <> redeemReq)
-    client <## "service response: {\"code\":\"unsupported_version\",\"type\":\"error\"}"
+    client <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}"
   where
     writeCompleteConfig = do
       (issuerKeyFile, codeSecretFile) <- writeTestBadgeServiceSecrets tmpPath