diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 085f9d5401..01a84cee7a 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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 diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 8604ab1b60..65be54b2fe 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/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. diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index e31817e562..6bb4b14aa7 100644 --- a/tests/BadgeTests.hs +++ b/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 diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 4fdc4261bf..b4dc94dc0f 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/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 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 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