core: classify an unverifiable badge credential, settle before broadcasting, and narrow the stash deletion to codes

src/Simplex/Chat/Library/Commands.hs

@@ -5242,7 +5242,11 @@ redeemBadgeCode nm user@User {userId} codeText = do
   (present_, redeemed) <- withEntityLock "badgeRedeem" (CLBadgeUser userId) $ do
     stash_ <- withStore' $ \db -> getBadgeCodeRedemption db user codeSent
     stash@BadgeStash {masterKey} <- stashBadgeKeys user stash_ $ \db -> createBadgeCodeRedemption db g user codeSent now
-    redeemBadgeStash nm user sendTarget stash BSCRedeemBadgeCode {masterKey, code = codeSent} terminalCodeError
+    requestBadgeStash nm user sendTarget stash BSCRedeemBadgeCode {masterKey, code = codeSent} >>= \case
+      Left (errCode, _) -> do
+        when (terminalCodeError errCode) $ withStore' $ \db -> deleteBadgeCodeRedemption db user codeSent
+        throwRedeemError $ BREServiceError errCode
+      Right redeemed -> pure redeemed
   -- outside the badge lock: the chat lock must not be taken under it
   mapM_ presentUserBadgeToContacts present_
   pure redeemed
@@ -5266,7 +5270,9 @@ handOverStoreReceipt presentingUser echoedInvoiceId payment = do
     withStore' (\db -> holdStoreReceipt db g presentingUser echoedInvoiceId txRef payment now)
       >>= maybe (throwChatError $ CEInternalError "store receipt was not recorded") pure
   owner <- withStore $ \db -> getUser db ownerId
-  answer <- case status of
+  -- before the answer, which can throw: no later hand-over of this receipt signals, and a spare signal costs an empty pass
+  when newlyHeld $ lift $ startStoreReceiptWork owner
+  case status of
     RSHeld -> badgeStateResponse owner
     RSCredited {badgePurchaseId} -> do
       cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
@@ -5274,9 +5280,6 @@ handOverStoreReceipt presentingUser echoedInvoiceId payment = do
       CRBadgeRedeemed owner (OwnBadge cred (mkBadgeStatus now (Just True) info)) False <$> getUserBadgeState owner
     RSRefused {refusal = Just BIFServiceError {code}} -> throwRedeemError $ BREServiceError code
     RSRefused {} -> throwChatError $ CEInternalError "store purchase refused for no recorded reason"
-  -- after the answer is read, so it shows the receipt held whatever the worker does next
-  when newlyHeld $ lift $ startStoreReceiptWork owner
-  pure answer
 
 -- | The receipt will never be credited to its key; any other refusal may pass on a retry.
 storeReceiptRefused :: BadgeServiceErrorCode -> Bool
@@ -5307,16 +5310,8 @@ requireBadgeService = asks (badgeServiceAddress . config) >>= maybe (throwRedeem
 refuseWhileBadgeHeld :: User -> CM ()
 refuseWhileBadgeHeld user = whenM (withStore' (`userHasBadge` user)) $ throwRedeemError BREBadgeActive
 
--- | One attempt to turn a stash into a badge, dropping the stash only on a refusal no retry can fix.
-redeemBadgeStash :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> (BadgeServiceErrorCode -> Bool) -> CM (Maybe User, ChatResponse)
-redeemBadgeStash nm user sendTarget stash request stashDead =
-  requestBadgeStash nm user sendTarget stash request >>= \case
-    Left (errCode, _) -> do
-      when (stashDead errCode) $ withStore' (`deleteBadgeStash` stash)
-      throwRedeemError $ BREServiceError errCode
-    Right redeemed -> pure redeemed
-
--- | A refusal is answered rather than thrown, with the service's retryAfter.
+-- | One attempt to turn a stash into a badge. A refusal is answered rather than thrown, with the
+-- service's retryAfter.
 requestBadgeStash :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (Maybe User, ChatResponse))
 requestBadgeStash nm user sendTarget stash@BadgeStash {purchaseKey, purchasePrivKey} request = do
   let req = BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request}
@@ -5469,14 +5464,14 @@ creditStoreReceipt userId HeldStoreReceipt {receiptId, stash = stash@BadgeStash
         | storeReceiptRefused code -> SRORefused <$ withStore' (\db -> refuseStoreReceipt db receiptId $ serviceFailure code retryAfter)
         | otherwise -> SRODeferred <$ defer (serviceFailure code retryAfter) retryAfter
       Left e -> SRODeferred <$ defer (badgeIssueFailure e) Nothing
-  -- only a settlement is announced: the app answers it with a sweep, which signals this worker
+  -- only a settlement is announced, and the app's sweep in answer signals this worker only for a newly held receipt, so it cannot loop
   case outcome of
     SROCredited present_ -> do
-      -- outside the badge lock: the chat lock must not be taken under it
-      mapM_ presentUserBadgeToContacts present_
       user <- withStore $ \db -> getUser db userId
       toView . CEvtBadgeChanged user =<< getUserBadgeState user
       toView $ CEvtStorePurchaseSettled user
+      -- last, so a failed broadcast cannot lose the settlement; outside the badge lock, as it takes the chat lock
+      mapM_ presentUserBadgeToContacts present_
     SRORefused -> withStore (`getUser` userId) >>= toView . CEvtStorePurchaseSettled
     SRODeferred -> pure ()
   where
@@ -5682,6 +5677,8 @@ badgeIssueFailure e = case e of
     | otherwise -> BIFUnexpected {message = tshow agentError}
   ChatError (CECommandError m) -> BIFUnexpected {message = T.pack m}
   ChatError (CEInternalError m) -> BIFUnexpected {message = T.pack m}
+  ChatError (CEBadgeRedeemError BREUnknownKeyIndex) -> BIFInvalidCredential
+  ChatError (CEBadgeRedeemError BRECredentialNotVerified) -> BIFInvalidCredential
   _ -> BIFUnexpected {message = tshow e}
 
 -- | Whether a failure can clear on its own, which decides whether the alert waits for the shown

src/Simplex/Chat/Store/Badges.hs

@@ -31,7 +31,7 @@ module Simplex.Chat.Store.Badges
     deferStoreReceipt,
     refuseStoreReceipt,
     deleteUnfundedStoreReceipts,
-    deleteBadgeStash,
+    deleteBadgeCodeRedemption,
     createStashBadgePurchase,
     getStashBadgePurchase,
     storeBadgeIssuance,
@@ -226,10 +226,11 @@ getDueStoreReceipts db userId now =
     <$> DB.query
       db
       [sql|
-        SELECT badge_store_receipt_id, purchase_key, purchase_priv_key, master_key, payment, retry_delay
-        FROM badge_store_receipts
-        WHERE user_id = ? AND payment IS NOT NULL AND next_attempt_at <= ?
-        ORDER BY next_attempt_at
+        SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.payment, r.retry_delay
+        FROM badge_store_receipts r
+        JOIN users u ON u.user_id = r.user_id
+        WHERE r.user_id = ? AND r.payment IS NOT NULL AND r.next_attempt_at <= ? AND u.shown_badge_id IS NULL
+        ORDER BY r.next_attempt_at
       |]
       (userId, now)
   where
@@ -239,7 +240,15 @@ getDueStoreReceipts db userId now =
 getNextStoreReceiptAttempt :: DB.Connection -> UserId -> IO (Maybe UTCTime)
 getNextStoreReceiptAttempt db userId =
   fmap join . maybeFirstRow fromOnly $
-    DB.query db "SELECT MIN(next_attempt_at) FROM badge_store_receipts WHERE user_id = ? AND payment IS NOT NULL" (Only userId)
+    DB.query
+      db
+      [sql|
+        SELECT MIN(r.next_attempt_at)
+        FROM badge_store_receipts r
+        JOIN users u ON u.user_id = r.user_id
+        WHERE r.user_id = ? AND r.payment IS NOT NULL AND u.shown_badge_id IS NULL
+      |]
+      (Only userId)
 
 deferStoreReceipt :: DB.Connection -> Int64 -> UTCTime -> Maybe Int64 -> BadgeIssueFailure -> IO ()
 deferStoreReceipt db receiptId nextAttemptAt retryDelay failure =
@@ -269,28 +278,18 @@ toBadgeStash :: (Int64 -> BadgeStashRef) -> (Int64, C.PublicKeyEd25519, C.Privat
 toBadgeStash ref (stashId, purchaseKey, purchasePrivKey, Binary mk) =
   BadgeStash {stashRef = ref stashId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk}
 
--- | Drop a stash whose funding the service refused for good, unless a purchase already came from
--- it - badge_purchases references its row.
-deleteBadgeStash :: DB.Connection -> BadgeStash -> IO ()
-deleteBadgeStash db BadgeStash {stashRef} = case stashRef of
-  BSRCodeRedemption redemptionId ->
-    DB.execute
-      db
-      [sql|
-        DELETE FROM badge_code_redemptions
-        WHERE badge_code_redemption_id = ?
-          AND NOT EXISTS (SELECT 1 FROM badge_purchases WHERE badge_code_redemption_id = ?)
-      |]
-      (redemptionId, redemptionId)
-  BSRStoreReceipt storeReceiptId ->
-    DB.execute
-      db
-      [sql|
-        DELETE FROM badge_store_receipts
-        WHERE badge_store_receipt_id = ?
-          AND NOT EXISTS (SELECT 1 FROM badge_purchases WHERE badge_store_receipt_id = ?)
-      |]
-      (storeReceiptId, storeReceiptId)
+-- | Drop the keys stashed for a code the service refused for good, unless a purchase already came
+-- from them - badge_purchases references their row.
+deleteBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO ()
+deleteBadgeCodeRedemption db User {userId} code =
+  DB.execute
+    db
+    [sql|
+      DELETE FROM badge_code_redemptions
+      WHERE user_id = ? AND code = ?
+        AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_code_redemption_id = badge_code_redemptions.badge_code_redemption_id)
+    |]
+    (userId, code)
 
 -- | 'False' when the stash already funded a purchase here: the service replays the credential it
 -- issued, and that must add no purchase and leave the shown badge alone.

tests/BadgeTests.hs

@@ -36,7 +36,7 @@ import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service
 import Simplex.Chat.Badges.Types (BadgeIssueFailure (..))
 import Simplex.Chat (defaultChatConfig)
-import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..), badgeRetryInterval, chatErrorAgent)
+import Simplex.Chat.Controller (BadgeRedeemError (..), ChatError (..), ChatErrorType (..), badgeRetryInterval, chatErrorAgent)
 import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, storeTransactionRef)
 import Simplex.Chat.PaymentService (ServicePayment (..))
 import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..), StoreTransactionRef (..))
@@ -713,6 +713,8 @@ testIssueFailureClassification = do
   failureFor timeout `shouldBe` BIFNetwork {agentError = tshow timeout}
   failureFor auth `shouldBe` BIFUnexpected {message = tshow auth}
   badgeIssueFailure (ChatError (CECommandError "unexpected badge service response")) `shouldBe` BIFUnexpected {message = "unexpected badge service response"}
+  badgeIssueFailure (ChatError (CEBadgeRedeemError BREUnknownKeyIndex)) `shouldBe` BIFInvalidCredential
+  badgeIssueFailure (ChatError (CEBadgeRedeemError BRECredentialNotVerified)) `shouldBe` BIFInvalidCredential
 
 -- A refusal the service marks transient is not worth a word before the credential lapses. Internal
 -- comes without retryAfter so that a failing service is not pressed, not because the fault is

tests/Bots/BadgeService/BotTests.hs

@@ -140,7 +140,7 @@ badgeServiceTests = do
     it "should keep a refusal on the record, and hold a pending receipt until it settles" testPurchaseStash
     it "should keep a receipt credited to another key as refused" testPurchaseStashReceiptUsed
     it "should hold a Play token the service will not send to Play" testPurchaseUnsentPlayToken
-    it "should hold a store receipt while a badge is held, deferring it with nothing sent" testPurchaseWhileBadgeHeld
+    it "should hold a store receipt while a badge is held, without attempting it" testPurchaseWhileBadgeHeld
     it "should answer a receipt handed over under a second profile as the profile that bought it" testPurchaseSameReceiptOtherProfile
     it "should credit a purchase first handed over under another profile to that profile" testPurchaseStrandedUnderOtherProfile
     it "should credit a purchase to a hidden profile without naming it" testPurchaseDeliveredToHiddenProfile
@@ -150,7 +150,7 @@ badgeServiceTests = do
     it "should attach a late receipt to its record, and credit the profile that created it" testInvoiceLateReceipt
     it "should list a record however old until a receipt reaching it is settled" testInvoiceAgedOut
     it "should refuse an invoice with no service configured or while a badge is held, creating no record" testInvoiceRefusedBeforeCharge
-    it "should hold a receipt for an invoice while a badge is held, deferring it with nothing sent" testInvoiceWhileBadgeHeld
+    it "should hold a receipt for an invoice while a badge is held, without attempting it" testInvoiceWhileBadgeHeld
     it "should list only the asking profile's open store purchases" testInvoiceStateOtherProfile
     it "should credit a receipt the store could not verify once its retryAfter has passed, with no second hand-over" testStoreReceiptRetried
     it "should send nothing for a deferred receipt handed over again before it is due" testStoreReceiptNotSentEarly
@@ -1777,17 +1777,15 @@ testPurchaseUnsentPlayToken ps =
 
 testPurchaseWhileBadgeHeld :: HasCallStack => TestParams -> IO ()
 testPurchaseWhileBadgeHeld ps =
-  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc} ->
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->
     withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
       code <- issueCode cc BTSupporter 1
       redeemFirstBadge alice code
-      since <- testClockTime bsClock
       alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
       alice <##. "1: supporter"
       storePurchaseOpen alice ""
-      (at, failure) <- waitStoreReceiptDeferred (chatController alice) since
-      failure `shouldSatisfy` T.isPrefixOf "unexpected "
-      at `shouldSatisfy` (> addUTCTime (nominalDay - 60) since)
+      (alice </)
+      storeReceiptErrors (chatController alice) `shouldReturn` [Nothing]
       heldStoreReceipts (chatController alice) `shouldReturn` 1
       rowCount cc "sx_badge_service_payments" `shouldReturn` 0
 
@@ -1951,17 +1949,16 @@ testInvoiceRefusedBeforeCharge ps = do
 
 testInvoiceWhileBadgeHeld :: HasCallStack => TestParams -> IO ()
 testInvoiceWhileBadgeHeld ps =
-  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc} ->
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->
     withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
       invoiceId <- createInvoice alice 1
       code <- issueCode cc BTSupporter 1
       redeemFirstBadge alice code
-      since <- testClockTime bsClock
       alice ##> purchaseWithInvoice 1 invoiceId supporterPlay
       alice <##. "1: supporter"
       alice <##. ("store purchase open: invoice " <> invoiceId <> ", transaction ")
-      (_, failure) <- waitStoreReceiptDeferred (chatController alice) since
-      failure `shouldSatisfy` T.isPrefixOf "unexpected "
+      (alice </)
+      storeReceiptErrors (chatController alice) `shouldReturn` [Nothing]
       storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack invoiceId), True)]
       heldStoreReceipts (chatController alice) `shouldReturn` 1
       rowCount cc "sx_badge_service_payments" `shouldReturn` 0
@@ -2095,17 +2092,16 @@ testStoreReceiptCleanup ps =
       alice <## ("store purchase open: invoice " <> unpaid)
       storePurchaseOpen alice ""
       alice <## "store purchase settled"
-      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS})
-      alice <## ("store purchase open: invoice " <> unpaid)
-      storePurchaseOpen alice ""
-      storePurchaseCredited alice "" "1: supporter"
-      -- held behind the badge credited above, so it stays held whatever the store says
       since <- testClockTime bsClock
-      alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
-      alice <##. "1: supporter"
+      alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googleUnreachableToken))
       alice <## ("store purchase open: invoice " <> unpaid)
       storePurchaseOpen alice ""
       _ <- waitStoreReceiptDeferred (chatController alice) since
+      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS})
+      alice <## ("store purchase open: invoice " <> unpaid)
+      storePurchaseOpen alice ""
+      storePurchaseOpen alice ""
+      storePurchaseCredited alice "" "1: supporter"
       storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack unpaid), False), (1, Nothing, True), (1, Nothing, True), (1, Nothing, True)]
       -- a month on, the record no receipt reached and the refusal go; the credited and the held one stay
       testClockTime bsClock >>= setClockAt bsClock . addUTCTime (31 * nominalDay)
@@ -2165,6 +2161,11 @@ waitStoreReceiptRows cc n = loop (100 :: Int)
       rows <- storeReceiptRows cc
       if length rows == n then pure rows else threadDelay 50000 >> loop (i - 1)
 
+storeReceiptErrors :: ChatController -> IO [Maybe Text]
+storeReceiptErrors ChatController {chatStore} =
+  withTransaction chatStore $ \db ->
+    map fromOnly <$> DB.query_ db "SELECT credit_error FROM badge_store_receipts ORDER BY badge_store_receipt_id"
+
 heldStoreReceipts :: ChatController -> IO Int
 heldStoreReceipts ChatController {chatStore} =
   withTransaction chatStore $ \db -> do