diff --git a/apps/simplex-badge-service/src/BadgeService/Catalog.hs b/apps/simplex-badge-service/src/BadgeService/Catalog.hs index b15185da68..00cbf2629e 100644 --- a/apps/simplex-badge-service/src/BadgeService/Catalog.hs +++ b/apps/simplex-badge-service/src/BadgeService/Catalog.hs @@ -11,6 +11,8 @@ module BadgeService.Catalog priceOffer, catalogCurrency, defaultCatalog, + StoreProduct (..), + storeProduct, ) where @@ -21,7 +23,7 @@ import Data.Word (Word32, Word64, Word8) import Simplex.Chat.Badges (BadgeType (..)) import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..)) import Simplex.Chat.Badges.Types (BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..)) -import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) +import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), PaymentProvider (..)) data OfferInvalid = OIZeroMonths | OIFreeMonthsExceedTerm | OIDiscountTooLarge | OIAmountUnsellable deriving (Eq, Show) @@ -133,3 +135,21 @@ defaultCatalog seededAt = (prices, offers) status = BISActive, createdAt = seededAt } + +-- | What one unit of a store product grants. +data StoreProduct = StoreProduct + { badgeType :: BadgeType, + months :: Int + } + deriving (Eq, Show) + +-- | A receipt proves only which product was paid for, so the badge comes from here and never from +-- the client. Mirrors the one-time products of BadgeStore.swift and BadgeStore.kt, whose ids differ +-- by store; their subscriptions are refused, since nothing adds a renewal's months to a badge yet. +storeProduct :: PaymentProvider -> Text -> Maybe StoreProduct +storeProduct provider productId = case (provider, productId) of + (PPApple, "BADGE_SUPPORTER_01") -> Just $ StoreProduct BTSupporter 1 + (PPApple, "BADGE_LEGEND_01") -> Just $ StoreProduct BTLegend 1 + (PPGoogle, "badge_supporter_01") -> Just $ StoreProduct BTSupporter 1 + (PPGoogle, "badge_legend_01") -> Just $ StoreProduct BTLegend 1 + _ -> Nothing diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 9a3a3f4236..32f68a3818 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -20,7 +20,7 @@ module BadgeService.Service ) where -import BadgeService.Catalog (defaultCatalog) +import BadgeService.Catalog (StoreProduct (..), defaultCatalog, storeProduct) import BadgeService.Config (BadgeIssuerKey (..), ServiceConfig (..), readServiceConfig) import BadgeService.Options import BadgeService.Poller (newPollerEnv, newReadHints, runPoller) @@ -29,6 +29,7 @@ import BadgeService.Providers.Stripe (stripeProvider) import BadgeService.Store import BadgeService.Store.Invoices (seedCatalog, truncateToSecond) import BadgeService.Store.Migrate (runBadgeServiceMigrations) +import BadgeService.StoreReceipts import BadgeService.Waiters (Waiters, newWaiters) import BadgeService.Web.Server (exportWebapp, newWebEnv, runWebListener) import Control.Applicative (optional) @@ -44,6 +45,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace) import Data.Either (fromRight) import Data.Functor (($>)) +import Data.Int (Int64) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Text as T @@ -61,10 +63,12 @@ import Simplex.Chat.Core (sendChatCmd, simplexChatCore) import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..), ciContentToText) import Simplex.Chat.Options (printDbOpts) +import Simplex.Chat.PaymentService.Types (PaymentProvider) import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal.Main (simplexChatCLI') import Simplex.Chat.Types (AgentInvId (..), Contact, User (..)) import Simplex.Messaging.Agent.Store.Common (DBStore) +import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (bbsPublicKey) import Simplex.Messaging.Encoding.String (TextEncoding, strEncode, textDecode, textEncode) @@ -76,15 +80,18 @@ import System.Exit (exitFailure) data ServiceState = ServiceState { serviceCC :: TMVar ChatController, serviceRequestQ :: TQueue (User, AgentInvId, Maybe C.PublicKeyEd25519, J.Object), - chatRedeemQ :: TQueue (Contact, T.Text) + chatRedeemQ :: TQueue (Contact, T.Text), + 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. newServiceState :: IO ServiceState newServiceState = do serviceCC <- newEmptyTMVarIO serviceRequestQ <- newTQueueIO chatRedeemQ <- newTQueueIO - pure ServiceState {serviceCC, serviceRequestQ, chatRedeemQ} + pure ServiceState {serviceCC, serviceRequestQ, chatRedeemQ, storeVerifier = noStoreVerifier} welcomeGetOpts :: IO BadgeServiceOpts welcomeGetOpts = do @@ -272,7 +279,7 @@ processQueuedRequests key env = do cc <- atomically $ readTMVar $ serviceCC env forever $ do (u, reqId, sigKey, reqData) <- atomically $ readTQueue $ serviceRequestQ env - handleServiceRequest key cc u reqId sigKey reqData + handleServiceRequest key (storeVerifier env) cc u reqId sigKey reqData processChatRedeems :: BadgeIssuerKey -> ServiceState -> IO () processChatRedeems key env = do @@ -308,11 +315,11 @@ badgePostStartHook BadgeServiceOpts {noAddress, testing} devRedeem env cc = do unless noAddress $ initializeBotAddress' (not testing) (Just True) devRedeem cc void $ atomically $ tryPutTMVar (serviceCC env) cc -handleServiceRequest :: BadgeIssuerKey -> ChatController -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO () -handleServiceRequest key cc User {userId} reqId sigKey reqData = do +handleServiceRequest :: BadgeIssuerKey -> StoreVerifier -> ChatController -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO () +handleServiceRequest key verifier cc User {userId} reqId sigKey reqData = do let reqIdT = safeDecodeUtf8 (strEncode reqId) logInfo $ "badge service request " <> reqIdT - resp <- badgeServiceResponse key cc sigKey reqData + resp <- badgeServiceResponse key verifier cc sigKey reqData sendChatCmd cc (APISendServiceResponse userId reqId (responseObject resp)) >>= \case Right _ -> pure () Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e @@ -334,8 +341,8 @@ badgeErrorRetryAfter = \case -- | The agent verified the signature, so sigKey is a key the sender holds; a differing purchaseKey would let a client claim a purchase it cannot sign for. -badgeServiceResponse :: BadgeIssuerKey -> ChatController -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse -badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData) of +badgeServiceResponse :: BadgeIssuerKey -> StoreVerifier -> ChatController -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse +badgeServiceResponse key verifier cc sigKey reqData = case J.fromJSON (J.Object reqData) of J.Error _ -> pure $ errorResponse BSEBadRequest J.Success BadgeServiceRequest {version, purchaseKey, request} | not (version `isCompatible` supportedBadgeServiceVRange) -> pure $ errorResponse BSEUnsupportedVersion @@ -344,10 +351,16 @@ badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData) BSCRedeemBadgeCode {masterKey, code} -> case purchaseKey of Just k -> redeemCode key cc k masterKey code Nothing -> pure $ errorResponse BSEBadRequest + BSCPurchaseBadge {masterKey, payment, upgrade} + | Just (provider, verify) <- storeVerification verifier payment -> case (purchaseKey, upgrade) of + (Just k, Nothing) -> purchaseWithReceipt key cc k masterKey provider verify + -- store upgrades are not built, and ignoring one would credit its months at the discounted price + (Just _, Just _) -> pure $ errorResponse BSEUnsupportedVersion + (Nothing, _) -> pure $ errorResponse BSEBadRequest BSCIssueBadge {balance} -> case purchaseKey of Just k -> issueBadgeCmd key cc k balance Nothing -> pure $ errorResponse BSEBadRequest - -- Every command but redeemBadgeCode needs a key the service already knows; that one creates the purchase, so its key is unknown on a first redemption. + -- Every command but redeemBadgeCode and purchaseBadge from a store needs a key the service already knows; those two create the purchase, so their key is unknown on a first purchase. _ -> case purchaseKey of Nothing -> pure $ errorResponse BSEUnsupportedVersion Just k -> @@ -384,29 +397,19 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText withDB "getBadgeCode" cc (readCode now code) >>= \case Left _ -> pure $ errorResponse BSEInternal Right (Left resp) -> pure resp - Right (Right IssuedCode {badgeCodeId, badgeType, months}) -> do - (grantUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc - -- TODO [badges] a top-up grants onto an existing ledger, and must lapse before it or the - -- months it adds are counted from a start already in the past - let granted = grantEntry now grantUuid months SCCode $ emptyEntry now badgeType - -- A grant of at least one month starting now always has a month to issue. - case issueEntry now issueUuid granted of - Nothing -> pure $ errorResponse BSEInternal - Just issued -> credentialForEntry key masterKey issued >>= \case - Left e -> logError ("badge service signing failed: " <> T.pack e) $> errorResponse BSEInternal - Right signed -> do - -- If the code was revoked or redeemed while signing, the claim fails. Read the code again to tell the client why. - r <- withDB "writeCodeRedemption" cc $ \db -> - liftIO (createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now) >>= \case - Nothing -> - readCode now code db >>= \case - Left resp -> pure resp - Right _ -> logError "badge service: redeeming a code failed, but the code is neither redeemed nor revoked" $> errorResponse BSEInternal - Just purchaseId -> liftIO $ do - appendLedgerPlan db purchaseId [granted] $ Just $ issuanceAfter granted signed - entries_ <- getLedgerEntries db purchaseId 0 - pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_ - pure $ fromRight (errorResponse BSEInternal) r + Right (Right IssuedCode {badgeCodeId, badgeType, months}) -> + signFirstMonth key cc masterKey badgeType months SCCode now >>= \case + Left resp -> pure resp + Right firstMonth -> do + -- If the code was revoked or redeemed while signing, the claim fails. Read the code again to tell the client why. + r <- withDB "writeCodeRedemption" cc $ \db -> + liftIO (createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now) >>= \case + Nothing -> + readCode now code db >>= \case + Left resp -> pure resp + Right _ -> logError "badge service: redeeming a code failed, but the code is neither redeemed nor revoked" $> errorResponse BSEInternal + Just purchaseId -> liftIO $ firstMonthResponse db purchaseId Nothing firstMonth + pure $ fromRight (errorResponse BSEInternal) r where readCode now code db = liftIO $ getBadgeCode db (badgeCodeHash code) >>= \case @@ -417,19 +420,83 @@ 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 -> - checkUnspent db redemption >>= \case + claimedResponse db BSECodeUsed purchaseKey redemption >>= \case Left resp -> pure $ Left resp Right () | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired | otherwise -> pure $ Right c - checkUnspent db = \case - CodeUnredeemed -> pure $ Right () - CodeRedeemedUnreadable -> pure $ Left $ errorResponse BSEInternal - CodeRedeemed RedeemedCode {purchaseKey = k, badgePurchaseId, credential} - | k /= purchaseKey -> pure $ Left $ errorResponse BSECodeUsed - | otherwise -> - maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) - <$> getLedgerEntries db badgePurchaseId 0 + +-- | Every refusal is answered before anything is written, so it leaves the receipt unclaimed; and +-- nothing is written until the credential is signed. +purchaseWithReceipt :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeMasterKey -> PaymentProvider -> IO (Either StoreRefusal StoreTransaction) -> IO BadgeServiceResponse +purchaseWithReceipt key cc purchaseKey masterKey provider verify = + verify >>= \case + Left refusal -> storeRefusalResponse refusal + Right StoreTransaction {providerRef, productId, quantity, paid} -> + withDB "getStorePayment" cc (readClaim providerRef) >>= \case + Left _ -> pure $ errorResponse BSEInternal + Right (Left resp) -> pure resp + -- the product is read only for a receipt not yet credited, so retiring it leaves its replays answered + Right (Right ()) -> case storeProduct provider productId of + Nothing -> pure $ errorResponse BSEProductUnavailable + Just StoreProduct {badgeType, months} -> do + now <- badgeNow cc + signFirstMonth key cc masterKey badgeType (months * quantity) (SCPayment Nothing) now >>= \case + Left resp -> pure resp + Right firstMonth -> do + paymentId <- randomId cc + r <- withDB "writeStorePurchase" cc $ \db -> + 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 -> + readClaim providerRef db >>= \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 + pure $ fromRight (errorResponse BSEInternal) r + where + readClaim providerRef db = liftIO $ getStorePaymentClaim db provider providerRef >>= claimedResponse db BSEReceiptUsed purchaseKey + +-- | The client learns only the code: a forged receipt and a refunded purchase are both receipt_invalid. +storeRefusalResponse :: StoreRefusal -> IO BadgeServiceResponse +storeRefusalResponse = \case + SRInvalid reason -> logInfo ("store receipt refused: " <> reason) $> errorResponse BSEReceiptInvalid + SRPending -> pure $ errorResponse BSEPaymentPending + SRUnreachable reason -> logWarn ("store unreachable: " <> reason) $> errorResponse BSEProviderUnavailable + +-- | A funding already spent answers as the purchase it funded: that purchase again for its own key, +-- and usedCode for any other. +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} + | k /= purchaseKey -> pure $ Left $ errorResponse usedCode + | otherwise -> + maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) + <$> getLedgerEntries db badgePurchaseId 0 + +-- | The grant of a new purchase and the first month issued from it, signed; nothing is written. +signFirstMonth :: BadgeIssuerKey -> ChatController -> BadgeMasterKey -> BadgeType -> Int -> StatementCreditType -> UTCTime -> IO (Either BadgeServiceResponse (StatementEntry, (StatementEntry, BadgeCredential))) +signFirstMonth key cc masterKey badgeType months credit now = do + (grantUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc + -- TODO [badges] a top-up grants onto an existing ledger, and must lapse before it or the + -- months it adds are counted from a start already in the past + let granted = grantEntry now grantUuid months credit $ emptyEntry now badgeType + -- A grant of at least one month starting now always has a month to issue. + case issueEntry now issueUuid granted of + Nothing -> pure $ Left $ errorResponse BSEInternal + Just issued -> + credentialForEntry key masterKey issued >>= \case + Left e -> logError ("badge service signing failed: " <> T.pack e) $> Left (errorResponse BSEInternal) + Right signed -> pure $ Right (granted, signed) + +-- | Writes what signFirstMonth signed onto the purchase just claimed for it. +firstMonthResponse :: DB.Connection -> Int64 -> Maybe T.Text -> (StatementEntry, (StatementEntry, BadgeCredential)) -> IO BadgeServiceResponse +firstMonthResponse db purchaseId creditPaymentId_ (granted, signed) = do + appendLedgerPlan db purchaseId creditPaymentId_ [granted] $ Just $ issuanceAfter granted signed + entries_ <- getLedgerEntries db purchaseId 0 + pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_ -- | The purchase is reached through the verified signer key and no other way. issueBadgeCmd :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse @@ -458,7 +525,7 @@ issueBadgeCmd key cc purchaseKey BadgeBalance {lastEntry} = do writeIssued purchaseId tip rows t issuance_ = do r <- withDB "issueBadge" cc $ \db -> liftIO $ do tip' <- getLedgerTip db purchaseId - when (fmap entryId tip' == fmap entryId tip) $ appendLedgerPlan db purchaseId rows issuance_ + when (fmap entryId tip' == fmap entryId tip) $ appendLedgerPlan db purchaseId Nothing rows issuance_ issueResponse db purchaseId t pure $ fromRight (errorResponse BSEInternal) r -- Only the asserted entry's identity is read, never the months it claims. diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index d8ab44c268..59e423c3d7 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -4,14 +4,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module BadgeService.Store ( IssuedCode (..), - CodeRedemption (..), - RedeemedCode (..), + FundingClaim (..), + ClaimedPurchase (..), NewCodePurchase (..), + NewStorePurchase (..), ServicePurchase (..), getBadgeCode, + getStorePaymentClaim, purchaseKeyExists, getPurchaseByKey, getLedgerTip, @@ -20,13 +23,14 @@ module BadgeService.Store getCurrentIssuance, appendLedgerPlan, createCodePurchase, + createStorePurchase, insertBadgeCode, RevokeResult (..), revokeCode, ) where -import BadgeService.Store.Invoices (executeChanging) +import BadgeService.Store.Invoices (executeChanging, paymentStatusText, providerText) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB @@ -35,8 +39,9 @@ import Data.Text (Text) import Data.Time.Clock (UTCTime) import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType) import Simplex.Chat.Badges.Ledger -import Simplex.Chat.Badges.Service (StatementEntry (..)) +import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementEntry (..), StatementEntryType (..)) import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus, BadgePurchaseStatus (..)) +import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceId (..), PaymentProvider, PaymentStatus (..)) import Simplex.Chat.Store.Shared (insertedRowId) import Simplex.Messaging.Agent.Store.DB (Binary (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -58,15 +63,16 @@ data IssuedCode = IssuedCode paymentStatus :: BadgeCodePaymentStatus, revokedAt :: Maybe UTCTime, expiresAt :: Maybe UTCTime, - redemption :: CodeRedemption + redemption :: FundingClaim } -data CodeRedemption - = CodeUnredeemed - | CodeRedeemed RedeemedCode - | CodeRedeemedUnreadable +-- | Whether a code or a store payment has already funded a purchase, and which. +data FundingClaim + = Unclaimed + | Claimed ClaimedPurchase + | ClaimedUnreadable -data RedeemedCode = RedeemedCode +data ClaimedPurchase = ClaimedPurchase { badgePurchaseId :: Int64, purchaseKey :: C.PublicKeyEd25519, credential :: BadgeCredential @@ -79,6 +85,16 @@ data NewCodePurchase = NewCodePurchase badgeType :: BadgeType } +data NewStorePurchase = NewStorePurchase + { paymentId :: Text, + provider :: PaymentProvider, + providerRef :: Text, + paid :: Maybe (CurrencyAmount, Text), + purchaseKey :: C.PublicKeyEd25519, + masterKey :: BadgeMasterKey, + badgeType :: BadgeType + } + data ServicePurchase = ServicePurchase { badgePurchaseId :: Int64, masterKey :: BadgeMasterKey, @@ -103,12 +119,32 @@ 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 = codeRedemption purchaseId_ purchaseKey_ credential_} - codeRedemption purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of - (Just badgePurchaseId, Just purchaseKey) -> case decodeCredential =<< credential_ of - Just credential -> CodeRedeemed RedeemedCode {badgePurchaseId, purchaseKey, credential} - Nothing -> CodeRedeemedUnreadable - _ -> CodeUnredeemed + IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redemption = fundingClaim purchaseId_ purchaseKey_ credential_} + +-- | The purchase a store transaction's payment funds, read the same way as a code's. +getStorePaymentClaim :: DB.Connection -> PaymentProvider -> Text -> IO FundingClaim +getStorePaymentClaim db provider providerRef = + maybeFirstRow' Unclaimed (\(purchaseId, purchaseKey, credential_) -> fundingClaim (Just purchaseId) (Just purchaseKey) credential_) $ + DB.query + db + [sql| + SELECT p.badge_purchase_id, p.purchase_key, i.credential + FROM sx_badge_service_payments pay + JOIN sx_badge_service_badge_purchases p ON p.payment_id = pay.payment_id + LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id + WHERE pay.provider = ? AND pay.provider_ref = ? + ORDER BY i.period_end DESC + LIMIT 1 + |] + (providerText provider, providerRef) + +fundingClaim :: Maybe Int64 -> Maybe C.PublicKeyEd25519 -> Maybe (Binary ByteString) -> FundingClaim +fundingClaim 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 + where decodeCredential (Binary bs) = J.decodeStrict' bs purchaseKeyExists :: DB.Connection -> C.PublicKeyEd25519 -> IO Bool @@ -137,11 +173,12 @@ getLedgerTip db purchaseId = DB.query db [sql| - SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type, - entry_type, entry_credit_type, entry_debit_type, service_created_at - FROM sx_badge_service_badge_ledger - WHERE badge_purchase_id = ? - ORDER BY entry_id DESC + SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type, + l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id + FROM sx_badge_service_badge_ledger l + LEFT JOIN sx_badge_service_payments pay ON pay.payment_id = l.payment_id + WHERE l.badge_purchase_id = ? + ORDER BY l.entry_id DESC LIMIT 1 |] (Only purchaseId) @@ -161,18 +198,19 @@ getLedgerEntries db purchaseId afterEntryId = <$> DB.query db [sql| - SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type, - entry_type, entry_credit_type, entry_debit_type, service_created_at - FROM sx_badge_service_badge_ledger - WHERE badge_purchase_id = ? AND entry_id > ? - ORDER BY entry_id + SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type, + l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id + FROM sx_badge_service_badge_ledger l + LEFT JOIN sx_badge_service_payments pay ON pay.payment_id = l.payment_id + WHERE l.badge_purchase_id = ? AND l.entry_id > ? + ORDER BY l.entry_id |] (purchaseId, afterEntryId) -toEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType, Text, Maybe Text, Maybe Text, UTCTime) -> Maybe StatementEntry -toEntry (entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, entryType_, credit_, debit_, createdAt) = +toEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType, Text, Maybe Text, Maybe Text, UTCTime) :. (Maybe Text, Maybe Text) -> Maybe StatementEntry +toEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, entryType_, credit_, debit_, createdAt) :. (paymentId_, invoiceId_)) = (\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince = Nothing, createdAt, entryType}) - <$> entryTypeFromColumns entryType_ credit_ debit_ + <$> entryTypeFromColumns ((InvoiceId <$> invoiceId_) <$ paymentId_) entryType_ credit_ debit_ getCurrentIssuance :: DB.Connection -> Int64 -> UTCTime -> IO (Maybe BadgeCredential) getCurrentIssuance db purchaseId now = do @@ -190,9 +228,10 @@ getCurrentIssuance db purchaseId now = do [Only (Binary bs)] -> J.decodeStrict' bs _ -> Nothing --- TODO write the reference columns (payment_id, charge_id, from_purchase_id, to_purchase_id) for entry types that carry one; only the tag is written today. -appendLedgerPlan :: DB.Connection -> Int64 -> [StatementEntry] -> Maybe (StatementEntry, StatementEntry, BadgeCredential) -> IO () -appendLedgerPlan db purchaseId rows issuance_ = do +-- | creditPaymentId_ names the payment behind a payment credit among the rows. +-- TODO write the other reference columns (charge_id, from_purchase_id, to_purchase_id) for entry types that carry one; only the tag is written today. +appendLedgerPlan :: DB.Connection -> Int64 -> Maybe Text -> [StatementEntry] -> Maybe (StatementEntry, StatementEntry, BadgeCredential) -> IO () +appendLedgerPlan db purchaseId creditPaymentId_ rows issuance_ = do mapM_ appendRow rows case issuance_ of Nothing -> pure () @@ -211,15 +250,18 @@ appendLedgerPlan db purchaseId rows issuance_ = do where appendRow StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, createdAt, entryType} = do let (entryTypeT, creditType, debitType) = entryTypeColumns entryType + paymentId_ = case entryType of + SECredit SCPayment {} -> creditPaymentId_ + _ -> Nothing DB.execute db [sql| INSERT INTO sx_badge_service_badge_ledger (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts, - balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type, payment_id) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType)) + ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType, paymentId_)) insertedRowId db -- redeemed_at is stamped here, so this must run in the same transaction as the credential rows. @@ -245,6 +287,33 @@ createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = Bad (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now) Just <$> insertedRowId db +-- | Must run in the same transaction as the credential rows. The payment is inserted before the +-- purchase, and its (provider, provider_ref) is unique: a transaction presented twice at once, or +-- under another key, inserts nothing the second time and fails. +createStorePurchase :: DB.Connection -> NewStorePurchase -> UTCTime -> IO (Maybe Int64) +createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do + claimed <- + executeChanging + db + [sql| + INSERT INTO sx_badge_service_payments (payment_id, provider, provider_ref, amount, currency, status, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?) + ON CONFLICT (provider, provider_ref) DO NOTHING + |] + (paymentId, providerText provider, providerRef, (\(CurrencyAmount a) -> a) . fst <$> paid, snd <$> paid, paymentStatusText PSSettled, now, now) + if claimed == 0 + then pure Nothing + else do + DB.execute + db + [sql| + INSERT INTO sx_badge_service_badge_purchases + (purchase_key, master_key, initial_badge_type, current_badge_type, status, payment_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?) + |] + (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, paymentId, now, now) + Just <$> insertedRowId db + data RevokeResult = Revoked | AlreadyRevoked | AlreadyRedeemed | NoSuchCode deriving (Eq, Show) diff --git a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs index c8179d5df2..a58df6d02b 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs @@ -17,7 +17,8 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = - [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema) + [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), + ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -109,6 +110,44 @@ DROP INDEX @idx_badge_purchases_code; DROP TABLE @badge_codes; |] +m20260925_badge_store_receipts :: Text +m20260925_badge_store_receipts = + withPrefix + servicePrefix + -- The unique provider_ref is what makes one store transaction fund one purchase: presented twice + -- at once, or under two keys, only one insert of its payment succeeds. + [r| +DROP INDEX @idx_payments_provider_ref; + +CREATE UNIQUE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref); + +ALTER TABLE @badge_purchases ADD COLUMN payment_id TEXT REFERENCES @payments; + +CREATE UNIQUE INDEX @idx_badge_purchases_payment ON @badge_purchases(payment_id); + +ALTER TABLE @badge_ledger ADD COLUMN payment_id TEXT REFERENCES @payments; + +CREATE INDEX @idx_badge_ledger_payment ON @badge_ledger(payment_id); +|] + +down_m20260925_badge_store_receipts :: Text +down_m20260925_badge_store_receipts = + withPrefix + servicePrefix + [r| +DROP INDEX @idx_badge_ledger_payment; + +ALTER TABLE @badge_ledger DROP COLUMN payment_id; + +DROP INDEX @idx_badge_purchases_payment; + +ALTER TABLE @badge_purchases DROP COLUMN payment_id; + +DROP INDEX @idx_payments_provider_ref; + +CREATE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref); +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA; diff --git a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs index bf022f189c..fed5fd5ed0 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs @@ -18,7 +18,8 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations = - [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema) + [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), + ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -110,6 +111,44 @@ DROP INDEX @idx_badge_purchases_code; DROP TABLE @badge_codes; |] +m20260925_badge_store_receipts :: Query +m20260925_badge_store_receipts = + withPrefix + servicePrefix + -- The unique provider_ref is what makes one store transaction fund one purchase: presented twice + -- at once, or under two keys, only one insert of its payment succeeds. + [sql| +DROP INDEX @idx_payments_provider_ref; + +CREATE UNIQUE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref); + +ALTER TABLE @badge_purchases ADD COLUMN payment_id TEXT REFERENCES @payments; + +CREATE UNIQUE INDEX @idx_badge_purchases_payment ON @badge_purchases(payment_id); + +ALTER TABLE @badge_ledger ADD COLUMN payment_id TEXT REFERENCES @payments; + +CREATE INDEX @idx_badge_ledger_payment ON @badge_ledger(payment_id); +|] + +down_m20260925_badge_store_receipts :: Query +down_m20260925_badge_store_receipts = + withPrefix + servicePrefix + [sql| +DROP INDEX @idx_badge_ledger_payment; + +ALTER TABLE @badge_ledger DROP COLUMN payment_id; + +DROP INDEX @idx_badge_purchases_payment; + +ALTER TABLE @badge_purchases DROP COLUMN payment_id; + +DROP INDEX @idx_payments_provider_ref; + +CREATE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref); +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BLOB; diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs new file mode 100644 index 0000000000..87e1c586ad --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module BadgeService.StoreReceipts + ( StoreTransaction (..), + StoreRefusal (..), + StoreVerifier (..), + noStoreVerifier, + storeVerification, + ) +where + +import Data.Text (Text) +import Simplex.Chat.PaymentService (ServicePayment (..)) +import Simplex.Chat.PaymentService.Types (CurrencyAmount, PaymentProvider (..)) +import Simplex.Messaging.Util (catchOwn') + +-- | What a store vouches for about one completed transaction. providerRef is its stable id and is +-- stored, so it is never a bearer secret: Apple's transactionId, a hash of Google's purchase token. +data StoreTransaction = StoreTransaction + { providerRef :: Text, + productId :: Text, + quantity :: Int, + paid :: Maybe (CurrencyAmount, Text) -- in minor units; Google's purchase record carries no price + } + deriving (Eq, Show) + +-- | The reasons are for the service's log alone and must never quote the receipt. +data StoreRefusal + = SRInvalid Text -- the store does not vouch for it: forged, malformed, another app's, unknown or refunded + | SRPending -- a real purchase the store has not settled; it may yet + | SRUnreachable Text -- the store was not asked, or did not answer + deriving (Eq, Show) + +-- | Not a Provider: a receipt is presented once as proof, with nothing to create, watch or cancel. +-- A verifier answers SRInvalid only on the store's own word, never for failing to reach it. +data StoreVerifier = StoreVerifier + { verifyApple :: Text -> IO (Either StoreRefusal StoreTransaction), -- the JWS + verifyGoogle :: Text -> Text -> IO (Either StoreRefusal StoreTransaction) -- the product id and the token + } + +noStoreVerifier :: StoreVerifier +noStoreVerifier = StoreVerifier {verifyApple = \_ -> unconfigured, verifyGoogle = \_ _ -> unconfigured} + where + unconfigured = pure $ Left $ SRUnreachable "no verifier configured" + +-- | Nothing for a payment no store made. A verifier that throws was not answered, so it is +-- unreachable, never invalid; its exception is not logged, since it can hold a URL with the token. +storeVerification :: StoreVerifier -> ServicePayment -> Maybe (PaymentProvider, IO (Either StoreRefusal StoreTransaction)) +storeVerification StoreVerifier {verifyApple, verifyGoogle} = \case + SPApple {jws} -> Just (PPApple, answered $ verifyApple jws) + SPGoogle {productId, token} -> Just (PPGoogle, answered $ verifyGoogle productId token) + SPInvoice {} -> Nothing + SPReceipt {} -> Nothing + where + answered verify = verify `catchOwn'` \_ -> pure $ Left $ SRUnreachable "verifier threw" diff --git a/apps/simplex-badge-service/test-fixtures/apple/transaction-legend.json b/apps/simplex-badge-service/test-fixtures/apple/transaction-legend.json new file mode 100644 index 0000000000..36068a8030 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/apple/transaction-legend.json @@ -0,0 +1,19 @@ +{ + "transactionId": "2000000812345672", + "originalTransactionId": "2000000812345672", + "bundleId": "chat.simplex.app", + "productId": "BADGE_LEGEND_01", + "purchaseDate": 1790000000000, + "originalPurchaseDate": 1790000000000, + "quantity": 1, + "type": "Consumable", + "appAccountToken": "0b6a7e1d-5c3f-4a8e-b2d4-9e1f6c7a8b20", + "inAppOwnershipType": "PURCHASED", + "signedDate": 1790000001000, + "environment": "Sandbox", + "transactionReason": "PURCHASE", + "storefront": "USA", + "storefrontId": "143441", + "price": 70000, + "currency": "USD" +} diff --git a/apps/simplex-badge-service/test-fixtures/apple/transaction-supporter.json b/apps/simplex-badge-service/test-fixtures/apple/transaction-supporter.json new file mode 100644 index 0000000000..0a86f61da5 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/apple/transaction-supporter.json @@ -0,0 +1,19 @@ +{ + "transactionId": "2000000812345671", + "originalTransactionId": "2000000812345671", + "bundleId": "chat.simplex.app", + "productId": "BADGE_SUPPORTER_01", + "purchaseDate": 1790000000000, + "originalPurchaseDate": 1790000000000, + "quantity": 1, + "type": "Consumable", + "appAccountToken": "7f7c0f43-4b7b-4c2e-9d57-1b7a2b1f3c11", + "inAppOwnershipType": "PURCHASED", + "signedDate": 1790000001000, + "environment": "Sandbox", + "transactionReason": "PURCHASE", + "storefront": "USA", + "storefrontId": "143441", + "price": 7000, + "currency": "USD" +} diff --git a/bots/src/API/Docs/Commands.hs b/bots/src/API/Docs/Commands.hs index 4ffba7bfbe..635a8c7ff6 100644 --- a/bots/src/API/Docs/Commands.hs +++ b/bots/src/API/Docs/Commands.hs @@ -407,6 +407,7 @@ undocumentedCommands = "APIPlanForwardChatItems", "APIPrepareContact", "APIPrepareGroup", + "APIPurchaseBadge", "APIRedeemBadgeCode", "APIRegisterToken", "APIRejectCall", diff --git a/docs/protocol/badges-rpc.md b/docs/protocol/badges-rpc.md index 8ea70e1d19..e9a8f4cd78 100644 --- a/docs/protocol/badges-rpc.md +++ b/docs/protocol/badges-rpc.md @@ -27,12 +27,12 @@ A timeout hides the outcome, so the client repeats the identical signed request ## Commands -`purchaseBadge` and `upgradeBadgeSubscription` carry `badgeRequest`, the signer's input (`BadgeRequest`, `Simplex.Chat.Badges`): the service signs exactly this content or rejects the command. The proposed `badgeExpiry` is capped by the funded coverage (`sundayAfter`, model §3) and is required — a credential always expires, and a badge that does not is expressed as a long finite term; `badgeExtra` is reserved and must be empty. `issueBadge` carries no `badgeRequest`: the tier, the master key and the expiry are all the service's own, so there is nothing for the client to state. +`upgradeBadgeSubscription` carries `badgeRequest`, the signer's input (`BadgeRequest`, `Simplex.Chat.Badges`): the service signs exactly this content or rejects the command. The proposed `badgeExpiry` is capped by the funded coverage (`sundayAfter`, model §3) and is required — a credential always expires, and a badge that does not is expressed as a long finite term; `badgeExtra` is reserved and must be empty. `issueBadge` carries no `badgeRequest`: the tier, the master key and the expiry are all the service's own, so there is nothing for the client to state. - `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` 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. 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; `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, recording nothing. 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. - `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). diff --git a/docs/protocol/badges-rpc.schema.json b/docs/protocol/badges-rpc.schema.json index 01581a5bac..52cdcd0948 100644 --- a/docs/protocol/badges-rpc.schema.json +++ b/docs/protocol/badges-rpc.schema.json @@ -95,7 +95,7 @@ "properties": {"jws": {"type": "string"}} }, "google": { - "properties": {"token": {"type": "string"}} + "properties": {"productId": {"type": "string"}, "token": {"type": "string"}} }, "invoice": { "properties": {"invoiceId": {"type": "string"}} @@ -309,7 +309,7 @@ }, "purchaseBadge": { "properties": { - "badgeRequest": {"ref": "badgeRequest"}, + "masterKey": {"ref": "base64url"}, "payment": {"ref": "payment"} }, "optionalProperties": { diff --git a/simplex-chat.cabal b/simplex-chat.cabal index e759fbdd3e..87aae0578e 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -168,6 +168,7 @@ library Simplex.Chat.Store.Postgres.Migrations.M20260915_user_badges Simplex.Chat.Store.Postgres.Migrations.M20260918_badge_issue_errors Simplex.Chat.Store.Postgres.Migrations.M20260923_preferences_json + Simplex.Chat.Store.Postgres.Migrations.M20260925_badge_store_receipts else exposed-modules: Simplex.Chat.Archive @@ -345,6 +346,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20260915_user_badges Simplex.Chat.Store.SQLite.Migrations.M20260918_badge_issue_errors Simplex.Chat.Store.SQLite.Migrations.M20260923_preferences_json + Simplex.Chat.Store.SQLite.Migrations.M20260925_badge_store_receipts other-modules: Paths_simplex_chat hs-source-dirs: @@ -441,6 +443,7 @@ executable simplex-badge-service BadgeService.Store BadgeService.Store.Invoices BadgeService.Store.Migrate + BadgeService.StoreReceipts BadgeService.Waiters BadgeService.Web.Server Paths_simplex_chat @@ -729,6 +732,7 @@ test-suite simplex-chat-test BadgeService.Store BadgeService.Store.Invoices BadgeService.Store.Migrate + BadgeService.StoreReceipts BadgeService.Waiters BadgeService.Web.Server Bots.BadgeService.BTCPayTests @@ -736,6 +740,7 @@ test-suite simplex-chat-test Bots.BadgeService.CatalogTests Bots.BadgeService.ConfigTests Bots.BadgeService.FakeBTCPay + Bots.BadgeService.FakeStore Bots.BadgeService.FakeStripe Bots.BadgeService.StripeTests Bots.BadgeService.WaitersTests diff --git a/src/Simplex/Chat/Badges/Ledger.hs b/src/Simplex/Chat/Badges/Ledger.hs index 2f31773d2d..190c56ce4c 100644 --- a/src/Simplex/Chat/Badges/Ledger.hs +++ b/src/Simplex/Chat/Badges/Ledger.hs @@ -26,6 +26,7 @@ import Data.Time.Calendar.WeekDate (toWeekDate) import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime) import Simplex.Chat.Badges (BadgeType) import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..)) +import Simplex.Chat.PaymentService.Types (InvoiceId) -- The calendar difference overshoots by at most one month, so one comparison settles it. monthsBetween :: UTCTime -> UTCTime -> Integer @@ -204,13 +205,15 @@ debitTypeTag = \case SDLapse -> "lapse" SDUnknown {tag} -> tag --- | Only the types a tag alone rebuilds, which is those whose constructor has no fields; the rest --- answer Nothing rather than a type with an invented payload. The client also stores each type's --- JSON and reads that first, so this is its fallback; the service has no such column. --- TODO [badges] take the reference columns and rebuild payment, charge, transferIn, upgrade and --- transferOut, without which the service cannot re-emit a statement carrying one. -entryTypeFromColumns :: Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType -entryTypeFromColumns entryType credit_ debit_ = case (entryType, credit_, debit_) of +-- | Only the types a tag alone rebuilds, which is those whose constructor has no fields, and a +-- payment credit when the row references its payment - payment_ is then that payment's invoice, if +-- it had one. The rest answer Nothing rather than a type with an invented payload. The client also +-- stores each type's JSON and reads that first, so this is its fallback; the service has no such column. +-- TODO [badges] take the reference columns and rebuild charge, transferIn, upgrade and transferOut, +-- without which the service cannot re-emit a statement carrying one. +entryTypeFromColumns :: Maybe (Maybe InvoiceId) -> Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType +entryTypeFromColumns payment_ entryType credit_ debit_ = case (entryType, credit_, debit_) of + ("credit", Just "payment", _) -> SECredit . SCPayment <$> payment_ ("credit", Just t, _) -> SECredit <$> creditType t ("debit", _, Just t) -> SEDebit <$> debitType t _ -> Nothing diff --git a/src/Simplex/Chat/Badges/Service.hs b/src/Simplex/Chat/Badges/Service.hs index 725009d839..8a26a09af4 100644 --- a/src/Simplex/Chat/Badges/Service.hs +++ b/src/Simplex/Chat/Badges/Service.hs @@ -87,7 +87,7 @@ data BadgeServiceCommand code :: Text -- no badgeRequest: a code carries no tier for the client to state } | BSCPurchaseBadge - { badgeRequest :: BadgeRequest, + { masterKey :: BadgeMasterKey, -- no badgeRequest: the tier is the product's, the expiry the week's payment :: ServicePayment, upgrade :: Maybe BadgeUpgrade -- upgrade store 1-time badge } diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 9cc80fc54b..06f04434b3 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -86,6 +86,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Chat.Badges (BadgeCredential, FileSizeLimits, LocalBadge) import Simplex.Chat.Badges.Service (BadgeServiceErrorCode, StatementEntry) import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeState (..)) +import Simplex.Chat.PaymentService (ServicePayment) import Simplex.Messaging.Crypto.BBS (BBSPublicKey) import Simplex.Messaging.Crypto.File (CryptoFile (..)) import qualified Simplex.Messaging.Crypto.File as CF @@ -659,6 +660,7 @@ data ChatCommand | UpdateProfileImageFromFile FilePath -- set profile image from a .png/.jpg/.jpeg file | AddBadge BadgeCredential -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`) | APIRedeemBadgeCode {userId :: UserId, code :: Text} -- redeem a badge code with the configured badge service + | APIPurchaseBadge {userId :: UserId, payment :: ServicePayment} -- redeem an App Store or Google Play purchase for a badge | APIGetBadgeState {userId :: UserId} -- the user's badges, their balances and any current alert | APIGetBadgeLedger {userId :: UserId, badgePurchaseId :: Int64} -- the purchase's ledger, oldest first -- episode is last because it is free text: it is the value that makes one occurrence of an @@ -1481,6 +1483,7 @@ data SimplexDomainError data BadgeRedeemError = BREInvalidCode -- format or check character + | BREInvalidReceipt -- names no store transaction | BREServiceNotConfigured | BREBadgeActive | BREServiceError {serviceError :: BadgeServiceErrorCode} diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index d02a189b1d..f0e62c2273 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -26,10 +26,12 @@ import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as JM import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.Attoparsec.Combinator as A import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.URL as B64U import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB @@ -76,6 +78,7 @@ import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.Operators import Simplex.Chat.Options +import Simplex.Chat.PaymentService (ServicePayment (..)) import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol import Simplex.Chat.Remote @@ -3562,6 +3565,7 @@ processChatCommand cxt nm = \case ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile) AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user APIRedeemBadgeCode userId codeText -> withUserId userId $ \user -> redeemBadgeCode nm user codeText + APIPurchaseBadge userId payment -> withUserId userId $ \user -> purchaseBadge nm user payment APIGetBadgeState userId -> withUserId' userId $ \user -> do -- the read also signals the worker, whose results follow as CEvtBadgeChanged lift $ startBadgeWork user @@ -5227,22 +5231,8 @@ redeemBadgeCode nm user@User {userId} codeText = do -- both pass the guard and are both spent, for one badge (present_, redeemed) <- withEntityLock "badgeRedeem" (CLBadgeUser userId) $ do redemption_ <- withStore' $ \db -> getBadgeCodeRedemption db user codeSent - -- a code already redeemed here is allowed through: re-sending it returns the badge it bought - -- and adds nothing. Refused before its keys are stashed and before the request, so it stays unspent - replaying <- maybe (pure False) (\r -> withStore' $ \db -> isJust <$> getCodeBadgePurchase db r) redemption_ - unless replaying $ whenM (withStore' (`userHasBadge` user)) $ throwRedeemError BREBadgeActive - redemption@BadgeCodeRedemption {purchaseKey, purchasePrivKey, masterKey} <- - maybe (withStore' $ \db -> createBadgeCodeRedemption db g user codeSent now) pure redemption_ - let req = BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request = BSCRedeemBadgeCode {masterKey, code = codeSent}} - respBytes <- sendServiceRequestBytes nm user sendTarget Nothing (Just purchasePrivKey) req - respData <- either (const $ throwRedeemError $ BREInvalidResponse "not JSON") pure $ J.eitherDecodeStrict' respBytes - case J.fromJSON (J.Object respData) of - J.Error _ -> throwRedeemError $ BREInvalidResponse "not a badge service response" - J.Success BSPError {code = errCode} -> do - when (terminalCodeError errCode) $ withStore' $ \db -> deleteBadgeCodeRedemption db (redemptionId redemption) - throwRedeemError $ BREServiceError errCode - J.Success BSPBadgeCredential {credential = Just cred, statement} -> storeRedeemedBadge user redemption cred statement - J.Success _ -> throwRedeemError $ BREInvalidResponse "unexpected response type" + redemption@BadgeStash {masterKey} <- stashBadgeKeys user redemption_ $ \db -> createBadgeCodeRedemption db g user codeSent now + requestStashedBadge nm user sendTarget redemption BSCRedeemBadgeCode {masterKey, code = codeSent} terminalCodeError -- outside the badge lock: the chat lock must not be taken under it mapM_ presentUserBadgeToContacts present_ pure redeemed @@ -5254,6 +5244,66 @@ redeemBadgeCode nm user@User {userId} codeText = do BSECodeExpired -> True _ -> False +-- | The app presents a purchase until this returns its badge. The stash is keyed by the store's own +-- id for the transaction, so every retry reaches the service as the signer it first credited. +purchaseBadge :: NetworkRequestMode -> User -> ServicePayment -> CM ChatResponse +purchaseBadge nm user@User {userId} payment = do + txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment + sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwRedeemError BREServiceNotConfigured) pure + g <- asks random + now <- liftIO getCurrentTime + (present_, purchased) <- withEntityLock "badgePurchase" (CLBadgeUser userId) $ do + stash_ <- withStore' $ \db -> getBadgeStoreReceipt db user txRef + stash@BadgeStash {masterKey} <- stashBadgeKeys user stash_ $ \db -> createBadgeStoreReceipt db g user txRef now + requestStashedBadge nm user sendTarget stash BSCPurchaseBadge {masterKey, payment, upgrade = Nothing} terminalReceiptError + -- outside the badge lock: the chat lock must not be taken under it + mapM_ presentUserBadgeToContacts present_ + pure purchased + where + -- the receipt will never be credited to this key; any other refusal may pass on a retry + terminalReceiptError = \case + BSEReceiptInvalid -> True + BSEReceiptUsed -> True + _ -> False + +-- | Read without verifying anything: the id only keys the stash on this device, and the service +-- verifies the evidence itself. A Google token is a bearer secret, so only its hash is kept. +storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef +storeTransactionRef = \case + SPApple {jws} -> StoreTransactionRef "apple" <$> appleTransactionId jws + SPGoogle {token} -> Just $ StoreTransactionRef "google" $ safeDecodeUtf8 $ strEncode $ C.sha256Hash $ encodeUtf8 token + SPInvoice {} -> Nothing + SPReceipt {} -> Nothing + where + appleTransactionId signed = case T.splitOn "." signed of + [_, payload, _] -> do + J.Object o <- J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload) + J.String txId <- JM.lookup "transactionId" o + pure txId + _ -> Nothing + +-- | A stash that already bought a badge here passes, as re-sending it adds nothing; any other is +-- refused while a badge is held, before its keys are stashed or sent, so the funding stays unspent. +stashBadgeKeys :: User -> Maybe BadgeStash -> (DB.Connection -> IO BadgeStash) -> CM BadgeStash +stashBadgeKeys user stash_ createStash = do + replaying <- maybe (pure False) (\s -> withStore' $ \db -> isJust <$> getStashBadgePurchase db s) stash_ + unless replaying $ whenM (withStore' (`userHasBadge` user)) $ throwRedeemError BREBadgeActive + maybe (withStore' createStash) pure stash_ + +-- | A refusal for which stashDead holds drops the stash; any other, and a timeout, keep it. +requestStashedBadge :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> (BadgeServiceErrorCode -> Bool) -> CM (Maybe User, ChatResponse) +requestStashedBadge nm user sendTarget stash@BadgeStash {purchaseKey, purchasePrivKey} request stashDead = do + let req = BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} + respBytes <- sendServiceRequestBytes nm user sendTarget Nothing (Just purchasePrivKey) req + respData <- either (const $ throwRedeemError $ BREInvalidResponse "not JSON") pure $ J.eitherDecodeStrict' respBytes + case J.fromJSON (J.Object respData) of + J.Error _ -> throwRedeemError $ BREInvalidResponse "not a badge service response" + J.Success BSPError {code = errCode} -> do + when (stashDead errCode) $ withStore' (`deleteBadgeStash` stash) + throwRedeemError $ BREServiceError errCode + J.Success BSPBadgeCredential {credential = Just cred, statement} -> storeRedeemedBadge user stash cred statement + J.Success _ -> throwRedeemError $ BREInvalidResponse "unexpected response type" + throwRedeemError :: BadgeRedeemError -> CM a throwRedeemError = throwChatError . CEBadgeRedeemError @@ -5654,8 +5704,8 @@ stopBadgeWorkers workers = -- | Verify the credential before writing anything; the purchase, the statement's rows, the -- issuance and the profile's badge go in one transaction. Answers the user to tell contacts about, -- which the caller does once the badge lock is released. -storeRedeemedBadge :: User -> BadgeCodeRedemption -> BadgeCredential -> BadgeStatement -> CM (Maybe User, ChatResponse) -storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement = +storeRedeemedBadge :: User -> BadgeStash -> BadgeCredential -> BadgeStatement -> CM (Maybe User, ChatResponse) +storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement = verifyOwnBadge cred >>= \case Nothing -> throwRedeemError BREUnknownKeyIndex Just False -> throwRedeemError BRECredentialNotVerified @@ -5668,7 +5718,7 @@ storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey} let badge = OwnBadge cred (mkBadgeStatus now (Just True) info) -- TODO [badges] retire a previously held badge (user', newBadge, applied) <- withStore $ \db -> do - (purchaseId, newBadge) <- liftIO $ createCodeBadgePurchase db user redemption cred now + (purchaseId, newBadge) <- liftIO $ createStashBadgePurchase db user stash cred now applied <- liftIO $ applyBadgeStatement db g purchaseId badgeType statement (Just cred) now -- a replay must not put a superseded badge back, or tell every contact again user' <- if newBadge then setUserBadge db user (Just badge) else getUser db userId @@ -6109,6 +6159,7 @@ chatCommandP = "/_reject " *> (APIRejectContact <$> A.decimal <*> (" notify=" *> onOffP <|> pure False)), "/_service_request " *> (APISendServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (" timeout=" *> (realToFrac <$> A.double)) <*> optional (" sign_key=" *> strP) <* A.space <*> jsonP), "/_redeem_badge_code " *> (APIRedeemBadgeCode <$> A.decimal <* A.space <*> textP), + "/_badge purchase " *> (APIPurchaseBadge <$> A.decimal <* A.space <*> jsonP), "/_badge state " *> (APIGetBadgeState <$> A.decimal), "/_badge ledger " *> (APIGetBadgeLedger <$> A.decimal <* A.space <*> A.decimal), "/_badge ack " *> (APIAckBadgeAlert <$> A.decimal <* A.space <*> A.decimal <* A.space <*> badgeAlertKindP <* A.space <*> onOffP <* A.space <*> textP), diff --git a/src/Simplex/Chat/PaymentService.hs b/src/Simplex/Chat/PaymentService.hs index 38f94b2118..b8cedaa678 100644 --- a/src/Simplex/Chat/PaymentService.hs +++ b/src/Simplex/Chat/PaymentService.hs @@ -27,7 +27,7 @@ data ServiceInvoice = ServiceInvoice data ServicePayment = SPApple {jws :: Text} - | SPGoogle {token :: Text} + | SPGoogle {productId :: Text, token :: Text} -- the Publisher API finds a purchase by product and token | SPInvoice {invoiceId :: InvoiceId} | SPReceipt {receipt :: Text} -- transfer of unissued months deriving (Show) diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 19d6d2efef..e967f6fdc2 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -7,7 +7,9 @@ {-# LANGUAGE TypeOperators #-} module Simplex.Chat.Store.Badges - ( BadgeCodeRedemption (..), + ( BadgeStash (..), + BadgeStashRef (..), + StoreTransactionRef (..), UserBadgePurchase (..), getUserBadgePurchase, getBadgePurchase, @@ -18,9 +20,11 @@ module Simplex.Chat.Store.Badges clearShownBadge, getBadgeCodeRedemption, createBadgeCodeRedemption, - deleteBadgeCodeRedemption, - createCodeBadgePurchase, - getCodeBadgePurchase, + getBadgeStoreReceipt, + createBadgeStoreReceipt, + deleteBadgeStash, + createStashBadgePurchase, + getStashBadgePurchase, storeBadgeIssuance, getLatestIssuedCredential, storeBadgeStatement, @@ -33,6 +37,7 @@ where import Control.Concurrent.STM (TVar, atomically) import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) import Data.Maybe (isJust, mapMaybe) @@ -58,18 +63,26 @@ import Database.SQLite.Simple (Only (..), (:.) (..)) import Database.SQLite.Simple.QQ (sql) #endif --- | The keys one redemption attempt is signed with, stashed before the request is sent so that a --- retry reaches the service as the same signer and is answered with the credential already issued. -data BadgeCodeRedemption = BadgeCodeRedemption - { redemptionId :: Int64, +-- | The keys one attempt to fund a badge is signed with, stashed before the request is sent so that +-- a retry reaches the service as the same signer and is answered with the credential already issued. +data BadgeStash = BadgeStash + { stashRef :: BadgeStashRef, purchaseKey :: C.PublicKeyEd25519, purchasePrivKey :: C.PrivateKeyEd25519, masterKey :: BadgeMasterKey } -getBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO (Maybe BadgeCodeRedemption) +-- | The row a stash is kept in, which a purchase bought with it references. +data BadgeStashRef = BSRCodeRedemption Int64 | BSRStoreReceipt Int64 + +-- | A store and its own id for one transaction. The evidence is not the key: the store may sign it +-- again, and a retry of the same purchase has to find the same stash. +data StoreTransactionRef = StoreTransactionRef {provider :: Text, transactionRef :: Text} + deriving (Eq, Show) + +getBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO (Maybe BadgeStash) getBadgeCodeRedemption db User {userId} code = - maybeFirstRow toRedemption $ + maybeFirstRow (toBadgeStash BSRCodeRedemption) $ DB.query db [sql| @@ -78,11 +91,8 @@ getBadgeCodeRedemption db User {userId} code = WHERE user_id = ? AND code = ? |] (userId, code) - where - toRedemption (redemptionId, purchaseKey, purchasePrivKey, Binary mk) = - BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} -createBadgeCodeRedemption :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO BadgeCodeRedemption +createBadgeCodeRedemption :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO BadgeStash createBadgeCodeRedemption db g User {userId} code now = do (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g masterKey@(BadgeMasterKey mk) <- generateMasterKey g @@ -94,42 +104,86 @@ createBadgeCodeRedemption db g User {userId} code now = do |] (userId, code, purchaseKey, purchasePrivKey, Binary mk, now) redemptionId <- insertedRowId db - pure BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey} + pure BadgeStash {stashRef = BSRCodeRedemption redemptionId, purchaseKey, purchasePrivKey, masterKey} --- | Drop a stashed attempt whose code the service refused for good, unless a purchase already --- came from it - badge_purchases references this row. -deleteBadgeCodeRedemption :: DB.Connection -> Int64 -> IO () -deleteBadgeCodeRedemption db redemptionId = +getBadgeStoreReceipt :: DB.Connection -> User -> StoreTransactionRef -> IO (Maybe BadgeStash) +getBadgeStoreReceipt db User {userId} StoreTransactionRef {provider, transactionRef} = + maybeFirstRow (toBadgeStash BSRStoreReceipt) $ + DB.query + db + [sql| + SELECT badge_store_receipt_id, purchase_key, purchase_priv_key, master_key + FROM badge_store_receipts + WHERE user_id = ? AND provider = ? AND transaction_ref = ? + |] + (userId, provider, transactionRef) + +createBadgeStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> StoreTransactionRef -> UTCTime -> IO BadgeStash +createBadgeStoreReceipt db g User {userId} StoreTransactionRef {provider, transactionRef} now = do + (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g + masterKey@(BadgeMasterKey mk) <- generateMasterKey g 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 = ?) + INSERT INTO badge_store_receipts (user_id, provider, transaction_ref, purchase_key, purchase_priv_key, master_key, created_at) + VALUES (?,?,?,?,?,?,?) |] - (redemptionId, redemptionId) + (userId, provider, transactionRef, purchaseKey, purchasePrivKey, Binary mk, now) + storeReceiptId <- insertedRowId db + pure BadgeStash {stashRef = BSRStoreReceipt storeReceiptId, purchaseKey, purchasePrivKey, masterKey} --- | 'False' when the code was already redeemed here: the service replays the credential it +toBadgeStash :: (Int64 -> BadgeStashRef) -> (Int64, C.PublicKeyEd25519, C.PrivateKeyEd25519, Binary ByteString) -> BadgeStash +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) + +-- | '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. -createCodeBadgePurchase :: DB.Connection -> User -> BadgeCodeRedemption -> BadgeCredential -> UTCTime -> IO (Int64, Bool) -createCodeBadgePurchase db User {userId} redemption credential now = - getCodeBadgePurchase db redemption >>= \case +createStashBadgePurchase :: DB.Connection -> User -> BadgeStash -> BadgeCredential -> UTCTime -> IO (Int64, Bool) +createStashBadgePurchase db User {userId} stash credential now = + getStashBadgePurchase db stash >>= \case Just purchaseId -> pure (purchaseId, False) Nothing -> do DB.execute db [sql| INSERT INTO badge_purchases - (user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status, badge_code_redemption_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?,?,?) + (user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status, + badge_code_redemption_id, badge_store_receipt_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?) |] - (userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType, PSIssued, redemptionId, now, now) + ((userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType) :. (PSIssued, redemptionId_, storeReceiptId_, now, now)) purchaseId <- insertedRowId db DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (purchaseId, userId) pure (purchaseId, True) where - BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = redemption + BadgeStash {stashRef, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = stash BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = credential + (redemptionId_, storeReceiptId_) = case stashRef of + BSRCodeRedemption redemptionId -> (Just redemptionId, Nothing) + BSRStoreReceipt storeReceiptId -> (Nothing, Just storeReceiptId) -- | The period comes from the ledger, the expiry from the credential, which runs a week longer. -- 'False' means no issuance row was written, which the caller reports rather than drop in silence. @@ -194,10 +248,13 @@ getIssuedPeriod db badgePurchaseId entryId = do [(Just periodStart, periodEnd)] -> Just (periodStart, periodEnd) _ -> Nothing -getCodeBadgePurchase :: DB.Connection -> BadgeCodeRedemption -> IO (Maybe Int64) -getCodeBadgePurchase db BadgeCodeRedemption {redemptionId} = - maybeFirstRow fromOnly $ - DB.query db "SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption_id = ?" (Only redemptionId) +getStashBadgePurchase :: DB.Connection -> BadgeStash -> IO (Maybe Int64) +getStashBadgePurchase db BadgeStash {stashRef} = + maybeFirstRow fromOnly $ case stashRef of + BSRCodeRedemption redemptionId -> + DB.query db "SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption_id = ?" (Only redemptionId) + BSRStoreReceipt storeReceiptId -> + DB.query db "SELECT badge_purchase_id FROM badge_purchases WHERE badge_store_receipt_id = ?" (Only storeReceiptId) data UserBadgePurchase = UserBadgePurchase { badgePurchaseId :: Int64, @@ -370,7 +427,7 @@ getBadgeLedger db User {userId} badgePurchaseId = toStatementEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType) :. (Maybe UTCTime, UTCTime, Text, Maybe Text, Maybe Text, Maybe Text) -> Maybe StatementEntry toStatementEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType) :. (wasPausedSince, createdAt, entryType_, credit_, debit_, value_)) = (\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType}) - <$> maybe (entryTypeFromColumns entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_ + <$> maybe (entryTypeFromColumns Nothing entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_ -- | Decodes the stored JSON rather than rebuilding from the tag, so a version that has since -- learnt the type reads it with its fields, and one that has not still gets it back verbatim. diff --git a/src/Simplex/Chat/Store/Postgres/Migrations.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index 24ed45c9a9..dd5e812595 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -53,6 +53,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260904_file_badges import Simplex.Chat.Store.Postgres.Migrations.M20260915_user_badges import Simplex.Chat.Store.Postgres.Migrations.M20260918_badge_issue_errors import Simplex.Chat.Store.Postgres.Migrations.M20260923_preferences_json +import Simplex.Chat.Store.Postgres.Migrations.M20260925_badge_store_receipts import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -105,7 +106,8 @@ schemaMigrations = ("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges), ("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges), ("20260918_badge_issue_errors", m20260918_badge_issue_errors, Just down_m20260918_badge_issue_errors), - ("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json) + ("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json), + ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs index 98bdd53db7..78e8e6ed46 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs @@ -165,10 +165,6 @@ CREATE TABLE @subscription_charges( UNIQUE(payment_id, provider_charge_ref) ); -ALTER TABLE @badge_purchases ADD COLUMN payment_id TEXT REFERENCES @payments; - -CREATE UNIQUE INDEX @idx_badge_purchases_payment ON @badge_purchases(payment_id); - CREATE TABLE @badge_invoices( invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE, badge_purchase_id BIGINT NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE, @@ -200,16 +196,12 @@ CREATE TABLE @badge_subscription_changes( CREATE INDEX @idx_badge_subscription_changes_purchase ON @badge_subscription_changes(badge_purchase_id); -ALTER TABLE @badge_ledger ADD COLUMN payment_id TEXT REFERENCES @payments; - ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges; ALTER TABLE @badge_ledger ADD COLUMN from_purchase_id BIGINT REFERENCES @badge_purchases; ALTER TABLE @badge_ledger ADD COLUMN to_purchase_id BIGINT REFERENCES @badge_purchases; -CREATE INDEX @idx_badge_ledger_payment ON @badge_ledger(payment_id); - CREATE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id); CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id); @@ -217,11 +209,9 @@ CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id); CREATE INDEX @idx_badge_ledger_to_purchase ON @badge_ledger(to_purchase_id); -- down -DROP INDEX @idx_badge_ledger_payment; DROP INDEX @idx_badge_ledger_charge; DROP INDEX @idx_badge_ledger_from_purchase; DROP INDEX @idx_badge_ledger_to_purchase; -ALTER TABLE @badge_ledger DROP COLUMN payment_id; ALTER TABLE @badge_ledger DROP COLUMN charge_id; ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id; ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id; @@ -231,8 +221,6 @@ DROP INDEX @idx_badge_invoices_purchase; DROP INDEX @idx_badge_invoices_offer; DROP INDEX @idx_badge_invoices_price; DROP TABLE @badge_invoices; -DROP INDEX @idx_badge_purchases_payment; -ALTER TABLE @badge_purchases DROP COLUMN payment_id; DROP TABLE @subscription_charges; -} diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs new file mode 100644 index 0000000000..c4b0dc4981 --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.Postgres.Migrations.M20260925_badge_store_receipts where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20260925_badge_store_receipts :: Text +m20260925_badge_store_receipts = + [r| +CREATE TABLE badge_store_receipts( + badge_store_receipt_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY, + user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE, + provider TEXT NOT NULL, + transaction_ref TEXT NOT NULL, + purchase_key BYTEA NOT NULL, + purchase_priv_key BYTEA NOT NULL, + master_key BYTEA NOT NULL, + created_at TIMESTAMPTZ NOT NULL, + UNIQUE(user_id, provider, transaction_ref) +); + +CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id); + +ALTER TABLE badge_purchases ADD COLUMN badge_store_receipt_id BIGINT REFERENCES badge_store_receipts; + +CREATE UNIQUE INDEX idx_badge_purchases_store_receipt ON badge_purchases(badge_store_receipt_id); +|] + +down_m20260925_badge_store_receipts :: Text +down_m20260925_badge_store_receipts = + [r| +DROP INDEX idx_badge_purchases_store_receipt; + +ALTER TABLE badge_purchases DROP COLUMN badge_store_receipt_id; + +DROP INDEX idx_badge_store_receipts_user; + +DROP TABLE badge_store_receipts; +|] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index 4dcefa1598..a5cb6b012d 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -176,6 +176,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260904_file_badges import Simplex.Chat.Store.SQLite.Migrations.M20260915_user_badges import Simplex.Chat.Store.SQLite.Migrations.M20260918_badge_issue_errors import Simplex.Chat.Store.SQLite.Migrations.M20260923_preferences_json +import Simplex.Chat.Store.SQLite.Migrations.M20260925_badge_store_receipts import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -351,7 +352,8 @@ schemaMigrations = ("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges), ("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges), ("20260918_badge_issue_errors", m20260918_badge_issue_errors, Just down_m20260918_badge_issue_errors), - ("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json) + ("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json), + ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs index 3462db9bc1..5ea14f98b9 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs @@ -166,10 +166,6 @@ CREATE TABLE @subscription_charges( UNIQUE(payment_id, provider_charge_ref) ) STRICT; -ALTER TABLE @badge_purchases ADD COLUMN payment_id TEXT REFERENCES @payments; - -CREATE UNIQUE INDEX @idx_badge_purchases_payment ON @badge_purchases(payment_id); - CREATE TABLE @badge_invoices( invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE, badge_purchase_id INTEGER NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE, @@ -201,16 +197,12 @@ CREATE TABLE @badge_subscription_changes( CREATE INDEX @idx_badge_subscription_changes_purchase ON @badge_subscription_changes(badge_purchase_id); -ALTER TABLE @badge_ledger ADD COLUMN payment_id TEXT REFERENCES @payments; - ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges; ALTER TABLE @badge_ledger ADD COLUMN from_purchase_id INTEGER REFERENCES @badge_purchases; ALTER TABLE @badge_ledger ADD COLUMN to_purchase_id INTEGER REFERENCES @badge_purchases; -CREATE INDEX @idx_badge_ledger_payment ON @badge_ledger(payment_id); - CREATE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id); CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id); @@ -218,11 +210,9 @@ CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id); CREATE INDEX @idx_badge_ledger_to_purchase ON @badge_ledger(to_purchase_id); -- down -DROP INDEX @idx_badge_ledger_payment; DROP INDEX @idx_badge_ledger_charge; DROP INDEX @idx_badge_ledger_from_purchase; DROP INDEX @idx_badge_ledger_to_purchase; -ALTER TABLE @badge_ledger DROP COLUMN payment_id; ALTER TABLE @badge_ledger DROP COLUMN charge_id; ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id; ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id; @@ -232,8 +222,6 @@ DROP INDEX @idx_badge_invoices_purchase; DROP INDEX @idx_badge_invoices_offer; DROP INDEX @idx_badge_invoices_price; DROP TABLE @badge_invoices; -DROP INDEX @idx_badge_purchases_payment; -ALTER TABLE @badge_purchases DROP COLUMN payment_id; DROP TABLE @subscription_charges; -} diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs new file mode 100644 index 0000000000..1da7255f23 --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.SQLite.Migrations.M20260925_badge_store_receipts where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20260925_badge_store_receipts :: Query +m20260925_badge_store_receipts = + [sql| +CREATE TABLE badge_store_receipts( + badge_store_receipt_id INTEGER PRIMARY KEY AUTOINCREMENT, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + provider TEXT NOT NULL, + transaction_ref TEXT NOT NULL, + purchase_key BLOB NOT NULL, + purchase_priv_key BLOB NOT NULL, + master_key BLOB NOT NULL, + created_at TEXT NOT NULL, + UNIQUE(user_id, provider, transaction_ref) +) STRICT; + +CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id); + +ALTER TABLE badge_purchases ADD COLUMN badge_store_receipt_id INTEGER REFERENCES badge_store_receipts; + +CREATE UNIQUE INDEX idx_badge_purchases_store_receipt ON badge_purchases(badge_store_receipt_id); +|] + +down_m20260925_badge_store_receipts :: Query +down_m20260925_badge_store_receipts = + [sql| +DROP INDEX idx_badge_purchases_store_receipt; + +ALTER TABLE badge_purchases DROP COLUMN badge_store_receipt_id; + +DROP INDEX idx_badge_store_receipts_user; + +DROP TABLE badge_store_receipts; +|] diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 1c62bc267b..81cde864e1 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -2867,6 +2867,7 @@ viewChatError isCmd logLevel testView = \case CEBadgeRedeemError e -> let reason = case e of BREInvalidCode -> "invalid code" + BREInvalidReceipt -> "invalid store receipt" BREServiceNotConfigured -> "badge service not configured" BREBadgeActive -> "badge already active" BREServiceError code -> "badge service error: " <> T.unpack (badgeServiceErrorText code) diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index bd8f62d3fd..bf14e5d86c 100644 --- a/tests/BadgeTests.hs +++ b/tests/BadgeTests.hs @@ -12,9 +12,11 @@ module BadgeTests (badgeTests) where import BadgeService.Service (badgeErrorRetryAfter) import Control.Concurrent.STM (atomically) import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Base64.URL as B64U import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Data.Time.Calendar (fromGregorian) import Data.Time.Calendar.WeekDate (toWeekDate) import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay) @@ -30,13 +32,16 @@ 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.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval) +import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, storeTransactionRef) +import Simplex.Chat.PaymentService (ServicePayment (..)) +import Simplex.Chat.PaymentService.Types (InvoiceId (..)) +import Simplex.Chat.Store.Badges (StoreTransactionRef (..)) import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), AgentServiceError (..), SMPAgentError (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay) import Simplex.Messaging.Crypto.BBS import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BrokerErrorType (..), ErrorType (AUTH), NetworkError (..)) -import Simplex.Messaging.Util (tshow) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) import Simplex.Messaging.Version.Internal (Version (..)) import Test.Hspec @@ -92,9 +97,12 @@ badgeTests = do it "bounds and strips a code this version does not know" testServiceErrorCodeBounded describe "service protocol JSON" $ do it "redeemBadgeCode request matches the schema" testRedeemRequestJSON + it "purchaseBadge request matches the schema" testPurchaseRequestJSON it "badgeCredential response matches the schema" testCredentialResponseJSON it "error response matches the schema" testErrorResponseJSON it "statement entries round-trip, unknown entry types verbatim" testStatementJSON + describe "store purchases" $ do + it "keys a purchase by the store's transaction id, not by the evidence signed over it" testStoreTransactionRef proofOf :: BadgeProof -> BBSProof proofOf (BadgeProof _ _ p _) = p @@ -753,12 +761,18 @@ testEntryTypeColumns = do debits = [SDRefund, SDUpgrade k, SDTransferOut k, SDSupport, SDBadge, SDLapse] mapM_ (\c -> wireTag (J.toJSON (SECredit c)) "credit" `shouldBe` Just (creditTypeTag c)) credits mapM_ (\d -> wireTag (J.toJSON (SEDebit d)) "debit" `shouldBe` Just (debitTypeTag d)) debits - -- the three types this version writes survive a round trip through the columns + -- the types this version writes survive a round trip through the columns, a payment credit + -- through the payment its row references mapM_ - (\t -> uncurry3 entryTypeFromColumns (entryTypeColumns t) `shouldSatisfy` sameEntryType t) + (\t -> uncurry3 (entryTypeFromColumns Nothing) (entryTypeColumns t) `shouldSatisfy` sameEntryType t) [SECredit SCCode, SEDebit SDBadge, SEDebit SDLapse] + let storeCredit = SECredit (SCPayment Nothing) + invoiceCredit = SECredit (SCPayment (Just (InvoiceId "inv1"))) + uncurry3 (entryTypeFromColumns (Just Nothing)) (entryTypeColumns storeCredit) `shouldSatisfy` sameEntryType storeCredit + uncurry3 (entryTypeFromColumns (Just (Just (InvoiceId "inv1")))) (entryTypeColumns invoiceCredit) `shouldSatisfy` sameEntryType invoiceCredit -- a type that needs a reference column is not silently read back as something else - uncurry3 entryTypeFromColumns (entryTypeColumns (SECredit (SCCharge "ch1"))) `shouldSatisfy` isNothing + uncurry3 (entryTypeFromColumns Nothing) (entryTypeColumns storeCredit) `shouldSatisfy` isNothing + uncurry3 (entryTypeFromColumns Nothing) (entryTypeColumns (SECredit (SCCharge "ch1"))) `shouldSatisfy` isNothing -- which is why every type is stored as its own JSON as well, and read from that first: the -- columns alone would answer a row naming an invoice or a purchase as no row at all mapM_ roundTrips credits @@ -790,6 +804,45 @@ testRedeemRequestJSON = do `shouldBe` J.object ["version" J..= (1 :: Int), "request" J..= J.object ["type" J..= ("getBadgeCatalog" :: T.Text)]] roundTrips req +testPurchaseRequestJSON :: IO () +testPurchaseRequestJSON = do + drg <- C.newRandom + mk <- generateMasterKey drg + (k, _) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519) + let payment = SPGoogle {productId = "badge_supporter_01", token = "token"} + req = BadgeServiceRequest {version = Version 1, purchaseKey = Just k, request = BSCPurchaseBadge {masterKey = mk, payment, upgrade = Nothing}} + -- the client states its master key and the store's evidence, and nothing a receipt already decides + J.toJSON req + `shouldBe` J.object + [ "version" J..= (1 :: Int), + "purchaseKey" J..= k, + "request" + J..= J.object + [ "type" J..= ("purchaseBadge" :: T.Text), + "masterKey" J..= mk, + "payment" J..= J.object ["type" J..= ("google" :: T.Text), "productId" J..= ("badge_supporter_01" :: T.Text), "token" J..= ("token" :: T.Text)] + ] + ] + J.toJSON SPApple {jws = "a.b.c"} `shouldBe` J.object ["type" J..= ("apple" :: T.Text), "jws" J..= ("a.b.c" :: T.Text)] + roundTrips req + +testStoreTransactionRef :: IO () +testStoreTransactionRef = do + let jws transactionId signature = T.intercalate "." [part "{\"alg\":\"ES256\"}", part ("{\"transactionId\":\"" <> transactionId <> "\",\"productId\":\"BADGE_SUPPORTER_01\"}"), signature] + part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8 + apple = storeTransactionRef . SPApple + -- the store may sign the same transaction again, and a retry must find the keys it stashed + apple (jws "2000000812345671" "c2lnbmVkIG9uY2U") `shouldBe` Just (StoreTransactionRef "apple" "2000000812345671") + apple (jws "2000000812345671" "c2lnbmVkIGFnYWlu") `shouldBe` apple (jws "2000000812345671" "c2lnbmVkIG9uY2U") + apple (jws "2000000812345672" "c2lnbmVkIG9uY2U") `shouldNotBe` apple (jws "2000000812345671" "c2lnbmVkIG9uY2U") + apple "not.a-jws" `shouldBe` Nothing + apple (T.intercalate "." [part "{}", part "{\"productId\":\"BADGE_SUPPORTER_01\"}", "sig"]) `shouldBe` Nothing + -- a Play token is a bearer secret, so it is kept only as its hash + let google = storeTransactionRef SPGoogle {productId = "badge_supporter_01", token = "play-token"} + google `shouldSatisfy` maybe False (\(StoreTransactionRef provider ref) -> provider == "google" && ref /= "play-token") + google `shouldBe` storeTransactionRef SPGoogle {productId = "badge_supporter_01", token = "play-token"} + storeTransactionRef SPInvoice {invoiceId = InvoiceId "inv"} `shouldBe` Nothing + testCredentialResponseJSON :: IO () testCredentialResponseJSON = do Right (_, sk) <- bbsKeyGen diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index c11af7f4d1..76095ed8cd 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -12,6 +12,7 @@ module Bots.BadgeService.BotTests where import BadgeService.Config (BadgeIssuerKey (..), readServiceConfig) import Bots.BadgeService.ConfigTests (withIssuer) +import Bots.BadgeService.FakeStore import BadgeService.Options import BadgeService.Service import BadgeService.Store.Invoices (markCodePaid) @@ -27,6 +28,7 @@ import Control.Exception (finally) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (toLower) import Data.Either (isLeft, isRight) import Data.Int (Int64) @@ -39,15 +41,18 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDay) import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Word (Word32) import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType (..), generateMasterKey) import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, badgeCodeText, formatBadgeCode, parseBadgeCode, randomBadgeCode) -import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, endOfMondayAfter) +import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, emptyEntry, endOfMondayAfter) import Simplex.Chat.Badges.Service import Simplex.Chat.Bot.Store (withDB') import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (CRCustomChatResponse)) import Simplex.Chat.Core (sendChatCmdStr) import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB +import Simplex.Chat.PaymentService (ServicePayment (..)) +import Simplex.Chat.PaymentService.Types (InvoiceId (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) import Simplex.Messaging.Agent.Store.Common (withTransaction) @@ -106,6 +111,23 @@ badgeServiceTests = do it "should renew a badge on a profile that is not active, without switching to it" testRenewalKeepsActiveProfile it "should broadcast the current profile when a renewal presents a badge" testRenewalKeepsProfileEdits it "should present the month already issued when a previous pass did not" testPresentationCatchesUp + describe "store purchases" $ do + it "should credit the months a store receipt paid for and issue the first" testStorePurchase + it "should return the same credential for a receipt its key presents again, writing nothing" testStorePurchaseReplay + it "should refuse a receipt another key was credited with" testStoreReceiptUsed + it "should refuse a receipt the store does not vouch for, with no retry" testStoreReceiptInvalid + it "should answer a store it cannot reach as retryable, writing nothing" testStoreUnreachable + it "should write nothing for a pending purchase, and credit it once when it settles" testStorePending + it "should refuse a product that grants no badge" testStoreUnknownProduct + it "should refuse a store purchase that carries an upgrade" testStoreUpgradeRefused + it "should grant the badge of the product the receipt proves" testStoreBadgeTypeFromProduct + it "should keep refusing invoice and receipt funding" testNonStoreFundingRefused + 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 + it "should drop the keys of a receipt refused for good, and keep them while it is pending" testPurchaseStash + it "should refuse a store purchase while a badge is held, before anything is sent" testPurchaseWhileBadgeHeld + it "should tell a second profile presenting the same receipt that it is used" testPurchaseSameReceiptOtherProfile badgeProfile :: Profile badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} @@ -157,7 +179,8 @@ data BadgeServiceEnv = BadgeServiceEnv bsClock :: TestClock, bsClientCfg :: ChatConfig, bsAddress :: String, - bsController :: ChatController + bsController :: ChatController, + bsStore :: FakeStore } -- | Stop the service for good: requests sent after it go unanswered until they time out. Stopping @@ -173,10 +196,11 @@ withBadgeServiceEnv :: HasCallStack => TestParams -> (BadgeServiceEnv -> IO ()) withBadgeServiceEnv ps 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} withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure () - runBadgeService svcCfg opts $ \_ -> pure () + runBadgeService store svcCfg opts $ \_ -> pure () bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do bs <## "subscribed 1 connections on server localhost" bs ##> "/sa" @@ -185,9 +209,9 @@ withBadgeServiceEnv ps test = do pure sLink let clientCfg = svcCfg {badgeServiceAddress = Just $ either (error . ("bad badge service address: " <>)) id $ strDecode (B.pack bsLink)} - runBadgeService svcCfg opts $ \env -> do + runBadgeService store 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} + test BadgeServiceEnv {bsIssuerKey = BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey = sk}, bsClock = clock, bsClientCfg = clientCfg, bsAddress = bsLink, bsController = cc, bsStore = store} issueCode :: HasCallStack => ChatController -> BadgeType -> Int -> IO BadgeCode issueCode cc badgeType months = issueCodeAs cc badgeType months "free" @@ -208,9 +232,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 :: ChatConfig -> BadgeServiceOpts -> (ServiceState -> IO ()) -> IO () -runBadgeService cfg opts action = do - env <- newServiceState +runBadgeService :: FakeStore -> ChatConfig -> BadgeServiceOpts -> (ServiceState -> IO ()) -> IO () +runBadgeService FakeStore {fakeVerifier} cfg opts action = do + env <- (\s -> s {storeVerifier = fakeVerifier}) <$> 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" @@ -359,8 +383,8 @@ testRedeemSameCodeOtherProfile ps = showActiveUser alice "alice (Alice, * supporter)" serviceCmd :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse -serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} purchaseKey request = - badgeServiceResponse bsIssuerKey bsController (Just purchaseKey) reqObject +serviceCmd BadgeServiceEnv {bsIssuerKey, bsController, bsStore = FakeStore {fakeVerifier}} purchaseKey request = + badgeServiceResponse bsIssuerKey fakeVerifier bsController (Just purchaseKey) reqObject where reqObject = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of J.Object o -> o @@ -1341,3 +1365,256 @@ testRevokedCode ps = alice <## "cannot redeem badge code: badge service error: code_invalid" second <- revokeCodeAs cc paid second `shouldSatisfy` T.isInfixOf "revoked already" + +purchaseCmd :: BadgeMasterKey -> ServicePayment -> BadgeServiceCommand +purchaseCmd masterKey payment = BSCPurchaseBadge {masterKey, payment, upgrade = Nothing} + +supporterPlay :: ServicePayment +supporterPlay = googlePayment "badge_supporter_01" googleSupporterToken + +paymentArg :: ServicePayment -> String +paymentArg = LB.unpack . J.encode + +refusalOf :: HasCallStack => BadgeServiceResponse -> (BadgeServiceErrorCode, Maybe Word32) +refusalOf = \case + BSPError {code, retryAfter} -> (code, retryAfter) + r -> error $ "expected an error, got " <> show (J.toJSON r) + +badgeTypeOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeType +badgeTypeOf r = (\(BadgeCredential _ _ _ BadgeInfo {badgeType}) -> badgeType) <$> credentialOf r + +rowCount :: ChatController -> String -> IO Int +rowCount ChatController {chatStore} table = + withTransaction chatStore $ \db -> do + [Only n] <- DB.query_ db $ fromString $ "SELECT COUNT(*) FROM " <> table + pure n + +-- | Each store payment's provider, amount and currency, and the ledger rows that name it. +storePayments :: ChatController -> IO [(Text, Maybe Int, Maybe Text, Int)] +storePayments ChatController {chatStore} = + withTransaction chatStore $ \db -> + DB.query_ db . fromString $ + "SELECT pay.provider, pay.amount, pay.currency, COUNT(l.entry_id) FROM sx_badge_service_payments pay " + <> "LEFT JOIN sx_badge_service_badge_ledger l ON l.payment_id = pay.payment_id " + <> "GROUP BY pay.payment_id, pay.provider, pay.amount, pay.currency ORDER BY pay.provider" + +nothingPurchased :: HasCallStack => ChatController -> IO () +nothingPurchased cc = do + rowCount cc "sx_badge_service_payments" `shouldReturn` 0 + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 0 + +testStorePurchase :: HasCallStack => TestParams -> IO () +testStorePurchase ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey supporterPlay + let (entries, previousEntryId) = statementOf purchased + previousEntryId `shouldBe` Nothing + map entryTag entries `shouldBe` ["payment", "badge"] + map (\e -> let (c, m, _) = entryOf e in (c, m)) entries `shouldBe` [(1, 1), (-1, 0)] + badgeTypeOf purchased `shouldBe` Just BTSupporter + masterKeyOf purchased `shouldBe` Just masterKey + map (\(_, c, m, _, _, t) -> (c, m, t)) <$> ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` [(1, 1, Just "payment"), (-1, 0, Just "badge")] + -- Play reports no price, and only the credit names the payment + storePayments cc `shouldReturn` [("google", Nothing, Nothing, 1)] + +testStorePurchaseReplay :: HasCallStack => TestParams -> IO () +testStorePurchaseReplay ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey supporterPlay + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + replayed <- serviceCmd env purchaseKey $ purchaseCmd masterKey supporterPlay + credentialOf replayed `shouldBe` credentialOf purchased + map entryTag (fst $ statementOf replayed) `shouldBe` map entryTag (fst $ statementOf purchased) + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger + storePayments cc `shouldReturn` [("google", Nothing, Nothing, 1)] + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + +testStoreReceiptUsed :: HasCallStack => TestParams -> IO () +testStoreReceiptUsed ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + (firstKey, firstMasterKey) <- newPurchaseKeys + _ <- serviceCmd env firstKey $ purchaseCmd firstMasterKey supporterPlay + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + (otherKey, otherMasterKey) <- newPurchaseKeys + used <- serviceCmd env otherKey $ purchaseCmd otherMasterKey supporterPlay + refusalOf used `shouldBe` (BSEReceiptUsed, Nothing) + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + +testStoreReceiptInvalid :: HasCallStack => TestParams -> IO () +testStoreReceiptInvalid ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = FakeStore {appleSupporterJWS}} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + let refused payment = refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey payment) + refused (googlePayment "badge_supporter_01" "not-a-purchase") `shouldReturn` (BSEReceiptInvalid, Nothing) + -- a real token presented for another product is not a purchase of it + refused (googlePayment "badge_legend_01" googleSupporterToken) `shouldReturn` (BSEReceiptInvalid, Nothing) + refused SPApple {jws = "not.a.jws"} `shouldReturn` (BSEReceiptInvalid, Nothing) + -- the payload of a real transaction under a signature that is not the store's + let resigned = case T.splitOn "." appleSupporterJWS of + [header, payload, _] -> T.intercalate "." [header, payload, "c2lnbmVkIGVsc2V3aGVyZQ"] + _ -> error "fixture is not a JWS" + refused SPApple {jws = resigned} `shouldReturn` (BSEReceiptInvalid, Nothing) + nothingPurchased cc + +testStoreUnreachable :: HasCallStack => TestParams -> IO () +testStoreUnreachable ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + unreachable <- serviceCmd env purchaseKey $ purchaseCmd masterKey $ googlePayment "badge_supporter_01" googleUnreachableToken + refusalOf unreachable `shouldSatisfy` \(code, retryAfter) -> code == BSEProviderUnavailable && isJust retryAfter + nothingPurchased cc + +testStorePending :: HasCallStack => TestParams -> IO () +testStorePending ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + let unsettled = purchaseCmd masterKey $ googlePayment "badge_supporter_01" googlePendingToken + waiting <- serviceCmd env purchaseKey unsettled + refusalOf waiting `shouldSatisfy` \(code, retryAfter) -> code == BSEPaymentPending && isJust retryAfter + nothingPurchased cc + settlePending store + settled <- serviceCmd env purchaseKey unsettled + badgeTypeOf settled `shouldBe` Just BTSupporter + again <- serviceCmd env purchaseKey unsettled + credentialOf again `shouldBe` credentialOf settled + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + storePayments cc `shouldReturn` [("google", Nothing, Nothing, 1)] + +testStoreUnknownProduct :: HasCallStack => TestParams -> IO () +testStoreUnknownProduct ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + -- a real purchase of a subscription, whose renewals nothing adds to a badge yet + subscription <- serviceCmd env purchaseKey $ purchaseCmd masterKey $ googlePayment "subscr_badge_supporter_01" googleSubscriptionToken + refusalOf subscription `shouldBe` (BSEProductUnavailable, Nothing) + nothingPurchased cc + +testStoreUpgradeRefused :: HasCallStack => TestParams -> IO () +testStoreUpgradeRefused ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + g <- C.newRandom + (fromPurchaseKey, fromPriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519) + now <- getCurrentTime + let upgrade = BadgeUpgrade {fromPurchaseKey, receipt = "receipt", receiptSignature = C.sign' fromPriv "receipt", balance = BadgeBalance {lastEntry = emptyEntry now BTSupporter}} + upgraded <- serviceCmd env purchaseKey BSCPurchaseBadge {masterKey, payment = supporterPlay, upgrade = Just upgrade} + refusalOf upgraded `shouldBe` (BSEUnsupportedVersion, Nothing) + nothingPurchased cc + +testStoreBadgeTypeFromProduct :: HasCallStack => TestParams -> IO () +testStoreBadgeTypeFromProduct ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = FakeStore {appleLegendJWS}} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + legend <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPApple {jws = appleLegendJWS} + badgeTypeOf legend `shouldBe` Just BTLegend + map (\StatementEntry {balanceBadgeType} -> balanceBadgeType) (fst $ statementOf legend) `shouldBe` [BTLegend, BTLegend] + storePayments cc `shouldReturn` [("apple", Just 7000, Just "USD", 1)] + +testNonStoreFundingRefused :: HasCallStack => TestParams -> IO () +testNonStoreFundingRefused ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + invoice <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPInvoice {invoiceId = InvoiceId "inv"} + refusalOf invoice `shouldBe` (BSEUnknownPurchaseKey, Nothing) + transfer <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPReceipt {receipt = "receipt"} + refusalOf transfer `shouldBe` (BSEUnknownPurchaseKey, Nothing) + nothingPurchased cc + +testStorePurchaseKeyMismatch :: HasCallStack => TestParams -> IO () +testStorePurchaseKeyMismatch ps = + withBadgeService ps $ \clientCfg bsLink cc -> + withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do + g <- C.newRandom + (_, signPriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519) + (claimedPub, _) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519) + let signKey = B.unpack $ strEncode (C.StoredPrivateKey signPriv) + claimed = B.unpack $ strEncode claimedPub + req = + "{\"version\":1,\"purchaseKey\":\"" <> claimed + <> "\",\"request\":{\"type\":\"purchaseBadge\",\"masterKey\":\"" <> testMasterKeyB64 + <> "\",\"payment\":" <> paymentArg supporterPlay <> "}}" + alice ##> ("/_service_request 1 " <> bsLink <> " sign_key=" <> signKey <> " " <> req) + alice <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}" + nothingPurchased cc + +testPurchaseBadge :: HasCallStack => TestParams -> IO () +testPurchaseBadge ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + let purchase = "/_badge purchase 1 " <> paymentArg supporterPlay + alice ##> purchase + alice <## "badge redeemed" + alice <## "supporter badge - active" + alice <##. "expires " + -- the app presents a purchase until the badge is stored, and one already stored adds nothing + alice ##> purchase + alice <## "badge already redeemed" + alice ##> "/p" + alice <## "user profile: alice (Alice, * supporter)" + alice <## "use /p [] to change it" + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + map (\(_, c, m, _, _, t) -> (c, m, t)) <$> ledgerRows (chatController alice) "badge_ledger" `shouldReturn` [(1, 1, Just "payment"), (-1, 0, Just "badge")] + +testPurchaseBadgeAppStore :: HasCallStack => TestParams -> IO () +testPurchaseBadgeAppStore ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = FakeStore {appleLegendJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendJWS}) + alice <## "badge redeemed" + alice <## "legend badge - active" + alice <##. "expires " + storePayments cc `shouldReturn` [("apple", Just 7000, Just "USD", 1)] + +testPurchaseStash :: HasCallStack => TestParams -> IO () +testPurchaseStash ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + let stashes = rowCount (chatController alice) "badge_store_receipts" + -- the store does not vouch for it, so the keys stashed for it can never be credited + alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "not-a-purchase")) + alice <## "cannot redeem badge code: badge service error: receipt_invalid" + stashes `shouldReturn` 0 + -- no store transaction to key a stash by, so nothing is stashed or sent + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = "not.a-jws"}) + alice <## "cannot redeem badge code: invalid store receipt" + stashes `shouldReturn` 0 + nothingPurchased cc + -- pending keeps the keys, and the settled purchase is credited to them, once + let unsettled = "/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken) + alice ##> unsettled + alice <## "cannot redeem badge code: badge service error: payment_pending" + stashes `shouldReturn` 1 + settlePending store + alice ##> unsettled + alice <## "badge redeemed" + alice <## "supporter badge - active" + alice <##. "expires " + stashes `shouldReturn` 1 + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + +testPurchaseWhileBadgeHeld :: HasCallStack => TestParams -> IO () +testPurchaseWhileBadgeHeld ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + code <- issueCode cc BTSupporter 1 + redeemFirstBadge alice code + alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + alice <## "cannot redeem badge code: badge already active" + rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 0 + rowCount cc "sx_badge_service_payments" `shouldReturn` 0 + +testPurchaseSameReceiptOtherProfile :: HasCallStack => TestParams -> IO () +testPurchaseSameReceiptOtherProfile ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + alice <## "badge redeemed" + alice <## "supporter badge - active" + alice <##. "expires " + alice ##> "/create user alisa" + showActiveUser alice "alisa" + alice ##> ("/_badge purchase 2 " <> paymentArg supporterPlay) + alice <## "cannot redeem badge code: badge service error: receipt_used" diff --git a/tests/Bots/BadgeService/FakeStore.hs b/tests/Bots/BadgeService/FakeStore.hs new file mode 100644 index 0000000000..16df9d64c8 --- /dev/null +++ b/tests/Bots/BadgeService/FakeStore.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Bots.BadgeService.FakeStore + ( FakeStore (..), + newFakeStore, + settlePending, + googleSupporterToken, + googlePendingToken, + googleUnreachableToken, + googleSubscriptionToken, + googlePayment, + unsignedJWS, + ) +where + +import BadgeService.StoreReceipts +import qualified Data.Aeson as J +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Simplex.Chat.PaymentService (ServicePayment (..)) +import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String (strEncode) +import Simplex.Messaging.Util (safeDecodeUtf8) +import System.FilePath (()) + +fixtureDir :: FilePath +fixtureDir = "apps" "simplex-badge-service" "test-fixtures" "apple" + +-- | Stores that vouch for a fixed set of receipts. The Apple JWS are the fixtures wrapped in a JWS +-- envelope with no real signature, and are accepted as these exact strings only, never because a +-- payload decodes - which is what a real verifier must refuse to do. +data FakeStore = FakeStore + { appleSupporterJWS :: Text, + appleLegendJWS :: Text, + pendingSettled :: IORef Bool, + fakeVerifier :: StoreVerifier + } + +newFakeStore :: IO FakeStore +newFakeStore = do + appleSupporterJWS <- unsignedJWS <$> B.readFile (fixtureDir "transaction-supporter.json") + appleLegendJWS <- unsignedJWS <$> B.readFile (fixtureDir "transaction-legend.json") + pendingSettled <- newIORef False + let appleReceipts = + [ (appleSupporterJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" 700), + (appleLegendJWS, appleTransaction "2000000812345672" "BADGE_LEGEND_01" 7000) + ] + verifyApple jws = pure $ maybe (Left $ SRInvalid "not a fake receipt") Right $ lookup jws appleReceipts + verifyGoogle productId token = googleVerdict pendingSettled productId token + pure FakeStore {appleSupporterJWS, appleLegendJWS, pendingSettled, fakeVerifier = StoreVerifier {verifyApple, verifyGoogle}} + where + appleTransaction providerRef productId cents = + StoreTransaction {providerRef, productId, quantity = 1, paid = Just (CurrencyAmount cents, "USD")} + +googleVerdict :: IORef Bool -> Text -> Text -> IO (Either StoreRefusal StoreTransaction) +googleVerdict pendingSettled productId token + | (productId, token) == ("badge_supporter_01", googleSupporterToken) = pure $ Right purchased + | (productId, token) == ("subscr_badge_supporter_01", googleSubscriptionToken) = pure $ Right purchased + | (productId, token) == ("badge_supporter_01", googlePendingToken) = do + settled <- readIORef pendingSettled + pure $ if settled then Right purchased else Left SRPending + | token == googleUnreachableToken = pure $ Left $ SRUnreachable "fake store is down" + | otherwise = pure $ Left $ SRInvalid "not a fake purchase" + where + purchased = StoreTransaction {providerRef = tokenRef, productId, quantity = 1, paid = Nothing} + tokenRef = safeDecodeUtf8 $ strEncode $ C.sha256Hash $ encodeUtf8 token + +settlePending :: FakeStore -> IO () +settlePending FakeStore {pendingSettled} = writeIORef pendingSettled True + +googleSupporterToken, googlePendingToken, googleUnreachableToken, googleSubscriptionToken :: Text +googleSupporterToken = "fake-play-token-supporter.AO-J1Oz9x2kqE7wYt3" +googlePendingToken = "fake-play-token-pending.AO-J1Oy8w1jpD6vXs2" +googleUnreachableToken = "fake-play-token-unreachable.AO-J1Ox7v0ioC5uWr1" +googleSubscriptionToken = "fake-play-token-subscription.AO-J1Ow6u9hnB4tVq0" + +googlePayment :: Text -> Text -> ServicePayment +googlePayment productId token = SPGoogle {productId, token} + +unsignedJWS :: B.ByteString -> Text +unsignedJWS payload = safeDecodeUtf8 $ B.intercalate "." $ map B64U.encodeUnpadded [header, payload, "not a signature"] + where + header = LB.toStrict $ J.encode $ J.object ["alg" J..= ("ES256" :: Text), "x5c" J..= (["leaf", "intermediate", "root"] :: [Text])] diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index dd21c820dd..cd24ff198b 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 (CodeRedemption (..), IssuedCode (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getBadgeCode, insertBadgeCode, revokeCode) +import BadgeService.Store (FundingClaim (..), 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 = CodeUnredeemed} -> pure True + Just IssuedCode {redemption = Unclaimed} -> pure True _ -> pure False revokedFirst <- newCode "revoked-first" revoke "revoked-first" `shouldReturn` Revoked