diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index c424afa7d0..2b45e62512 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -443,7 +443,7 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText -- Redeeming an unpaid code would issue a free badge, so unpaid is refused. | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending | otherwise -> - claimedResponse db BSECodeUsed purchaseKey redemption >>= \case + creditedResponse db BSECodeUsed purchaseKey redemption >>= \case Left resp -> pure $ Left resp Right () | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired @@ -453,11 +453,11 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText -- nothing is written until the credential is signed. purchaseWithReceipt :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeMasterKey -> StoreReceipt -> IO BadgeServiceResponse purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = providerRef}, verifyReceipt} = - withDB' "getStorePayment" cc (\db -> getStorePaymentClaim db provider providerRef) >>= \case + withDB' "getStorePayment" cc (\db -> getStorePaymentCredit db provider providerRef) >>= \case Left _ -> pure $ errorResponse BSEInternal - Right claim + Right credit -- only the key it credited can ask, and it is told only what it was given, so the store is not asked - | claimedBy claim -> answerClaim claim + | creditedBy credit -> answerCredit credit | otherwise -> verifyReceipt >>= \case Left refusal -> storeRefusalResponse refusal @@ -467,16 +467,16 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTran Right VerifiedStoreTransaction {quantity} | quantity /= 1 -> storeRefusalResponse $ SRVerifierFailed $ "verified a quantity of " <> tshow quantity Right VerifiedStoreTransaction {testPurchase = True} -> storeRefusalResponse $ SRInvalid "test purchase" - -- another key's claim is told only once the store vouched for the receipt, or it would reveal which transactions were credited - Right tx -> case claim of - Unclaimed -> newPurchase tx - _ -> answerClaim claim + -- another key's credit is told only once the store vouched for the receipt, or it would reveal which transactions were credited + Right tx -> case credit of + Uncredited -> newPurchase tx + _ -> answerCredit credit where - claimedBy = \case - Claimed ClaimedPurchase {purchaseKey = k} -> k == purchaseKey + creditedBy = \case + Credited CreditedPurchase {purchaseKey = k} -> k == purchaseKey _ -> False - answerClaim claim = - withDB' "answerStoreClaim" cc (\db -> claimedResponse db BSEReceiptUsed purchaseKey claim) <&> \case + answerCredit credit = + withDB' "answerStoreCredit" cc (\db -> creditedResponse db BSEReceiptUsed purchaseKey credit) <&> \case Right (Left resp) -> resp _ -> errorResponse BSEInternal -- the product is read only for a receipt not yet credited, so retiring it leaves its replays answered @@ -492,7 +492,7 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTran liftIO (createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey, badgeType} now) >>= \case -- Credited to another key, or to this one by a request that ran alongside it, while signing. Nothing -> - liftIO (getStorePaymentClaim db provider providerRef >>= claimedResponse db BSEReceiptUsed purchaseKey) >>= \case + liftIO (getStorePaymentCredit db provider providerRef >>= creditedResponse db BSEReceiptUsed purchaseKey) >>= \case Left resp -> pure resp Right () -> logError "badge service: claiming a store payment failed, but it funds no purchase" $> errorResponse BSEInternal Just purchaseId -> liftIO $ firstMonthResponse db purchaseId (Just paymentId) firstMonth @@ -507,11 +507,11 @@ storeRefusalResponse = \case 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 - Unclaimed -> pure $ Right () - ClaimedUnreadable -> pure $ Left $ errorResponse BSEInternal - Claimed ClaimedPurchase {purchaseKey = k, badgePurchaseId, credential} +creditedResponse :: DB.Connection -> BadgeServiceErrorCode -> C.PublicKeyEd25519 -> FundingCredit -> IO (Either BadgeServiceResponse ()) +creditedResponse db usedCode purchaseKey = \case + Uncredited -> pure $ Right () + CreditedUnreadable -> pure $ Left $ errorResponse BSEInternal + Credited CreditedPurchase {purchaseKey = k, badgePurchaseId, credential} | k /= purchaseKey -> pure $ Left $ errorResponse usedCode | otherwise -> maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index 0c50220b49..f81fbe4fe8 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -8,13 +8,13 @@ module BadgeService.Store ( IssuedCode (..), - FundingClaim (..), - ClaimedPurchase (..), + FundingCredit (..), + CreditedPurchase (..), NewCodePurchase (..), NewStorePurchase (..), ServicePurchase (..), getBadgeCode, - getStorePaymentClaim, + getStorePaymentCredit, purchaseKeyExists, getPurchaseByKey, getLedgerTip, @@ -64,15 +64,15 @@ data IssuedCode = IssuedCode paymentStatus :: BadgeCodePaymentStatus, revokedAt :: Maybe UTCTime, expiresAt :: Maybe UTCTime, - redemption :: FundingClaim + redemption :: FundingCredit } -data FundingClaim - = Unclaimed - | Claimed ClaimedPurchase - | ClaimedUnreadable +data FundingCredit + = Uncredited + | Credited CreditedPurchase + | CreditedUnreadable -data ClaimedPurchase = ClaimedPurchase +data CreditedPurchase = CreditedPurchase { badgePurchaseId :: Int64, purchaseKey :: C.PublicKeyEd25519, credential :: BadgeCredential @@ -119,11 +119,11 @@ getBadgeCode db codeHash = (Only (Binary codeHash)) where toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, purchaseId_, purchaseKey_, credential_) = - IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redemption = fundingClaim purchaseId_ purchaseKey_ credential_} + IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redemption = fundingCredit purchaseId_ purchaseKey_ credential_} -getStorePaymentClaim :: DB.Connection -> PaymentProvider -> Text -> IO FundingClaim -getStorePaymentClaim db provider providerRef = - maybeFirstRow' Unclaimed (\(purchaseId, purchaseKey, credential_) -> fundingClaim (Just purchaseId) (Just purchaseKey) credential_) $ +getStorePaymentCredit :: DB.Connection -> PaymentProvider -> Text -> IO FundingCredit +getStorePaymentCredit db provider providerRef = + maybeFirstRow' Uncredited (\(purchaseId, purchaseKey, credential_) -> fundingCredit (Just purchaseId) (Just purchaseKey) credential_) $ DB.query db [sql| @@ -137,12 +137,12 @@ getStorePaymentClaim db provider providerRef = |] (textEncode provider, providerRef) -fundingClaim :: Maybe Int64 -> Maybe C.PublicKeyEd25519 -> Maybe (Binary ByteString) -> FundingClaim -fundingClaim purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of +fundingCredit :: Maybe Int64 -> Maybe C.PublicKeyEd25519 -> Maybe (Binary ByteString) -> FundingCredit +fundingCredit purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of (Just badgePurchaseId, Just purchaseKey) -> case decodeCredential =<< credential_ of - Just credential -> Claimed ClaimedPurchase {badgePurchaseId, purchaseKey, credential} - Nothing -> ClaimedUnreadable - _ -> Unclaimed + Just credential -> Credited CreditedPurchase {badgePurchaseId, purchaseKey, credential} + Nothing -> CreditedUnreadable + _ -> Uncredited where decodeCredential (Binary bs) = J.decodeStrict' bs diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index 86f4e99d4b..bd8b166094 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/tests/Bots/BadgeService/WebTests.hs @@ -14,7 +14,7 @@ import BadgeService.Poller import BadgeService.Providers import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages) import BadgeService.Providers.Stripe (stripeProvider) -import BadgeService.Store (FundingClaim (..), IssuedCode (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getBadgeCode, insertBadgeCode, revokeCode) +import BadgeService.Store (FundingCredit (..), IssuedCode (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getBadgeCode, insertBadgeCode, revokeCode) import BadgeService.Store.Invoices import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount) import BadgeService.Web.Server @@ -471,7 +471,7 @@ testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now unredeemed codeHash = withTransaction st (`getBadgeCode` codeHash) >>= \case - Just IssuedCode {redemption = Unclaimed} -> pure True + Just IssuedCode {redemption = Uncredited} -> pure True _ -> pure False revokedFirst <- newCode "revoked-first" revoke "revoked-first" `shouldReturn` Revoked