mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-09-27 20:08:34 +00:00
core: deliver a store purchase to the profile it was bought under; verify store receipts safely
This commit is contained in:
spaced4ndy
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -10,7 +10,7 @@
|
||||
"appAccountToken": "0b6a7e1d-5c3f-4a8e-b2d4-9e1f6c7a8b20",
|
||||
"inAppOwnershipType": "PURCHASED",
|
||||
"signedDate": 1790000001000,
|
||||
"environment": "Sandbox",
|
||||
"environment": "Production",
|
||||
"transactionReason": "PURCHASE",
|
||||
"storefront": "USA",
|
||||
"storefrontId": "143441",
|
||||
|
||||
@@ -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"
|
||||
}
|
||||
@@ -10,7 +10,7 @@
|
||||
"appAccountToken": "7f7c0f43-4b7b-4c2e-9d57-1b7a2b1f3c11",
|
||||
"inAppOwnershipType": "PURCHASED",
|
||||
"signedDate": 1790000001000,
|
||||
"environment": "Sandbox",
|
||||
"environment": "Production",
|
||||
"transactionReason": "PURCHASE",
|
||||
"storefront": "USA",
|
||||
"storefrontId": "143441",
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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) $
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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);
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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);
|
||||
|
||||
+14
-1
@@ -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
|
||||
|
||||
@@ -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)"
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user