From a329f516206ce89d43d1687a83403df49edcd88b Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 25 Sep 2026 18:39:39 +0400 Subject: [PATCH] core: deliver a store purchase to the profile it was bought under; verify store receipts safely --- .../src/BadgeService/Service.hs | 97 +++++++++++-------- .../src/BadgeService/StoreReceipts.hs | 68 +++++++++---- .../apple/transaction-legend.json | 2 +- .../apple/transaction-sandbox.json | 19 ++++ .../apple/transaction-supporter.json | 2 +- docs/protocol/badges-rpc.md | 4 +- src/Simplex/Chat/Library/Commands.hs | 23 ++--- src/Simplex/Chat/PaymentService.hs | 24 +++++ src/Simplex/Chat/Store/Badges.hs | 9 ++ .../Migrations/M20260915_user_badges.hs | 1 + .../M20260925_badge_store_receipts.hs | 2 +- .../Migrations/M20260915_user_badges.hs | 1 + .../M20260925_badge_store_receipts.hs | 2 +- tests/BadgeTests.hs | 15 ++- tests/Bots/BadgeService/BotTests.hs | 92 +++++++++++++++--- tests/Bots/BadgeService/FakeStore.hs | 79 ++++++++++----- 16 files changed, 322 insertions(+), 118 deletions(-) create mode 100644 apps/simplex-badge-service/test-fixtures/apple/transaction-sandbox.json diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 8d483ca0e8..bd6b7fa2e2 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -15,6 +15,7 @@ module BadgeService.Service badgeServiceCLI, badgeServiceResponse, badgeErrorRetryAfter, + shownServiceRequest, IssueCodeOpts (..), issueBadgeCode, ) @@ -44,7 +45,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace) import Data.Either (fromRight) -import Data.Functor (($>)) +import Data.Functor (($>), (<&>)) import Data.Int (Int64) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, maybeToList) @@ -63,7 +64,6 @@ 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 (..)) @@ -186,12 +186,11 @@ badgeServiceCLI opts@BadgeServiceOpts {serviceConfigFile} = do serviceCfg <- traverse readConfigOrExit serviceConfigFile key <- requireIssuerKey opts serviceCfg terminalChatConfig env <- newServiceState - let eventHook _cc ev = do - case ev of - Right (CEvtServiceRequest u reqId sigKey reqData) -> - atomically $ writeTQueue (serviceRequestQ env) (u, reqId, sigKey, reqData) - _ -> pure () - pure ev + let eventHook _cc = \case + Right (CEvtServiceRequest u reqId sigKey reqData) -> do + atomically $ writeTQueue (serviceRequestQ env) (u, reqId, sigKey, reqData) + pure $ Right $ CEvtServiceRequest u reqId sigKey (shownServiceRequest reqData) + ev -> pure ev chatHooks = defaultChatHooks { preStartHook = Just $ badgePreStartHook opts, @@ -204,6 +203,12 @@ badgeServiceCLI opts@BadgeServiceOpts {serviceConfigFile} = do processQueuedRequests key env ] +-- | The terminal prints each request, and requests carry codes and store receipts, which are bearer secrets. +shownServiceRequest :: J.Object -> J.Object +shownServiceRequest reqData = case KM.lookup "request" reqData of + Just (J.Object cmd) | Just t <- KM.lookup "type" cmd -> KM.singleton "request" $ J.object ["type" J..= t] + _ -> KM.empty + badgeCmdHook :: ChatController -> ChatCommand -> IO (Either (Either ChatError ChatResponse) ChatCommand) badgeCmdHook cc = \case CustomChatCommand cmd -> Left <$> runBadgeCmd cc cmd @@ -352,10 +357,10 @@ badgeServiceResponse key verifier cc sigKey reqData = case J.fromJSON (J.Object 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 + | Just receipt_ <- storeReceipt verifier payment -> case (purchaseKey, upgrade) of + (Just k, Nothing) -> either storeRefusalResponse (purchaseWithReceipt key cc k masterKey) receipt_ -- store upgrades are not built, and ignoring one would credit its months at the discounted price - (Just _, Just _) -> pure $ errorResponse BSEUnsupportedVersion + (Just _, Just _) -> pure $ errorResponse BSEBadRequest (Nothing, _) -> pure $ errorResponse BSEBadRequest BSCIssueBadge {balance} -> case purchaseKey of Just k -> issueBadgeCmd key cc k balance @@ -428,41 +433,55 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText -- | 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 +purchaseWithReceipt :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeMasterKey -> StoreReceipt -> IO BadgeServiceResponse +purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {provider, providerRef, verifyReceipt} = + withDB' "getStorePayment" cc (\db -> getStorePaymentClaim db provider providerRef) >>= \case + Left _ -> pure $ errorResponse BSEInternal + Right claim + -- only the key it credited can ask, and it is told only what it was given, so the store is not asked + | claimedBy claim -> answerClaim claim + | otherwise -> + verifyReceipt >>= \case + Left refusal -> storeRefusalResponse refusal + Right StoreTransaction {environment = SETest} -> storeRefusalResponse $ SRInvalid "test purchase" + -- another key's claim is told only once the store vouched for the receipt, or it would reveal which transactions were credited + Right tx -> case claim of + Unclaimed -> newPurchase tx + _ -> answerClaim claim where - readClaim providerRef db = liftIO $ getStorePaymentClaim db provider providerRef >>= claimedResponse db BSEReceiptUsed purchaseKey + claimedBy = \case + Claimed ClaimedPurchase {purchaseKey = k} -> k == purchaseKey + _ -> False + answerClaim claim = + withDB' "answerStoreClaim" cc (\db -> claimedResponse db BSEReceiptUsed purchaseKey claim) <&> \case + Right (Left resp) -> resp + _ -> errorResponse BSEInternal + -- the product is read only for a receipt not yet credited, so retiring it leaves its replays answered + newPurchase StoreTransaction {productId, quantity, paid} = 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 -> + liftIO (getStorePaymentClaim db provider providerRef >>= claimedResponse db BSEReceiptUsed purchaseKey) >>= \case + Left resp -> pure resp + Right () -> logError "badge service: claiming a store payment failed, but it funds no purchase" $> errorResponse BSEInternal + Just purchaseId -> liftIO $ firstMonthResponse db purchaseId (Just paymentId) firstMonth + pure $ fromRight (errorResponse BSEInternal) r --- | The client learns only the code: a forged receipt and a refunded purchase are both receipt_invalid. +-- | The client learns only the code: a forged receipt, a refunded purchase and a test one are all 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 + SRVerifierFailed reason -> logError ("store receipt not verified: " <> reason) $> errorResponse BSEInternal claimedResponse :: DB.Connection -> BadgeServiceErrorCode -> C.PublicKeyEd25519 -> FundingClaim -> IO (Either BadgeServiceResponse ()) claimedResponse db usedCode purchaseKey = \case diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs index 87e1c586ad..fb9d66071b 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs @@ -5,54 +5,84 @@ module BadgeService.StoreReceipts ( StoreTransaction (..), + StoreEnvironment (..), StoreRefusal (..), StoreVerifier (..), + StoreReceipt (..), noStoreVerifier, - storeVerification, + storeReceipt, ) where +import Control.Exception (evaluate) +import Data.Bifunctor (first) +import Data.Maybe (fromMaybe) import Data.Text (Text) -import Simplex.Chat.PaymentService (ServicePayment (..)) +import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef) import Simplex.Chat.PaymentService.Types (CurrencyAmount, PaymentProvider (..)) import Simplex.Messaging.Util (catchOwn') +import System.Timeout (timeout) --- | 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. +-- | What a store vouches for about one completed transaction. data StoreTransaction = StoreTransaction - { providerRef :: Text, - productId :: Text, + { productId :: Text, quantity :: Int, + environment :: StoreEnvironment, paid :: Maybe (CurrencyAmount, Text) -- in minor units; Google's purchase record carries no price } deriving (Eq, Show) +-- | A test purchase costs the buyer nothing: Apple's Sandbox, which a public TestFlight build buys +-- in, and Google's license testers. +data StoreEnvironment = SEProduction | SETest + 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 + | SRVerifierFailed Text -- a bug, not the store's 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. +-- Apple is checked offline, so its verifier is pure and cannot be unreachable; only Google is asked. +-- A store with no verifier deployed is unreachable: its purchases may be real. data StoreVerifier = StoreVerifier - { verifyApple :: Text -> IO (Either StoreRefusal StoreTransaction), -- the JWS - verifyGoogle :: Text -> Text -> IO (Either StoreRefusal StoreTransaction) -- the product id and the token + { verifyApple :: Maybe (Text -> Either Text StoreTransaction), -- the JWS; Left is why Apple did not sign it + verifyGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal StoreTransaction)) -- the product id and the token + } + +-- | A store payment, named by the store's own reference before anything is verified. +data StoreReceipt = StoreReceipt + { provider :: PaymentProvider, + providerRef :: Text, + verifyReceipt :: IO (Either StoreRefusal StoreTransaction) } noStoreVerifier :: StoreVerifier -noStoreVerifier = StoreVerifier {verifyApple = \_ -> unconfigured, verifyGoogle = \_ _ -> unconfigured} - where - unconfigured = pure $ Left $ SRUnreachable "no verifier configured" +noStoreVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Nothing} --- | 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) +-- | Nothing for a payment no store made. Exceptions are not logged, since they can quote the receipt +-- or, from Google, a URL holding the token. +storeReceipt :: StoreVerifier -> ServicePayment -> Maybe (Either StoreRefusal StoreReceipt) +storeReceipt StoreVerifier {verifyApple, verifyGoogle} = \case + SPApple {jws} -> Just $ case appleTransactionId jws of + Nothing -> Left $ SRInvalid "names no transaction" + Just ref -> Right $ StoreReceipt PPApple ref $ maybe unconfigured (\verify -> offline $ first SRInvalid $ verify jws) verifyApple + SPGoogle {productId, token} -> Just $ Right $ StoreReceipt PPGoogle (googlePurchaseRef token) $ maybe unconfigured (\verify -> online $ verify productId token) verifyGoogle SPInvoice {} -> Nothing SPReceipt {} -> Nothing where - answered verify = verify `catchOwn'` \_ -> pure $ Left $ SRUnreachable "verifier threw" + unconfigured = pure $ Left $ SRUnreachable "no verifier configured" + -- nothing was fetched, so a throw is a bug or a malformed receipt, never an outage + offline verdict = forced verdict `catchOwn'` \_ -> pure $ Left $ SRVerifierFailed "apple verifier threw" + online verify = + (fromMaybe (Left $ SRUnreachable "google verifier timed out") <$> timeout storeVerifyTimeout (verify >>= forced)) + `catchOwn'` \_ -> pure $ Left $ SRUnreachable "google verifier threw" + -- a verdict holding a thunk that throws would otherwise throw later, outside these handlers + forced = either (fmap Left . evaluate) (fmap Right . evaluate) + +-- | Requests are answered one at a time, so a store that does not answer holds up every other one. +storeVerifyTimeout :: Int +storeVerifyTimeout = 10000000 diff --git a/apps/simplex-badge-service/test-fixtures/apple/transaction-legend.json b/apps/simplex-badge-service/test-fixtures/apple/transaction-legend.json index 36068a8030..72ee85416c 100644 --- a/apps/simplex-badge-service/test-fixtures/apple/transaction-legend.json +++ b/apps/simplex-badge-service/test-fixtures/apple/transaction-legend.json @@ -10,7 +10,7 @@ "appAccountToken": "0b6a7e1d-5c3f-4a8e-b2d4-9e1f6c7a8b20", "inAppOwnershipType": "PURCHASED", "signedDate": 1790000001000, - "environment": "Sandbox", + "environment": "Production", "transactionReason": "PURCHASE", "storefront": "USA", "storefrontId": "143441", diff --git a/apps/simplex-badge-service/test-fixtures/apple/transaction-sandbox.json b/apps/simplex-badge-service/test-fixtures/apple/transaction-sandbox.json new file mode 100644 index 0000000000..e61c63d2a7 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/apple/transaction-sandbox.json @@ -0,0 +1,19 @@ +{ + "transactionId": "2000000812345673", + "originalTransactionId": "2000000812345673", + "bundleId": "chat.simplex.app", + "productId": "BADGE_LEGEND_01", + "purchaseDate": 1790000000000, + "originalPurchaseDate": 1790000000000, + "quantity": 1, + "type": "Consumable", + "appAccountToken": "4d2c9a61-8e3b-4f70-a1c5-6b0e9d2f3a47", + "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 index 0a86f61da5..267184c036 100644 --- a/apps/simplex-badge-service/test-fixtures/apple/transaction-supporter.json +++ b/apps/simplex-badge-service/test-fixtures/apple/transaction-supporter.json @@ -10,7 +10,7 @@ "appAccountToken": "7f7c0f43-4b7b-4c2e-9d57-1b7a2b1f3c11", "inAppOwnershipType": "PURCHASED", "signedDate": 1790000001000, - "environment": "Sandbox", + "environment": "Production", "transactionReason": "PURCHASE", "storefront": "USA", "storefrontId": "143441", diff --git a/docs/protocol/badges-rpc.md b/docs/protocol/badges-rpc.md index dc2aeb15d4..8e316428b8 100644 --- a/docs/protocol/badges-rpc.md +++ b/docs/protocol/badges-rpc.md @@ -32,7 +32,7 @@ No command lets the client state what is signed. The tier is that of whatever fu - `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` 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 and `provider_unavailable` while the store cannot be asked, both recording nothing. 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, and for a test purchase, which cost nothing; `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 and `provider_unavailable` while the store cannot be asked, both recording nothing. A receipt already credited to the signing key is answered from the service's record without asking the store. The client does not finish the store transaction on `product_unavailable`: the purchase is paid, and a product the service does not price is its operator's error, so the transaction is presented again at the next trigger rather than retried now. 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. Its `badgeRequest` is to be dropped (see above). - `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). @@ -63,4 +63,4 @@ An assertion that names an entry the service holds is a prefix: the service proc ## Errors -`retryAfter` marks the transient codes: `payment_pending`, `provider_unavailable`, `rate_limited`. `offer_disabled` calls for a catalog refresh. `code_invalid` covers unknown, malformed and revoked codes alike, so a guesser learns nothing from the difference; `code_used` — redeemed under another key; `code_expired` — past its redemption deadline. `receipt_invalid` covers unknown receipts. All other codes are terminal for the attempted command. +`retryAfter` marks the transient codes: `payment_pending`, `provider_unavailable`, `rate_limited`. `offer_disabled` calls for a catalog refresh. `code_invalid` covers unknown, malformed and revoked codes alike, so a guesser learns nothing from the difference; `code_used` — redeemed under another key; `code_expired` — past its redemption deadline. `receipt_invalid` covers forged, malformed, unknown, refunded and test receipts alike, so a guesser learns nothing from the difference; `receipt_used` — credited to another key. All other codes are terminal for the attempted command. diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index f0e62c2273..4bc1dc4e5e 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -26,12 +26,10 @@ 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 @@ -78,7 +76,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.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef) import Simplex.Chat.ProfileGenerator (generateRandomProfile) import Simplex.Chat.Protocol import Simplex.Chat.Remote @@ -5244,14 +5242,15 @@ 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. +-- | The app presents a purchase until this returns its badge, under whichever profile is active; the +-- stash stays with the profile it was first presented under, so every retry is the signer first credited. purchaseBadge :: NetworkRequestMode -> User -> ServicePayment -> CM ChatResponse -purchaseBadge nm user@User {userId} payment = do +purchaseBadge nm presentingUser payment = do txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwRedeemError BREServiceNotConfigured) pure g <- asks random now <- liftIO getCurrentTime + user@User {userId} <- withStore $ \db -> liftIO (getBadgeStoreReceiptUserId db txRef) >>= maybe (pure presentingUser) (getUser db) (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 @@ -5266,21 +5265,13 @@ purchaseBadge nm user@User {userId} payment = do 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. +-- | The same reference the service claims a transaction by, read without verifying anything. storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef storeTransactionRef = \case SPApple {jws} -> StoreTransactionRef "apple" <$> appleTransactionId jws - SPGoogle {token} -> Just $ StoreTransactionRef "google" $ safeDecodeUtf8 $ strEncode $ C.sha256Hash $ encodeUtf8 token + SPGoogle {token} -> Just $ StoreTransactionRef "google" $ googlePurchaseRef 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. diff --git a/src/Simplex/Chat/PaymentService.hs b/src/Simplex/Chat/PaymentService.hs index b8cedaa678..91b7a9fde1 100644 --- a/src/Simplex/Chat/PaymentService.hs +++ b/src/Simplex/Chat/PaymentService.hs @@ -1,17 +1,28 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Simplex.Chat.PaymentService ( ServiceInvoice (..), ServicePayment (..), + appleTransactionId, + googlePurchaseRef, module Simplex.Chat.PaymentService.Types, ) where +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as JM import qualified Data.Aeson.TH as JQ +import qualified Data.ByteString.Base64.URL as B64U import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) import Simplex.Chat.PaymentService.Types +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String (strEncode) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON) +import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8) data ServiceInvoice = ServiceInvoice { invoiceId :: InvoiceId, @@ -32,6 +43,19 @@ data ServicePayment | SPReceipt {receipt :: Text} -- transfer of unissued months deriving (Show) +-- | Read without verifying the signature: it names the transaction, and proves nothing about it. +appleTransactionId :: Text -> Maybe Text +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 purchase token is a bearer secret, so a purchase is named by its hash. +googlePurchaseRef :: Text -> Text +googlePurchaseRef = safeDecodeUtf8 . strEncode . C.sha256Hash . encodeUtf8 + $(JQ.deriveJSON defaultJSON ''ServiceInvoice) $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SP") ''ServicePayment) diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 670bc0aaff..a1c67f8cc3 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -20,6 +20,7 @@ module Simplex.Chat.Store.Badges clearShownBadge, getBadgeCodeRedemption, createBadgeCodeRedemption, + getBadgeStoreReceiptUserId, getBadgeStoreReceipt, createBadgeStoreReceipt, deleteBadgeStash, @@ -49,6 +50,7 @@ import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..)) import Simplex.Chat.Store.Shared (insertedRowId) import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol (UserId) import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C @@ -105,6 +107,13 @@ createBadgeCodeRedemption db g User {userId} code now = do redemptionId <- insertedRowId db pure BadgeStash {stashRef = BSRCodeRedemption redemptionId, purchaseKey, purchasePrivKey, masterKey} +-- | A store transaction belongs to the store account, not to a profile, so its stash is looked up +-- across profiles: presented under another, it still reaches the service as the key it was credited to. +getBadgeStoreReceiptUserId :: DB.Connection -> StoreTransactionRef -> IO (Maybe UserId) +getBadgeStoreReceiptUserId db StoreTransactionRef {provider, transactionRef} = + maybeFirstRow fromOnly $ + DB.query db "SELECT user_id FROM badge_store_receipts WHERE provider = ? AND transaction_ref = ?" (provider, transactionRef) + getBadgeStoreReceipt :: DB.Connection -> User -> StoreTransactionRef -> IO (Maybe BadgeStash) getBadgeStoreReceipt db User {userId} StoreTransactionRef {provider, transactionRef} = maybeFirstRow (toBadgeStash BSRStoreReceipt) $ 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 78e8e6ed46..194d2b7343 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs @@ -152,6 +152,7 @@ DROP TABLE @badge_prices; |] {- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers. +The service alone already has @badge_purchases.payment_id and @badge_ledger.payment_id (its 20260925_badge_store_receipts). CREATE TABLE @subscription_charges( charge_id TEXT NOT NULL PRIMARY KEY, 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 index c4b0dc4981..8c9eb9e607 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs @@ -18,7 +18,7 @@ CREATE TABLE badge_store_receipts( purchase_priv_key BYTEA NOT NULL, master_key BYTEA NOT NULL, created_at TIMESTAMPTZ NOT NULL, - UNIQUE(user_id, provider, transaction_ref) + UNIQUE(provider, transaction_ref) ); CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id); 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 5ea14f98b9..e0eebca9b0 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs @@ -153,6 +153,7 @@ DROP TABLE @badge_prices; |] {- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers. +The service alone already has @badge_purchases.payment_id and @badge_ledger.payment_id (its 20260925_badge_store_receipts). CREATE TABLE @subscription_charges( charge_id TEXT NOT NULL PRIMARY KEY, 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 index 1da7255f23..34520e1dbd 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs @@ -17,7 +17,7 @@ CREATE TABLE badge_store_receipts( purchase_priv_key BLOB NOT NULL, master_key BLOB NOT NULL, created_at TEXT NOT NULL, - UNIQUE(user_id, provider, transaction_ref) + UNIQUE(provider, transaction_ref) ) STRICT; CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id); diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index bf14e5d86c..d4bd5e84a7 100644 --- a/tests/BadgeTests.hs +++ b/tests/BadgeTests.hs @@ -9,7 +9,7 @@ module BadgeTests (badgeTests) where -import BadgeService.Service (badgeErrorRetryAfter) +import BadgeService.Service (badgeErrorRetryAfter, shownServiceRequest) import Control.Concurrent.STM (atomically) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Base64.URL as B64U @@ -103,6 +103,7 @@ badgeTests = do 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 + it "shows a service request in the terminal as its type alone" testShownServiceRequest proofOf :: BadgeProof -> BBSProof proofOf (BadgeProof _ _ p _) = p @@ -843,6 +844,18 @@ testStoreTransactionRef = do google `shouldBe` storeTransactionRef SPGoogle {productId = "badge_supporter_01", token = "play-token"} storeTransactionRef SPInvoice {invoiceId = InvoiceId "inv"} `shouldBe` Nothing +testShownServiceRequest :: IO () +testShownServiceRequest = do + drg <- C.newRandom + mk <- generateMasterKey drg + (k, _) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519) + let shown request = case J.toJSON BadgeServiceRequest {version = Version 1, purchaseKey = Just k, request} of + J.Object o -> J.Object (shownServiceRequest o) + _ -> J.Null + typeOnly t = J.object ["request" J..= J.object ["type" J..= (t :: T.Text)]] + shown BSCPurchaseBadge {masterKey = mk, payment = SPApple {jws = "a.b.c"}, upgrade = Nothing} `shouldBe` typeOnly "purchaseBadge" + shown BSCRedeemBadgeCode {masterKey = mk, code = "SB-00000-00000-00000-00001"} `shouldBe` typeOnly "redeemBadgeCode" + testCredentialResponseJSON :: IO () testCredentialResponseJSON = do Right (_, sk) <- bbsKeyGen diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 76095ed8cd..7c621d59c4 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -15,6 +15,7 @@ import Bots.BadgeService.ConfigTests (withIssuer) import Bots.BadgeService.FakeStore import BadgeService.Options import BadgeService.Service +import BadgeService.Store (NewStorePurchase (..), createStorePurchase) import BadgeService.Store.Invoices (markCodePaid) import Simplex.Messaging.Agent.Store.DB (Binary (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -52,7 +53,7 @@ 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.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) import Simplex.Messaging.Agent.Store.Common (withTransaction) @@ -122,12 +123,16 @@ badgeServiceTests = do 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 replay a receipt to its own key while the store is down, and to no other" testStoreReplayWhileStoreDown + it "should answer a throwing Apple verifier as internal, and a failing or hanging Google one as retryable" testStoreVerifierFailures + it "should credit a transaction claimed twice at once only once" testStoreClaimRace 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 + it "should answer a receipt presented under a second profile as the profile that bought it" testPurchaseSameReceiptOtherProfile + it "should deliver a purchase first presented under another profile to that profile" testPurchaseStrandedUnderOtherProfile 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} @@ -1445,18 +1450,13 @@ testStoreReceiptUsed ps = testStoreReceiptInvalid :: HasCallStack => TestParams -> IO () testStoreReceiptInvalid ps = - withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = FakeStore {appleSupporterJWS}} -> do + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = FakeStore {appleSandboxJWS}} -> 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) + -- refused by the service, which the store would have vouched for + refused SPApple {jws = appleSandboxJWS} `shouldReturn` (BSEReceiptInvalid, Nothing) nothingPurchased cc testStoreUnreachable :: HasCallStack => TestParams -> IO () @@ -1501,7 +1501,7 @@ testStoreUpgradeRefused ps = 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) + refusalOf upgraded `shouldBe` (BSEBadRequest, Nothing) nothingPurchased cc testStoreBadgeTypeFromProduct :: HasCallStack => TestParams -> IO () @@ -1523,6 +1523,48 @@ testNonStoreFundingRefused ps = refusalOf transfer `shouldBe` (BSEUnknownPurchaseKey, Nothing) nothingPurchased cc +testStoreReplayWhileStoreDown :: HasCallStack => TestParams -> IO () +testStoreReplayWhileStoreDown ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey supporterPlay + ledger <- ledgerRows cc "sx_badge_service_badge_ledger" + setGoogleDown store True + -- the key it was credited to is answered from the record + replayed <- serviceCmd env purchaseKey $ purchaseCmd masterKey supporterPlay + credentialOf replayed `shouldBe` credentialOf purchased + -- any other key waits for the store, or the answer would tell it which purchases were credited + (otherKey, otherMasterKey) <- newPurchaseKeys + other <- serviceCmd env otherKey $ purchaseCmd otherMasterKey supporterPlay + fst (refusalOf other) `shouldBe` BSEProviderUnavailable + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger + +testStoreVerifierFailures :: HasCallStack => TestParams -> IO () +testStoreVerifierFailures ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = FakeStore {appleThrowingJWS}} -> do + (purchaseKey, masterKey) <- newPurchaseKeys + let answer payment = refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey payment) + -- Apple is checked offline, so a verifier that throws was answered by nothing but its own bug + answer SPApple {jws = appleThrowingJWS} `shouldReturn` (BSEInternal, Nothing) + answer (googlePayment "badge_supporter_01" googleThrowingToken) >>= (`shouldSatisfy` \(code, retryAfter) -> code == BSEProviderUnavailable && isJust retryAfter) + answer (googlePayment "badge_supporter_01" googleHangingToken) >>= (`shouldSatisfy` \(code, retryAfter) -> code == BSEProviderUnavailable && isJust retryAfter) + nothingPurchased cc + +testStoreClaimRace :: HasCallStack => TestParams -> IO () +testStoreClaimRace ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsController = cc} -> do + (firstKey, firstMasterKey) <- newPurchaseKeys + (otherKey, otherMasterKey) <- newPurchaseKeys + now <- getCurrentTime + let claim paymentId purchaseKey masterKey = + withDB' "claim" cc $ \db -> + createStorePurchase db NewStorePurchase {paymentId, provider = PPGoogle, providerRef = "ref", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter} now + -- both past the read before either wrote, as two requests signing at once are + claim "p1" firstKey firstMasterKey >>= (`shouldSatisfy` either (const False) isJust) + claim "p2" otherKey otherMasterKey `shouldReturn` Right Nothing + rowCount cc "sx_badge_service_payments" `shouldReturn` 1 + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + testStorePurchaseKeyMismatch :: HasCallStack => TestParams -> IO () testStorePurchaseKeyMismatch ps = withBadgeService ps $ \clientCfg bsLink cc -> @@ -1608,7 +1650,7 @@ testPurchaseWhileBadgeHeld ps = testPurchaseSameReceiptOtherProfile :: HasCallStack => TestParams -> IO () testPurchaseSameReceiptOtherProfile ps = - withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg} -> + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) alice <## "badge redeemed" @@ -1616,5 +1658,29 @@ testPurchaseSameReceiptOtherProfile ps = alice <##. "expires " alice ##> "/create user alisa" showActiveUser alice "alisa" + -- the store transaction is the device's, so it stays with the profile it was bought under alice ##> ("/_badge purchase 2 " <> paymentArg supporterPlay) - alice <## "cannot redeem badge code: badge service error: receipt_used" + alice <## "[user: alice] badge already redeemed" + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + alice ##> "/p" + showActiveUser alice "alisa" + +testPurchaseStrandedUnderOtherProfile :: HasCallStack => TestParams -> IO () +testPurchaseStrandedUnderOtherProfile ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + let unsettled userId = "/_badge purchase " <> show (userId :: Int) <> " " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken) + alice ##> unsettled 1 + alice <## "cannot redeem badge code: badge service error: payment_pending" + alice ##> "/create user alisa" + showActiveUser alice "alisa" + settlePending store + -- presented again under whichever profile is active, the purchase reaches the keys alice stashed + alice ##> unsettled 2 + alice <## "[user: alice] badge redeemed" + alice <## "supporter badge - active" + alice <##. "expires " + rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1 + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + alice ##> "/user alice" + showActiveUser alice "alice (Alice, * supporter)" diff --git a/tests/Bots/BadgeService/FakeStore.hs b/tests/Bots/BadgeService/FakeStore.hs index e98d1a3503..c1ed24bc15 100644 --- a/tests/Bots/BadgeService/FakeStore.hs +++ b/tests/Bots/BadgeService/FakeStore.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,9 +7,12 @@ module Bots.BadgeService.FakeStore ( FakeStore (..), newFakeStore, settlePending, + setGoogleDown, googleSupporterToken, googlePendingToken, googleUnreachableToken, + googleThrowingToken, + googleHangingToken, googleSubscriptionToken, googlePayment, unsignedJWS, @@ -16,17 +20,16 @@ module Bots.BadgeService.FakeStore where import BadgeService.StoreReceipts +import Control.Concurrent (threadDelay) +import Control.Monad (forever) 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 (()) @@ -38,46 +41,74 @@ fixtureDir = "apps" "simplex-badge-service" "test-fixtures" "apple" data FakeStore = FakeStore { appleSupporterJWS :: Text, appleLegendJWS :: Text, + appleSandboxJWS :: Text, + appleThrowingJWS :: Text, pendingSettled :: IORef Bool, + googleDown :: 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") + appleSupporterJWS <- fixtureJWS "transaction-supporter.json" + appleLegendJWS <- fixtureJWS "transaction-legend.json" + appleSandboxJWS <- fixtureJWS "transaction-sandbox.json" + let appleThrowingJWS = unsignedJWS "{\"transactionId\":\"2000000812345679\",\"productId\":\"BADGE_SUPPORTER_01\"}" pendingSettled <- newIORef False + googleDown <- newIORef False let appleReceipts = - [ (appleSupporterJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" 700), - (appleLegendJWS, appleTransaction "2000000812345672" "BADGE_LEGEND_01" 7000) + [ (appleSupporterJWS, appleTransaction "BADGE_SUPPORTER_01" SEProduction 700), + (appleLegendJWS, appleTransaction "BADGE_LEGEND_01" SEProduction 7000), + (appleSandboxJWS, appleTransaction "BADGE_LEGEND_01" SETest 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}} + verifyApple jws + | jws == appleThrowingJWS = error "fake verifier bug" + | otherwise = maybe (Left "not a fake receipt") Right $ lookup jws appleReceipts + verifyGoogle = googleVerdict pendingSettled googleDown + pure + FakeStore + { appleSupporterJWS, + appleLegendJWS, + appleSandboxJWS, + appleThrowingJWS, + pendingSettled, + googleDown, + fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle} + } where - appleTransaction providerRef productId cents = - StoreTransaction {providerRef, productId, quantity = 1, paid = Just (CurrencyAmount cents, "USD")} + fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir name) + appleTransaction productId environment cents = + StoreTransaction {productId, quantity = 1, environment, 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" +googleVerdict :: IORef Bool -> IORef Bool -> Text -> Text -> IO (Either StoreRefusal StoreTransaction) +googleVerdict pendingSettled googleDown productId token = + readIORef googleDown >>= \case + True -> pure $ Left $ SRUnreachable "fake store is down" + False + | (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" + | token == googleThrowingToken -> ioError $ userError "fake connection reset" + | token == googleHangingToken -> forever $ threadDelay 1000000 + | 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 + purchased = StoreTransaction {productId, quantity = 1, environment = SEProduction, paid = Nothing} settlePending :: FakeStore -> IO () settlePending FakeStore {pendingSettled} = writeIORef pendingSettled True -googleSupporterToken, googlePendingToken, googleUnreachableToken, googleSubscriptionToken :: Text +setGoogleDown :: FakeStore -> Bool -> IO () +setGoogleDown FakeStore {googleDown} = writeIORef googleDown + +googleSupporterToken, googlePendingToken, googleUnreachableToken, googleThrowingToken, googleHangingToken, googleSubscriptionToken :: Text googleSupporterToken = "fake-play-token-supporter.AO-J1Oz9x2kqE7wYt3" googlePendingToken = "fake-play-token-pending.AO-J1Oy8w1jpD6vXs2" googleUnreachableToken = "fake-play-token-unreachable.AO-J1Ox7v0ioC5uWr1" +googleThrowingToken = "fake-play-token-throwing.AO-J1Ov5t8gmA3sUp9" +googleHangingToken = "fake-play-token-hanging.AO-J1Ou4s7flZ2rTo8" googleSubscriptionToken = "fake-play-token-subscription.AO-J1Ow6u9hnB4tVq0" googlePayment :: Text -> Text -> ServicePayment