badge service: refuse a store with no verifier as terminal; keep answering requests after one throws

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

@@ -16,6 +16,7 @@ module BadgeService.Service
     badgeServiceResponse,
     badgeErrorRetryAfter,
     shownServiceRequest,
+    survive,
     IssueCodeOpts (..),
     issueBadgeCode,
   )
@@ -36,6 +37,7 @@ import BadgeService.Web.Server (exportWebapp, newWebEnv, runWebListener)
 import Control.Applicative (optional)
 import Control.Concurrent.STM
 import BadgeService.Log (logError, logInfo, logWarn)
+import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try)
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 import qualified Data.Aeson as J
@@ -84,8 +86,8 @@ data ServiceState = ServiceState
     storeVerifier :: StoreVerifier
   }
 
--- | No store verifier exists yet, so every store receipt is answered provider_unavailable: the
--- purchase may be real, and the app keeps presenting it until one is deployed.
+-- | No store verifier exists yet, so every store receipt not already credited is answered
+-- provider_not_configured, terminal for the request: retrying cannot deploy one.
 newServiceState :: IO ServiceState
 newServiceState = do
   serviceCC <- newEmptyTMVarIO
@@ -284,14 +286,24 @@ processQueuedRequests key env = do
   cc <- atomically $ readTMVar $ serviceCC env
   forever $ do
     (u, reqId, sigKey, reqData) <- atomically $ readTQueue $ serviceRequestQ env
-    handleServiceRequest key (storeVerifier env) cc u reqId sigKey reqData
+    survive ("request " <> safeDecodeUtf8 (strEncode reqId)) $ handleServiceRequest key (storeVerifier env) cc u reqId sigKey reqData
 
 processChatRedeems :: BadgeIssuerKey -> ServiceState -> IO ()
 processChatRedeems key env = do
   cc <- atomically $ readTMVar $ serviceCC env
   forever $ do
     (ct, msg) <- atomically $ readTQueue $ chatRedeemQ env
-    chatRedeem key cc ct msg
+    survive "a chat redemption" $ chatRedeem key cc ct msg
+
+-- | Asynchronous exceptions are rethrown, since that is how the race stops this thread. The
+-- exception itself is not logged: it can quote the request, which carries codes and store receipts.
+survive :: T.Text -> IO () -> IO ()
+survive what action =
+  (try action :: IO (Either SomeException ())) >>= \case
+    Right () -> pure ()
+    Left e -> case fromException e :: Maybe SomeAsyncException of
+      Just _ -> throwIO e
+      Nothing -> logError $ "badge service: " <> what <> " failed; the next one will be handled"
 
 -- | Here the service generates the master key and can link the badge, so [dev] chat_redeem gates this.
 chatRedeem :: BadgeIssuerKey -> ChatController -> Contact -> T.Text -> IO ()
@@ -482,6 +494,7 @@ storeRefusalResponse = \case
   SRPending -> pure $ errorResponse BSEPaymentPending
   SRUnreachable reason -> logWarn ("store unreachable: " <> reason) $> errorResponse BSEProviderUnavailable
   SRVerifierFailed reason -> logError ("store receipt not verified: " <> reason) $> errorResponse BSEInternal
+  SRNotConfigured -> logWarn "store receipt refused: no verifier for this store is configured" $> errorResponse BSEProviderNotConfigured
 
 claimedResponse :: DB.Connection -> BadgeServiceErrorCode -> C.PublicKeyEd25519 -> FundingClaim -> IO (Either BadgeServiceResponse ())
 claimedResponse db usedCode purchaseKey = \case

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

@@ -45,11 +45,11 @@ data StoreRefusal
   | SRPending -- a real purchase the store has not settled; it may yet
   | SRUnreachable Text -- the store was not asked, or did not answer
   | SRVerifierFailed Text -- a bug, not the store's answer
+  | SRNotConfigured -- no verifier for this store is deployed; the purchase may be real
   deriving (Eq, Show)
 
 -- | Not a Provider: a receipt is presented once as proof, with nothing to create, watch or cancel.
 -- Apple is checked offline, so its verifier is pure and cannot be unreachable; only Google is asked.
--- A store with no verifier deployed is unreachable: its purchases may be real.
 data StoreVerifier = StoreVerifier
   { verifyApple :: Maybe (Text -> Either Text StoreTransaction), -- the JWS; Left is why Apple did not sign it
     verifyGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal StoreTransaction)), -- the product id and the token
@@ -82,7 +82,7 @@ storeReceipt StoreVerifier {verifyApple, verifyGoogle, verifyTimeout} = \case
   SPInvoice {} -> Nothing
   SPReceipt {} -> Nothing
   where
-    unconfigured = pure $ Left $ SRUnreachable "no verifier configured"
+    unconfigured = pure $ Left SRNotConfigured
     -- nothing was fetched, so a throw or an overrun is a bug or a malformed receipt, never an outage
     offline verdict =
       (fromMaybe (Left $ SRVerifierFailed "apple verifier timed out") <$> timeout verifyTimeout (forced verdict))

docs/protocol/badges-rpc.md

@@ -32,7 +32,7 @@ No command lets the client state what is signed. The tier is that of whatever fu
 - `getBadgeCatalog` → `badgeCatalog` — the prices and offers; signed, also the purchase's `badgeStatement`. Store builds never send it: prices come from the store and SKUs from app config.
 - `getBadgeInvoice` → `badgeInvoice` — prices the purchase for `badgeInfo` and `paymentVia` (`card` — Stripe; `crypto` — btc, xmr). The response holds the generic `invoice` — `invoiceId`, `price`, `discount`, the upgrade `credit`, `amount` = price − discount − credit, `currency`, `expiresAt`, and `paymentTo` (`url` for card; `address` and `cryptoAmount` for crypto) — beside the badge part, `badgeType` and `months`. `priceId` pins the price the client displayed; `offerId` selects a discounted duration, and its absence buys one month at that price. Price and offer status is checked here only: `deprecated` is still accepted, `disabled` is rejected; a badge type with no active price yields `product_unavailable`.
 - `redeemBadgeCode` → `badgeCredential` — redeems a code, records the credit, and issues the first credential, in one round trip. It carries `masterKey` and `code` and no `badgeRequest`: a code states no tier and no expiry, so the credential is what reports them. Errors: `code_invalid` for an unknown or malformed code, `code_used` when another key redeemed it, `code_expired` past a redemption deadline.
-- `purchaseBadge` → `badgeCredential` — verifies the funding (`apple` JWS offline; `google` product id and token via the Publisher API; `invoice` against webhook-confirmed settlement, `payment_pending` until it lands; `receipt`), records the credit, and issues the first credential, in one round trip. It carries `masterKey` and no `badgeRequest`: the tier and months are those of the product the funding proves, and the expiry is the one every credential for that week shares, so the client has nothing to state. Errors: `receipt_invalid` for a receipt the store does not vouch for, whether forged, malformed, unknown or refunded, and for a test purchase, which cost nothing; `receipt_used` when another key was credited with it; `product_unavailable` for a product that grants no badge; `payment_pending` while the store has not settled it and `provider_unavailable` while the store cannot be asked, both recording nothing. A receipt already credited to the signing key is answered from the service's record without asking the store. The client does not finish the store transaction on `product_unavailable`: the purchase is paid, and a product the service does not price is its operator's error, so the transaction is presented again at the next trigger rather than retried now. The response `receipt` is the recovery bearer secret (model § recovery); the service stores its hash; lifetime badges receive none.
+- `purchaseBadge` → `badgeCredential` — verifies the funding (`apple` JWS offline; `google` product id and token via the Publisher API; `invoice` against webhook-confirmed settlement, `payment_pending` until it lands; `receipt`), records the credit, and issues the first credential, in one round trip. It carries `masterKey` and no `badgeRequest`: the tier and months are those of the product the funding proves, and the expiry is the one every credential for that week shares, so the client has nothing to state. Errors: `receipt_invalid` for a receipt the store does not vouch for, whether forged, malformed, unknown or refunded, and for a test purchase, which cost nothing; `receipt_used` when another key was credited with it; `product_unavailable` for a product that grants no badge; `payment_pending` while the store has not settled it and `provider_unavailable` while the store cannot be asked, both recording nothing; `provider_not_configured` when this deployment has no verifier for the store, recording nothing and terminal for the request, since retrying cannot deploy one. A receipt already credited to the signing key is answered from the service's record without asking the store. The client does not finish the store transaction, and keeps the keys it signed with, on `product_unavailable` or `provider_not_configured`: the purchase is paid, and a product the service does not price or a store it cannot verify is its operator's error, so the transaction is presented again at the next trigger rather than retried now. The response `receipt` is the recovery bearer secret (model § recovery); the service stores its hash; lifetime badges receive none.
   - Funding by `receipt` is a transfer (post-MVP): the unissued months of the purchase that receipt belongs to move to the signing key, recorded as `debit(transferOut)` on the source and `credit(transferIn)` on the new purchase, and the presented receipt is retired for a fresh one. The transferred period's issuance debits a month like any other. Lifetime badges hold no receipt, so support handles them.
 - `upgradeBadgeSubscription` → `badgeCredential` — the app-led store subscription change, on the same key: verifies the store evidence of the replaced subscription and records the new plan; an immediate upgrade returns the new credential, a deferred change returns none. Its `badgeRequest` is to be dropped (see above).
 - `issueBadge` → `badgeCredential` — issues the next period from the balance, the only source of issuance. It carries `balance` alone: the credential is signed with the purchase's stored master key, for the type the balance funds, expiring at the `sundayAfter` of the period issued. The ledger is advanced first; the credential is signed before the `debit(badge)` and issuance rows are written, in one transaction. An exhausted balance yields no `credential`; the `statement` shows why. Issuing on a paused badge resumes it (model 2.13).
@@ -63,4 +63,4 @@ An assertion that names an entry the service holds is a prefix: the service proc
 
 ## Errors
 
-`retryAfter` marks the transient codes: `payment_pending`, `provider_unavailable`, `rate_limited`. `offer_disabled` calls for a catalog refresh. `code_invalid` covers unknown, malformed and revoked codes alike, so a guesser learns nothing from the difference; `code_used` — redeemed under another key; `code_expired` — past its redemption deadline. `receipt_invalid` covers forged, malformed, unknown, refunded and test receipts alike, so a guesser learns nothing from the difference; `receipt_used` — credited to another key. All other codes are terminal for the attempted command.
+`retryAfter` marks the transient codes: `payment_pending`, `provider_unavailable`, `rate_limited`. `offer_disabled` calls for a catalog refresh. `code_invalid` covers unknown, malformed and revoked codes alike, so a guesser learns nothing from the difference; `code_used` — redeemed under another key; `code_expired` — past its redemption deadline. `receipt_invalid` covers forged, malformed, unknown, refunded and test receipts alike, so a guesser learns nothing from the difference; `receipt_used` — credited to another key; `provider_not_configured` — no verifier for that store is deployed, so the receipt is neither credited nor refused. All other codes are terminal for the attempted command.

src/Simplex/Chat/Badges/Types.hs

@@ -236,6 +236,7 @@ data BadgeServiceErrorCode
   | BSEPaymentNotEntitled
   | BSEPaymentPending
   | BSEProviderUnavailable
+  | BSEProviderNotConfigured
   | BSERateLimited
   | BSECodeInvalid
   | BSECodeUsed
@@ -325,6 +326,7 @@ instance TextEncoding BadgeServiceErrorCode where
     BSEPaymentNotEntitled -> "payment_not_entitled"
     BSEPaymentPending -> "payment_pending"
     BSEProviderUnavailable -> "provider_unavailable"
+    BSEProviderNotConfigured -> "provider_not_configured"
     BSERateLimited -> "rate_limited"
     BSECodeInvalid -> "code_invalid"
     BSECodeUsed -> "code_used"
@@ -344,6 +346,7 @@ instance TextEncoding BadgeServiceErrorCode where
     "payment_not_entitled" -> BSEPaymentNotEntitled
     "payment_pending" -> BSEPaymentPending
     "provider_unavailable" -> BSEProviderUnavailable
+    "provider_not_configured" -> BSEProviderNotConfigured
     "rate_limited" -> BSERateLimited
     "code_invalid" -> BSECodeInvalid
     "code_used" -> BSECodeUsed

tests/BadgeTests.hs

@@ -9,7 +9,10 @@
 
 module BadgeTests (badgeTests) where
 
-import BadgeService.Service (badgeErrorRetryAfter, shownServiceRequest)
+import BadgeService.Service (badgeErrorRetryAfter, shownServiceRequest, survive)
+import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Control.Exception (SomeAsyncException, SomeException, catch, fromException, throwIO)
 import BadgeService.StoreReceipts (StoreReceipt (..), StoreRefusal (..), StoreVerifier (..), storeReceipt)
 import Control.Concurrent.STM (atomically)
 import Data.ByteString.Char8 (ByteString)
@@ -24,7 +27,7 @@ import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime,
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as KM
-import Data.Maybe (fromMaybe, isNothing, maybeToList)
+import Data.Maybe (fromMaybe, isJust, isNothing, maybeToList)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Code
@@ -106,6 +109,8 @@ badgeTests = do
     it "keys a purchase by the store's transaction id, not by the evidence signed over it" testStoreTransactionRef
     it "shows a service request in the terminal as its type alone" testShownServiceRequest
     it "refuses a Play product id or token that could name another purchase, before any verifier" testGooglePathStrings
+  describe "badge service request loop" $ do
+    it "survives a request that throws, and still stops when cancelled" testSurviveRequestFailure
 
 proofOf :: BadgeProof -> BBSProof
 proofOf (BadgeProof _ _ p _) = p
@@ -693,7 +698,7 @@ testServiceRetryAfter = do
   badgeErrorRetryAfter BSEInternal `shouldBe` Nothing
   mapM_
     (\code -> badgeErrorRetryAfter code `shouldBe` Nothing)
-    [BSEBadRequest, BSEUnsupportedVersion, BSEUnknownPurchaseKey, BSECodeInvalid, BSECodeUsed, BSECodeExpired, BSEUnknown "future_code"]
+    [BSEBadRequest, BSEUnsupportedVersion, BSEUnknownPurchaseKey, BSECodeInvalid, BSECodeUsed, BSECodeExpired, BSEProviderNotConfigured, BSEUnknown "future_code"]
 
 -- The app shows the recorded failure in a sentence, so an agent error is stored as the agent
 -- error and not as the chat error wrapping it, whether or not it can clear on its own.
@@ -871,6 +876,19 @@ testGooglePathStrings = do
     Just (Right StoreReceipt {provider}) -> provider `shouldBe` PPGoogle
     _ -> expectationFailure "a valid product id and token were refused"
 
+testSurviveRequestFailure :: IO ()
+testSurviveRequestFailure = do
+  survive "a request" (throwIO $ userError "failed") `shouldReturn` ()
+  started <- newEmptyMVar
+  stopped <- newEmptyMVar
+  t <- forkIO $ survive "a request" (putMVar started () >> threadDelay 10000000) `catch` (putMVar stopped . asyncException)
+  takeMVar started
+  killThread t
+  takeMVar stopped `shouldReturn` True
+  where
+    asyncException :: SomeException -> Bool
+    asyncException e = isJust (fromException e :: Maybe SomeAsyncException)
+
 testCredentialResponseJSON :: IO ()
 testCredentialResponseJSON = do
   Right (_, sk) <- bbsKeyGen

tests/Bots/BadgeService/BotTests.hs

@@ -18,6 +18,7 @@ import BadgeService.Options
 import BadgeService.Service
 import BadgeService.Store (NewStorePurchase (..), createStorePurchase)
 import BadgeService.Store.Invoices (markCodePaid)
+import BadgeService.StoreReceipts (StoreVerifier, noStoreVerifier)
 import Simplex.Messaging.Agent.Store.DB (Binary (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import ChatClient
@@ -127,6 +128,7 @@ badgeServiceTests = do
     it "should replay a receipt to its own key while the store is down, and to no other" testStoreReplayWhileStoreDown
     it "should answer a throwing Apple verifier as internal, and a failing or hanging Google one as retryable" testStoreVerifierFailures
     it "should credit a transaction claimed twice at once only once" testStoreClaimRace
+    it "should refuse a store with no verifier with no retry, and the client should keep its keys" testPurchaseWithNoVerifier
     it "should refuse a store purchase whose purchaseKey is not the verified signer" testStorePurchaseKeyMismatch
     it "should redeem a Play purchase into a badge, and replay it as the same badge" testPurchaseBadge
     it "should redeem an App Store purchase by its JWS" testPurchaseBadgeAppStore
@@ -187,7 +189,8 @@ data BadgeServiceEnv = BadgeServiceEnv
     bsClientCfg :: ChatConfig,
     bsAddress :: String,
     bsController :: ChatController,
-    bsStore :: FakeStore
+    bsStore :: FakeStore,
+    bsVerifier :: StoreVerifier
   }
 
 -- | Stop the service for good: requests sent after it go unanswered until they time out. Stopping
@@ -200,14 +203,18 @@ withBadgeService ps test =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsAddress, bsController} -> test bsClientCfg bsAddress bsController
 
 withBadgeServiceEnv :: HasCallStack => TestParams -> (BadgeServiceEnv -> IO ()) -> IO ()
-withBadgeServiceEnv ps test = do
+withBadgeServiceEnv ps = withBadgeServiceVerifier ps fakeVerifier
+
+withBadgeServiceVerifier :: HasCallStack => TestParams -> (FakeStore -> StoreVerifier) -> (BadgeServiceEnv -> IO ()) -> IO ()
+withBadgeServiceVerifier ps verifierOf test = do
   Right (pk, sk) <- bbsKeyGen
   clock <- newTestClock
   store <- newFakeStore
   let opts = mkBadgeServiceOpts ps sk
       svcCfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk, badgeCurrentTime = testClockTime clock}
+      verifier = verifierOf store
   withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure ()
-  runBadgeService store svcCfg opts $ \_ -> pure ()
+  runBadgeService verifier svcCfg opts $ \_ -> pure ()
   bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do
     bs <## "subscribed 1 connections on server localhost"
     bs ##> "/sa"
@@ -216,9 +223,9 @@ withBadgeServiceEnv ps test = do
     pure sLink
   let clientCfg =
         svcCfg {badgeServiceAddress = Just $ either (error . ("bad badge service address: " <>)) id $ strDecode (B.pack bsLink)}
-  runBadgeService store svcCfg opts $ \env -> do
+  runBadgeService verifier svcCfg opts $ \env -> do
     cc <- atomically $ readTMVar $ serviceCC env
-    test BadgeServiceEnv {bsIssuerKey = BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey = sk}, bsClock = clock, bsClientCfg = clientCfg, bsAddress = bsLink, bsController = cc, bsStore = store}
+    test BadgeServiceEnv {bsIssuerKey = BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey = sk}, bsClock = clock, bsClientCfg = clientCfg, bsAddress = bsLink, bsController = cc, bsStore = store, bsVerifier = verifier}
 
 issueCode :: HasCallStack => ChatController -> BadgeType -> Int -> IO BadgeCode
 issueCode cc badgeType months = issueCodeAs cc badgeType months "free"
@@ -239,9 +246,9 @@ issueCodeAs cc badgeType months status =
     r -> error $ "issue failed: " <> show (() <$ r)
 
 -- | The post-start hook fills serviceCC once the address exists, so the test waits on it rather than on a fixed delay that would race with startup and let one start's address output arrive during the next test.
-runBadgeService :: FakeStore -> ChatConfig -> BadgeServiceOpts -> (ServiceState -> IO ()) -> IO ()
-runBadgeService FakeStore {fakeVerifier} cfg opts action = do
-  env <- (\s -> s {storeVerifier = fakeVerifier}) <$> newServiceState
+runBadgeService :: StoreVerifier -> ChatConfig -> BadgeServiceOpts -> (ServiceState -> IO ()) -> IO ()
+runBadgeService verifier cfg opts action = do
+  env <- (\s -> s {storeVerifier = verifier}) <$> newServiceState
   t <- forkIO $ badgeService opts cfg env
   ready <- timeout 30000000 $ atomically $ readTMVar $ serviceCC env
   when (isNothing ready) $ killThread t >> error "badge service did not start"
@@ -390,8 +397,8 @@ testRedeemSameCodeOtherProfile ps =
       showActiveUser alice "alice (Alice, * supporter)"
 
 serviceCmd :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse
-serviceCmd BadgeServiceEnv {bsIssuerKey, bsController, bsStore = FakeStore {fakeVerifier}} purchaseKey request =
-  badgeServiceResponse bsIssuerKey fakeVerifier bsController (Just purchaseKey) reqObject
+serviceCmd BadgeServiceEnv {bsIssuerKey, bsController, bsVerifier} purchaseKey request =
+  badgeServiceResponse bsIssuerKey bsVerifier bsController (Just purchaseKey) reqObject
   where
     reqObject = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of
       J.Object o -> o
@@ -1552,6 +1559,18 @@ testStoreVerifierFailures ps =
     answer (googlePayment "badge_supporter_01" googleHangingToken) >>= (`shouldSatisfy` \(code, retryAfter) -> code == BSEProviderUnavailable && isJust retryAfter)
     nothingPurchased cc
 
+testPurchaseWithNoVerifier :: HasCallStack => TestParams -> IO ()
+testPurchaseWithNoVerifier ps =
+  withBadgeServiceVerifier ps (const noStoreVerifier) $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc} -> do
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey supporterPlay) `shouldReturn` (BSEProviderNotConfigured, Nothing)
+    nothingPurchased cc
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
+      alice <## "cannot redeem badge code: badge service error: provider_not_configured"
+      -- not yet rather than never, so the keys stay for the retry once a verifier is deployed
+      rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1
+
 testStoreClaimRace :: HasCallStack => TestParams -> IO ()
 testStoreClaimRace ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsController = cc} -> do