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.