badge-service: verify App Store and Google Play purchases (#7654)

This commit is contained in:
spaced4ndy
2026-10-13 15:24:07 +00:00
committed by GitHub
parent 5cddbffaa1
commit 59c588932e
31 changed files with 1574 additions and 79 deletions
@@ -272,7 +272,7 @@ final class BadgeStore: ObservableObject {
func storePurchaseRefused(_ user: UserRef, _ invoiceId: String, _ refusal: BadgeIssueFailure) async {
await MainActor.run {
if active(user) && openStorePurchases(user.userId).contains(where: { $0.invoiceId == invoiceId }) {
showAlert(NSLocalizedString("Purchase error", comment: "alert title"), message: refusal.purchaseText)
showAlert(refusal.purchaseAlertTitle, message: refusal.purchaseText)
}
}
await storePurchaseResolved(user, invoiceId)
@@ -379,7 +379,7 @@ private func storeReceipt(_ verification: VerificationResult<Transaction>) -> Ba
// a sweep that hands over a receipt refused while the app was not running learns it only from this answer
private func badgeReceiptRefused(_ error: Error) -> Bool {
if case let .error(.badgeRedeemError(.serviceError(code))) = error as? ChatError {
return code == .receiptInvalid || code == .receiptUsed
return code == .receiptInvalid || code == .receiptUsed || code == .testPurchase
}
return false
}
+4
View File
@@ -855,6 +855,7 @@ public enum BadgeServiceErrorCode: Decodable, Hashable {
case codeExpired
case receiptInvalid
case receiptUsed
case testPurchase
case internalError
case unknown(String)
@@ -876,6 +877,7 @@ public enum BadgeServiceErrorCode: Decodable, Hashable {
case .codeUsed: "code_used"
case .codeExpired: "code_expired"
case .receiptInvalid: "receipt_invalid"
case .testPurchase: "test_purchase"
case .receiptUsed: "receipt_used"
case .internalError: "internal"
case let .unknown(s): s
@@ -900,6 +902,7 @@ public enum BadgeServiceErrorCode: Decodable, Hashable {
case "code_used": self = .codeUsed
case "code_expired": self = .codeExpired
case "receipt_invalid": self = .receiptInvalid
case "test_purchase": self = .testPurchase
case "receipt_used": self = .receiptUsed
case "internal": self = .internalError
case let s: self = .unknown(s)
@@ -917,6 +920,7 @@ public func badgeServiceErrorText(_ code: BadgeServiceErrorCode) -> String? {
case .unknownPurchaseKey: NSLocalizedString("The badge service does not recognize this badge.", comment: "alert message")
case .internalError: NSLocalizedString("The badge service reported an internal error.", comment: "alert message")
case .receiptInvalid: NSLocalizedString("The store did not confirm this purchase.", comment: "alert message")
case .testPurchase: NSLocalizedString("Sandbox purchases are not credited. Badges can only be bought in the App Store version of the app.", comment: "alert message")
case .receiptUsed: NSLocalizedString("This purchase was already credited to a badge on another device or profile.", comment: "alert message")
case .paymentPending: NSLocalizedString("The payment has not been confirmed yet.", comment: "alert message")
case .providerUnavailable: NSLocalizedString("The store could not be reached.", comment: "alert message")
+8
View File
@@ -379,6 +379,14 @@ public enum BadgeIssueFailure: Decodable, Hashable {
}
}
public var purchaseAlertTitle: String {
switch self {
case .serviceError(.testPurchase, _):
NSLocalizedString("Sandbox purchase", comment: "alert title")
default: NSLocalizedString("Purchase error", comment: "alert title")
}
}
// the stored form, for support
public var tag: String {
switch self {
@@ -7475,6 +7475,7 @@ sealed class BadgeServiceErrorCode {
object CodeExpired: BadgeServiceErrorCode()
object ReceiptInvalid: BadgeServiceErrorCode()
object ReceiptUsed: BadgeServiceErrorCode()
object TestPurchase: BadgeServiceErrorCode()
object Internal: BadgeServiceErrorCode()
data class Unknown(val code: String): BadgeServiceErrorCode()
@@ -7497,6 +7498,7 @@ sealed class BadgeServiceErrorCode {
is CodeExpired -> "code_expired"
is ReceiptInvalid -> "receipt_invalid"
is ReceiptUsed -> "receipt_used"
is TestPurchase -> "test_purchase"
is Internal -> "internal"
is Unknown -> code
}
@@ -7511,6 +7513,7 @@ fun badgeServiceErrorText(code: BadgeServiceErrorCode): String? = when (code) {
is BadgeServiceErrorCode.UnknownPurchaseKey -> generalGetString(MR.strings.badges_error_unknown_purchase)
is BadgeServiceErrorCode.Internal -> generalGetString(MR.strings.badges_error_service_internal)
is BadgeServiceErrorCode.ReceiptInvalid -> generalGetString(MR.strings.badges_error_receipt_invalid)
is BadgeServiceErrorCode.TestPurchase -> generalGetString(MR.strings.badges_error_test_purchase)
is BadgeServiceErrorCode.ReceiptUsed -> generalGetString(MR.strings.badges_error_receipt_used)
is BadgeServiceErrorCode.PaymentPending -> generalGetString(MR.strings.badges_error_payment_pending)
is BadgeServiceErrorCode.ProviderUnavailable -> generalGetString(MR.strings.badges_error_provider_unavailable)
@@ -7540,6 +7543,7 @@ object BadgeServiceErrorCodeSerializer : KSerializer<BadgeServiceErrorCode> {
"code_expired" -> BadgeServiceErrorCode.CodeExpired
"receipt_invalid" -> BadgeServiceErrorCode.ReceiptInvalid
"receipt_used" -> BadgeServiceErrorCode.ReceiptUsed
"test_purchase" -> BadgeServiceErrorCode.TestPurchase
"internal" -> BadgeServiceErrorCode.Internal
else -> BadgeServiceErrorCode.Unknown(v)
}
@@ -443,5 +443,5 @@ private fun compactPrice(product: BadgeProduct): String {
private fun badgeReceiptRefused(err: ChatError?): Boolean {
val redeemError = ((err as? ChatError.ChatErrorChat)?.errorType as? ChatErrorType.CEBadgeRedeemError)?.badgeRedeemError
val code = (redeemError as? BadgeRedeemError.ServiceError)?.serviceError
return code is BadgeServiceErrorCode.ReceiptInvalid || code is BadgeServiceErrorCode.ReceiptUsed
return code is BadgeServiceErrorCode.ReceiptInvalid || code is BadgeServiceErrorCode.ReceiptUsed || code is BadgeServiceErrorCode.TestPurchase
}
@@ -3230,6 +3230,7 @@
<string name="badges_error_service_internal">The badge service reported an internal error.</string>
<string name="badges_error_receipt_invalid">The store did not confirm this purchase.</string>
<string name="badges_error_receipt_used">This purchase was already credited to a badge on another device or profile.</string>
<string name="badges_error_test_purchase">Test purchases are not credited. Badges can only be bought with a real purchase.</string>
<string name="badges_error_payment_pending">The payment has not been confirmed yet.</string>
<string name="badges_error_provider_unavailable">The store could not be reached.</string>
<string name="badges_error_provider_not_configured">Badges cannot be bought in the app yet.</string>
+40 -3
View File
@@ -51,7 +51,7 @@ simplex-badge-service --help
`simplex-directory-service --run-cli`). This mode is the chat/RPC side and the `//` commands
below: it starts no web listener and no poller, and serves no group commands, whatever
`--service-config` says. It still updates a code's group message when the code is redeemed or
revoked. `[dev] accept_unverified_store_receipts` applies to it.
revoked. `[apple]`, `[google]` and `[dev] accept_unverified_store_receipts` apply to it.
- `--no-address`: skip address creation on start-up (for operators who provision the address themselves).
The service cannot sign credentials without an issuer key and refuses to start without one:
@@ -84,7 +84,7 @@ Other options:
- `--service-config INI_FILE`: path to `badge_service.ini`. Omit it to run the chat/RPC side
only; the process never starts a web listener without it, and never starts one under
`--run-cli`, which parses and validates the whole file (`[listener] static_dir` included) but
uses only its `[issuer]` section and `[dev] accept_unverified_store_receipts`. An issuer key is
uses only its `[issuer]`, `[apple]` and `[google]` sections and `[dev] accept_unverified_store_receipts`. An issuer key is
still required either way.
- `--service-name NAME`: the bot's display name, without `*`s or spaces (default `SimpleX Badges`).
- `--client-service`: use the client service certificate.
@@ -209,6 +209,43 @@ the exception: each answers 200, 400 or 413 with an empty body, because its prov
caller and nothing it could read would change what the route does. A wrong verb on any route, those
two included, answers `method_not_allowed`.
### Store purchases (App Store and Google Play)
Each store is verified only when its section is present; without one, every receipt from that store
is answered `provider_not_configured` and the app keeps the purchase to present again. A section
missing a key, an unreadable root certificate or service account key, or either section beside
`[dev] accept_unverified_store_receipts = on`, stops the service at startup.
```ini
[apple]
bundle_id = chat.simplex.app
root_certificate = /etc/simplex-badge-service/AppleRootCA-G3.cer
[google]
package_name = chat.simplex.app
service_account_file = /etc/simplex-badge-service/play-service-account.json
```
- `[apple]` verifies the signed transaction offline, against Apple Root CA - G3 in DER as Apple
publishes it at <https://www.apple.com/certificateauthority/AppleRootCA-G3.cer>. A transaction
for another bundle id, or a chain this root does not verify, is answered `internal` and logged as
an error rather than refused, since `bundle_id` or `root_certificate` may be the wrong one; check
both when those errors appear, unless the purchase was made in Xcode's StoreKit testing, which
the App Store does not sign, so no root verifies it.
- `[google]` asks the Google Play Developer API about each purchase, and acknowledges it before
crediting it, as the service account whose JSON key `service_account_file` holds. The account
needs both Play Console permissions Google's
[getting started](https://developers.google.com/android-publisher/getting_started) lists for its
billing APIs: "View financial data, orders, and cancellation survey responses" to read a
purchase, and "Manage orders and subscriptions" to acknowledge it. Without the second, a Play
purchase the app has not already acknowledged itself is answered `internal` and logged as an
error naming the acknowledgement, and the app presents it again once the permission is granted,
which must be within three days, before Play refunds it. The key signs in
for an access token, so keep the file readable by this service alone.
Which answers are terminal for a purchase and which leave it to be presented again is listed per
store in [`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md#commands).
### Accepting store receipts unverified, for local testing
```ini
@@ -221,7 +258,7 @@ the service accepts any well-formed receipt without asking or verifying anything
the `transactionId` and `productId` its payload names, unsigned or not, and a Play product id and
token as given. It applies to both run modes, since `--run-cli` answers service requests too, and
the service logs a warning at every start while it is on. Off by default, and only `on`/`off`
parse.
parse. The service refuses to start with it on beside an `[apple]` or `[google]` section.
With it on, anyone who can reach the service address can mint badges by sending a made-up receipt.
That is harmless only while this deployment signs with an issuer key released apps do not carry, so
@@ -40,6 +40,24 @@ session_minutes = 60
waiting_seconds = 3
idle_seconds = 60
; verifies App Store purchases offline. Omit the whole section and the service answers every App Store
; receipt provider_not_configured, which the app retries later.
; root_certificate is Apple Root CA - G3 as Apple publishes it, in DER:
; https://www.apple.com/certificateauthority/AppleRootCA-G3.cer
;[apple]
;bundle_id = chat.simplex.app
;root_certificate = /etc/simplex-badge-service/AppleRootCA-G3.cer
; verifies Play purchases with the Google Play Developer API. Omit the whole section and the service answers
; every Play receipt provider_not_configured, which the app retries later.
; service_account_file is the JSON key Google issues for a service account with the Play Console
; permissions "View financial data, orders, and cancellation survey responses" and "Manage orders and
; subscriptions", to read and acknowledge purchases. Without the second, a purchase the app has not
; already acknowledged itself is answered internal until the permission is granted. Keep the file readable by this service alone.
;[google]
;package_name = chat.simplex.app
;service_account_file = /etc/simplex-badge-service/play-service-account.json
; the key this service signs credentials with. index is the index clients verify against, so
; private_key has to be one whose public half already ships in the apps at that index: a fresh
; `simplex-chat badge keygen` pair is refused until it does.
@@ -62,6 +80,7 @@ idle_seconds = 60
;description = Welcome to the badges group
; local testing only, in both run modes: accepts any well-formed App Store or Play receipt without
; verifying it, so anyone who can reach this service can mint badges
; verifying it, so anyone who can reach this service can mint badges. The service refuses to start
; with this on beside an [apple] or [google] section.
[dev]
accept_unverified_store_receipts = off
@@ -10,6 +10,8 @@ module BadgeService.Config
SpeedPolicy (..),
speedPolicyName,
PollConfig (..),
AppleStoreConfig (..),
PlayStoreConfig (..),
BadgeIssuerKey (..),
GroupConfig (..),
ServiceConfig (..),
@@ -22,11 +24,11 @@ where
import qualified Control.Exception as E
import BadgeService.Log (logWarn)
import Control.Monad (mfilter)
import Control.Monad (mfilter, when)
import Data.Attoparsec.Text (Parser, endOfInput, isEndOfLine, parseOnly, satisfy, skipMany, skipSpace, skipWhile)
import qualified Data.ByteString.Char8 as B
import Data.Ini (Ini, iniGlobals, iniParser, keys, lookupValue, sections)
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
@@ -91,6 +93,20 @@ instance Show StripeConfig where
data PollConfig = PollConfig {pWaitingSeconds :: Int, pIdleSeconds :: Int}
deriving (Eq, Show)
data AppleStoreConfig = AppleStoreConfig
{ aBundleId :: Text,
aRootCertificate :: FilePath
}
deriving (Eq, Show)
data PlayStoreConfig = PlayStoreConfig
{ gPackageName :: Text,
gServiceAccountFile :: FilePath,
gApiHost :: Text,
gTokenUrl :: Text
}
deriving (Eq, Show)
data BadgeIssuerKey = BadgeIssuerKey
{ keyIdx :: Int,
secretKey :: BBSSecretKey
@@ -112,6 +128,8 @@ data ServiceConfig = ServiceConfig
btcpay :: Maybe BTCPayConfig,
stripe :: Maybe StripeConfig,
poll :: PollConfig,
appleStore :: Maybe AppleStoreConfig,
playStore :: Maybe PlayStoreConfig,
issuer :: Maybe BadgeIssuerKey,
group :: Maybe GroupConfig,
-- Local testing only; anyone who can reach the service can mint badges with any well-formed receipt.
@@ -128,6 +146,12 @@ defaultStripeHost = "https://api.stripe.com"
defaultSessionMinutes :: Int
defaultSessionMinutes = 60
defaultPlayApiHost :: Text
defaultPlayApiHost = "https://androidpublisher.googleapis.com"
defaultPlayTokenUrl :: Text
defaultPlayTokenUrl = "https://oauth2.googleapis.com/token"
-- | At most one day, so a card order expires long before the poller stops checking it at 72 hours.
minSessionMinutes, maxSessionMinutes :: Int
minSessionMinutes = 1
@@ -166,6 +190,8 @@ knownSettings =
("btcpay", ["host", "api_key", "store_id", "webhook_secret", "expiry_minutes", "speed_policy", "payment_tolerance"]),
("stripe", ["secret_key", "publishable_key", "webhook_secret", "session_minutes"]),
("poll", ["waiting_seconds", "idle_seconds"]),
("apple", ["bundle_id", "root_certificate"]),
("google", ["package_name", "service_account_file"]),
("group", ["display_name", "description"]),
("dev", ["accept_unverified_store_receipts"]),
("issuer", ["index", "private_key"])
@@ -199,13 +225,19 @@ parseConfig ini = do
grp <- groupSection
pWaitingSeconds <- cadence "waiting_seconds" 3
pIdleSeconds <- cadence "idle_seconds" 60
apple <- appleSection
google <- googleSection
devUnverifiedReceipts <- bool "dev" "accept_unverified_store_receipts" False
when (devUnverifiedReceipts && (isJust apple || isJust google)) $
Left "[dev] accept_unverified_store_receipts must be off where [apple] or [google] verifies store receipts"
pure
ServiceConfig
{ listener = ListenerConfig {lHost, lPort, lStaticDir, lServeWebapp, lWebappExportDir, lTrustForwardedFor},
btcpay = btc,
stripe = str,
poll = PollConfig {pWaitingSeconds, pIdleSeconds},
appleStore = apple,
playStore = google,
issuer = iss,
group = grp,
devAcceptUnverifiedStoreReceipts = devUnverifiedReceipts
@@ -300,6 +332,18 @@ parseConfig ini = do
sSessionMinutes <- sessionMinutes
let sHost = defaultStripeHost
pure (Just StripeConfig {sSecretKey, sPublishableKey, sWebhookSecret, sSessionMinutes, sHost})
appleSection
| not (hasSection "apple") = Right Nothing
| otherwise = do
aBundleId <- required "apple" "bundle_id"
aRootCertificate <- T.unpack <$> required "apple" "root_certificate"
pure (Just AppleStoreConfig {aBundleId, aRootCertificate})
googleSection
| not (hasSection "google") = Right Nothing
| otherwise = do
gPackageName <- required "google" "package_name"
gServiceAccountFile <- T.unpack <$> required "google" "service_account_file"
pure (Just PlayStoreConfig {gPackageName, gServiceAccountFile, gApiHost = defaultPlayApiHost, gTokenUrl = defaultPlayTokenUrl})
sessionMinutes = do
v <- num "stripe" "session_minutes" defaultSessionMinutes
if v >= minSessionMinutes && v <= maxSessionMinutes
@@ -7,6 +7,7 @@
module BadgeService.Service
( ServiceState (..),
newServiceState,
configureStoreVerifier,
welcomeGetOpts,
checkIssuerKey,
badgeService,
@@ -22,7 +23,7 @@ where
import BadgeService.Catalog (StoreProduct (..), defaultCatalog, storeProduct)
import BadgeService.Codes (issueFailedText, issueOneCode, singleUse)
import BadgeService.Config (BadgeIssuerKey (..), ServiceConfig (..), readServiceConfig)
import BadgeService.Config (AppleStoreConfig (..), BadgeIssuerKey (..), PlayStoreConfig (..), ServiceConfig (..), readServiceConfig)
import BadgeService.Group (GroupEvent, ensureManagedGroup, groupEvent, hasTracker, refreshTracker, revokeWithTracker, runGroupLane)
import BadgeService.Group.Command (badgeTypeP, codeP, maxMonths, textTokenP)
import BadgeService.Log (logError, logInfo, logWarn)
@@ -34,6 +35,8 @@ import BadgeService.Store
import BadgeService.Store.Invoices (seedCatalog, truncateToSecond)
import BadgeService.Store.Migrate (runBadgeServiceMigrations)
import BadgeService.StoreReceipts
import BadgeService.StoreReceipts.Apple (readAppleRoot, verifyAppleTransaction)
import BadgeService.StoreReceipts.Google (playStoreVerifier)
import BadgeService.StoreReceipts.Mock (mockStoreVerifier)
import BadgeService.Waiters (Waiters, newWaiters)
import BadgeService.Web.Server (exportWebapp, newWebEnv, runWebListener)
@@ -84,8 +87,8 @@ data ServiceState = ServiceState
storeVerifier :: StoreVerifier
}
-- | No store verifier exists yet, so every store receipt not already credited is answered
-- provider_not_configured, terminal for the request: retrying cannot deploy one.
-- | With no store verifier, which badge_service.ini configures, every store receipt not already credited
-- is answered provider_not_configured.
newServiceState :: IO ServiceState
newServiceState = do
serviceCC <- newEmptyTMVarIO
@@ -130,19 +133,37 @@ readConfigOrExit path =
Left e -> putStrLn (path <> ": " <> e) >> exitFailure
Right sc -> pure sc
devStoreVerifier :: Maybe ServiceConfig -> ServiceState -> IO ServiceState
devStoreVerifier serviceCfg env
| maybe False devAcceptUnverifiedStoreReceipts serviceCfg = do
logWarn "[dev] accept_unverified_store_receipts is on: any store receipt is accepted without verification"
pure env {storeVerifier = mockStoreVerifier}
| otherwise = pure env
-- | The config refuses the dev flag beside a real verifier, so only one of them applies.
configureStoreVerifier :: Maybe ServiceConfig -> ServiceState -> IO ServiceState
configureStoreVerifier serviceCfg env@ServiceState {storeVerifier = v} = case serviceCfg of
Just ServiceConfig {devAcceptUnverifiedStoreReceipts = True} -> do
logWarn "[dev] accept_unverified_store_receipts is on: any store receipt is accepted without verification"
pure env {storeVerifier = mockStoreVerifier}
Just ServiceConfig {appleStore, playStore} -> do
apple <- forM appleStore $ \AppleStoreConfig {aBundleId, aRootCertificate} ->
(\root -> verifyAppleTransaction root aBundleId) <$> orExit (readAppleRoot aRootCertificate)
google <- forM playStore $ orExit . playStoreVerifier
forM_ appleStore $ \AppleStoreConfig {aBundleId} -> logInfo $ "verifying App Store receipts for " <> aBundleId
forM_ playStore $ \PlayStoreConfig {gPackageName} -> logInfo $ "verifying Play purchases for " <> gPackageName
pure
env
{ storeVerifier =
v
{ verifyApple = maybe (verifyApple v) Just apple,
verifyGoogle = maybe (verifyGoogle v) (Just . fst) google,
acknowledgeGoogle = maybe (acknowledgeGoogle v) (Just . snd) google
}
}
Nothing -> pure env
where
orExit = (>>= either (\e -> putStrLn ("Error: " <> e) >> exitFailure) pure)
badgeService :: BadgeServiceOpts -> ChatConfig -> ServiceState -> IO ()
badgeService opts@BadgeServiceOpts {serviceConfigFile} cfg env = do
serviceCfg <- traverse readConfigOrExit serviceConfigFile
key <- requireIssuerKey opts serviceCfg cfg
waiters <- newWaiters
requestEnv <- devStoreVerifier serviceCfg env
requestEnv <- configureStoreVerifier serviceCfg env
let groupCfg = serviceCfg >>= \ServiceConfig {group} -> group
trackerQ_ = groupEventQ env <$ groupCfg
readEvents cc =
@@ -193,7 +214,7 @@ badgeServiceCLI :: BadgeServiceOpts -> IO ()
badgeServiceCLI opts@BadgeServiceOpts {serviceConfigFile} = do
serviceCfg <- traverse readConfigOrExit serviceConfigFile
key <- requireIssuerKey opts serviceCfg terminalChatConfig
env <- newServiceState >>= devStoreVerifier serviceCfg
env <- newServiceState >>= configureStoreVerifier serviceCfg
let eventHook _cc = \case
Right (CEvtServiceRequest u reqId sigKey reqData) -> do
atomically $ writeTQueue (serviceRequestQ env) (u, reqId, sigKey, reqData)
@@ -416,7 +437,7 @@ redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode
-- | 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 -> StoreReceipt -> IO BadgeServiceResponse
purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = providerRef}, verifyReceipt} =
purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = providerRef}, verifyReceipt, acknowledgeReceipt} =
withDB' "getStorePayment" cc (\db -> getStorePaymentCredit db provider providerRef) >>= \case
Left _ -> pure $ errorResponse BSEInternal
Right credit
@@ -430,7 +451,7 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTran
| transactionRef /= providerRef -> storeRefusalResponse $ SRVerifierFailed "verified a transaction other than the one claimed"
Right VerifiedStoreTransaction {quantity}
| quantity /= 1 -> storeRefusalResponse $ SRVerifierFailed $ "verified a quantity of " <> tshow quantity
Right VerifiedStoreTransaction {testPurchase = True} -> storeRefusalResponse $ SRInvalid "test purchase"
Right VerifiedStoreTransaction {testPurchase = True} -> storeRefusalResponse SRTestPurchase
-- another key's credit is told only once the store vouched for the receipt, or it would reveal which transactions were credited
Right tx -> case credit of
Uncredited -> newPurchase tx
@@ -446,26 +467,31 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTran
-- the product is read only for a receipt not yet credited, so retiring it leaves its replays answered
newPurchase VerifiedStoreTransaction {productId, paid} = case storeProduct provider productId of
Nothing -> pure $ errorResponse BSEProductUnavailable
Just StoreProduct {badgeType, months} -> do
now <- badgeNow cc
signFirstMonth key cc masterKey badgeType months (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 (getStorePaymentCredit db provider providerRef >>= creditedResponse db purchaseKey) >>= \case
Left resp -> pure resp
Right () -> logError ("badge service: a payment for " <> providerRef <> " exists but funds no purchase") $> errorResponse BSEInternal
Just purchaseId -> liftIO $ firstMonthResponse db purchaseId (Just paymentId) firstMonth
pure $ fromRight (errorResponse BSEInternal) r
Just StoreProduct {badgeType, months} ->
fromMaybe (pure $ Right ()) acknowledgeReceipt >>= \case
Left refusal -> storeRefusalResponse refusal
Right () -> do
now <- badgeNow cc
signFirstMonth key cc masterKey badgeType months (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 (getStorePaymentCredit db provider providerRef >>= creditedResponse db purchaseKey) >>= \case
Left resp -> pure resp
Right () -> logError ("badge service: a payment for " <> providerRef <> " exists but 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, a refunded purchase and a test one are all receipt_invalid.
-- | A forged receipt and a refunded one are both receipt_invalid, so the client learns nothing a
-- forger could iterate on. A test purchase is named, since the device that made it already knows.
storeRefusalResponse :: StoreRefusal -> IO BadgeServiceResponse
storeRefusalResponse = \case
SRInvalid reason -> logInfo ("store receipt refused: " <> reason) $> errorResponse BSEReceiptInvalid
SRTestPurchase -> logInfo "store receipt refused: test purchase" $> errorResponse BSETestPurchase
SRPending -> pure $ errorResponse BSEPaymentPending
SRUnreachable reason -> logWarn ("store unreachable: " <> reason) $> errorResponse BSEProviderUnavailable
SRVerifierFailed reason -> logError ("store receipt not verified: " <> reason) $> errorResponse BSEInternal
@@ -14,14 +14,13 @@ module BadgeService.StoreReceipts
where
import Control.Exception (evaluate)
import Data.Bifunctor (first)
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, isControl, isDigit, isPrint, isSpace)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef)
import Simplex.Chat.PaymentService.Types (CurrencyAmount, PaymentProvider (..), StoreTransactionRef (..))
import Simplex.Messaging.Util (catchOwn')
import Simplex.Messaging.Util (catchOwn', tshow)
import System.Timeout (timeout)
-- | What a store vouches for about one completed transaction.
@@ -38,19 +37,24 @@ data VerifiedStoreTransaction = VerifiedStoreTransaction
deriving (Eq, Show)
-- | The reasons are for the service's log alone and must never quote the receipt.
-- SRInvalid and SRTestPurchase are terminal: the client drops the purchase's keys and nothing
-- presents it again. So only a verdict no later attempt could change is either; when in doubt, SRUnreachable.
data StoreRefusal
= SRInvalid Text -- a verdict that cannot change, and the client consumes the purchase: forged, malformed, another app's, refunded
= SRInvalid Text -- a verdict that cannot change, and the client consumes the purchase: forged, malformed, refunded
| SRTestPurchase -- the store vouched for it, but it cost nothing; terminal, and named so the app can say why
| SRPending -- a real purchase the store has not settled; it may yet
| SRUnreachable Text -- no verdict: the store was not asked, did not answer, or does not know the token (a Play 404 may be lag)
| SRVerifierFailed Text -- a bug, not the store's answer
| SRVerifierFailed Text -- this service's own failure, its bug or misconfiguration, never the store's answer
| SRNotConfigured -- no verifier for this store is deployed; the purchase may be real
deriving (Eq, Show)
-- | Apple signs its receipt and ships the certificate chain in it, so it is verified with no network
-- call; a Play token is opaque and must be asked about, which is why only that field is in IO.
-- call; a Play token is opaque and must be asked about, which is why only the Play fields are in IO.
data StoreVerifier = StoreVerifier
{ verifyApple :: Maybe (Text -> Either Text VerifiedStoreTransaction), -- the JWS; Left is why Apple did not sign it
{ -- the JWS
verifyApple :: Maybe (Text -> Either StoreRefusal VerifiedStoreTransaction),
verifyGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)), -- the product id and the token
acknowledgeGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal ())),
-- microseconds; requests are answered one at a time, so a verifier that does not finish holds up every other one
verifyTimeout :: Int
}
@@ -58,37 +62,43 @@ data StoreVerifier = StoreVerifier
-- | A store payment, named by the store's own reference before anything is verified.
data StoreReceipt = StoreReceipt
{ txRef :: StoreTransactionRef,
verifyReceipt :: IO (Either StoreRefusal VerifiedStoreTransaction)
verifyReceipt :: IO (Either StoreRefusal VerifiedStoreTransaction),
acknowledgeReceipt :: Maybe (IO (Either StoreRefusal ()))
}
noStoreVerifier :: StoreVerifier
noStoreVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Nothing, verifyTimeout = 10000000}
noStoreVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Nothing, acknowledgeGoogle = Nothing, verifyTimeout = 10000000}
-- | 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.
toStoreReceipt :: StoreVerifier -> ServicePayment -> Maybe (Either StoreRefusal StoreReceipt)
toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, verifyTimeout} = \case
toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, verifyTimeout} = \case
SPApple {jws} -> Just $ case appleTransactionId jws of
Nothing -> Left $ SRInvalid "names no transaction"
Just ref -> Right $ StoreReceipt (StoreTransactionRef PPApple ref) $ maybe unconfigured (\verify -> offline $ first SRInvalid $ verify jws) verifyApple
Just ref -> Right $ StoreReceipt (StoreTransactionRef PPApple ref) (maybe unconfigured (\verify -> offline $ verify jws) verifyApple) Nothing
SPGoogle {productId, token}
-- the claim is the token's hash, so neither string may name any purchase but the one it claims,
-- whatever path a verifier builds from them
| not (googleProductId productId) -> Just $ Left $ SRInvalid "not a Play product id"
-- Play documents no token grammar, so this is our guess, and refusing to ask Play is not its verdict
| not (googleToken token) -> Just $ Left $ SRUnreachable "a Play token this service will not send"
| otherwise -> Just $ Right $ StoreReceipt (StoreTransactionRef PPGoogle (googlePurchaseRef token)) $ maybe unconfigured (\verify -> online $ verify productId token) verifyGoogle
| not (googleToken token) -> Just $ Left $ SRUnreachable $ "a Play token this service will not send: " <> tokenShape token
| otherwise ->
Just $ Right $
StoreReceipt
(StoreTransactionRef PPGoogle (googlePurchaseRef token))
(maybe unconfigured (\verify -> online "google verifier" $ verify productId token) verifyGoogle)
((\acknowledge -> online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogle)
SPInvoice {} -> Nothing
SPReceipt {} -> Nothing
where
unconfigured = pure $ Left SRNotConfigured
-- nothing was fetched, so a throw or an overrun is a bug or a malformed receipt, never an outage
-- nothing was fetched, so a throw or an overrun is this service's failure or a shape it does not know, never an outage
offline verdict =
(fromMaybe (Left $ SRVerifierFailed "apple verifier timed out") <$> timeout verifyTimeout (forced verdict))
`catchOwn'` \_ -> pure $ Left $ SRVerifierFailed "apple verifier threw"
online verify =
(fromMaybe (Left $ SRUnreachable "google verifier timed out") <$> timeout verifyTimeout (verify >>= forced))
`catchOwn'` \_ -> pure $ Left $ SRUnreachable "google verifier threw"
online what call =
(fromMaybe (Left $ SRUnreachable $ what <> " timed out") <$> timeout verifyTimeout (call >>= forced))
`catchOwn'` \_ -> pure $ Left $ SRUnreachable $ what <> " threw"
-- a verdict holding a thunk that throws would otherwise throw later, outside these handlers
forced = either (fmap Left . evaluate) (fmap Right . evaluate)
@@ -97,5 +107,22 @@ googleProductId pid = case T.uncons pid of
Just (c, _) -> T.length pid <= 150 && (isAsciiLower c || isDigit c) && T.all (\x -> isAsciiLower x || isDigit x || x == '_' || x == '.') pid
Nothing -> False
-- | Not empty or only dots, which a URL path resolves away.
googleToken :: Text -> Bool
googleToken t = not (T.null t) && T.length t <= 4096 && T.all (\x -> isAsciiLower x || isAsciiUpper x || isDigit x || x == '.' || x == '_' || x == '-') t
googleToken t = not (T.all (== '.') t) && T.length t <= 4096 && T.all (\x -> isAsciiLower x || isAsciiUpper x || isDigit x || x == '.' || x == '_' || x == '-') t
-- | What the log may say about a token: its length and the kinds of character in it, never any of them.
tokenShape :: Text -> Text
tokenShape t = tshow (T.length t) <> " characters: " <> T.intercalate ", " [kind | (kind, isKind) <- kinds, T.any isKind t]
where
kinds =
[ ("lowercase", isAsciiLower),
("uppercase", isAsciiUpper),
("digits", isDigit),
("'.'", (== '.')),
("'_'", (== '_')),
("'-'", (== '-')),
("other printable ASCII", \c -> isAscii c && isPrint c && not (isAlphaNum c) && c `notElem` ("._-" :: String)),
("whitespace or control", \c -> isSpace c || isControl c),
("non-ASCII", not . isAscii)
]
@@ -0,0 +1,181 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module BadgeService.StoreReceipts.Apple
( verifyAppleTransaction,
readAppleRoot,
)
where
import BadgeService.StoreReceipts (StoreRefusal (..), VerifiedStoreTransaction (..))
import Control.Exception (IOException, try)
import Control.Monad (guard, unless)
import Crypto.Hash.Algorithms (SHA256 (..))
import Crypto.Number.Serialize (os2ip)
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Types as ECC
import qualified Data.Aeson as J
import qualified Data.Aeson.KeyMap as JM
import qualified Data.Aeson.Types as JT
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base64.URL as B64U
import Data.Foldable (toList)
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word32)
import Data.X509
import Data.X509.EC (unserializePoint)
import Data.X509.Validation (SignatureFailure (..), SignatureVerification (..), verifySignedSignature)
import Simplex.Chat.PaymentService.Types (CurrencyAmount (..))
import Simplex.Messaging.Util (eitherToMaybe)
verifyAppleTransaction :: SignedCertificate -> Text -> Text -> Either StoreRefusal VerifiedStoreTransaction
verifyAppleTransaction root ourBundleId jws = case T.splitOn "." jws of
[header, payload, signature] -> do
leaf <- signingChain root =<< certificateChain header
sig <- jwsSignature signature
key <- leafKey leaf
unless (ECDSA.verify SHA256 key sig (encodeUtf8 $ header <> "." <> payload)) $
refused "the signature does not verify"
tx <- either (const $ failed "the payload Apple signed is not a transaction") Right $ do
o <- maybe (Left "not base64url JSON") Right $ jsonObject payload
JT.parseEither appleTransactionP o
transaction ourBundleId tx
_ -> refused "not three dot-separated parts"
-- | A header or chain in a shape Apple may yet adopt proves no forgery, so it fails rather than refuses.
certificateChain :: Text -> Either StoreRefusal [ByteString]
certificateChain header = do
o <- maybe (refused "the header is not base64url JSON") Right $ jsonObject header
case JM.lookup "alg" o of
Just (J.String "ES256") -> Right ()
_ -> failed "the header does not name ES256"
case JM.lookup "x5c" o of
Just (J.Array certs) -> traverse der $ toList certs
_ -> failed "the header carries no x5c chain"
where
der = \case
J.String c | Right bs <- B64.decode (encodeUtf8 c) -> Right bs
_ -> refused "an x5c certificate is not base64"
-- | The root in the chain is ignored: trust comes from the configured one alone.
signingChain :: SignedCertificate -> [ByteString] -> Either StoreRefusal SignedCertificate
signingChain root = \case
[leafDer, intermediateDer, _] -> do
leaf <- certificate leafDer
intermediate <- certificate intermediateDer
-- the configured root may be stale or wrong as likely as the receipt forged, so this retries rather than refuses
unless (signedBy root intermediate) $ failed "the intermediate is not signed by the configured root"
case verifySignedSignature leaf (certPubKey $ getCertificate intermediate) of
SignaturePass -> Right ()
SignatureFailed SignatureInvalid -> refused "the leaf is not signed by the intermediate"
SignatureFailed _ -> failed "the intermediate's key cannot check the leaf's signature algorithm"
-- Apple issues other certificates under this root, developers' among them; only these two mark the receipt-signing chain
unless (marked receiptSigningLeaf leaf && marked appleIntermediate intermediate) $
failed "Apple issued this chain, but not to sign receipts"
pure leaf
_ -> failed "x5c is not leaf, intermediate and root"
where
certificate = either (const $ failed "an x5c certificate does not decode") Right . decodeSignedCertificate
signedBy issuer cert = verifySignedSignature cert (certPubKey $ getCertificate issuer) == SignaturePass
marked oid cert = case certExtensions (getCertificate cert) of
Extensions (Just exts) -> any ((== oid) . extRawOID) exts
Extensions Nothing -> False
receiptSigningLeaf = [1, 2, 840, 113635, 100, 6, 11, 1]
appleIntermediate = [1, 2, 840, 113635, 100, 6, 2, 1]
leafKey :: SignedCertificate -> Either StoreRefusal ECDSA.PublicKey
leafKey leaf = case certPubKey (getCertificate leaf) of
PubKeyEC (PubKeyEC_Named ECC.SEC_p256r1 pt) | Just p <- unserializePoint p256 pt -> Right $ ECDSA.PublicKey p256 p
_ -> failed "the leaf Apple issued holds no P-256 key"
where
p256 = ECC.getCurveByName ECC.SEC_p256r1
-- | JWS carries ES256 as r and s, 32 bytes each, not the DER a certificate uses.
jwsSignature :: Text -> Either StoreRefusal ECDSA.Signature
jwsSignature s = case B64U.decodeUnpadded (encodeUtf8 s) of
Right bs | B.length bs == 64 -> let (r, s') = B.splitAt 32 bs in Right $ ECDSA.Signature (os2ip r) (os2ip s')
_ -> refused "the signature is not 64 base64url bytes"
data AppleTransaction = AppleTransaction
{ transactionId :: Text,
productId :: Text,
bundleId :: Text,
environment :: Text,
quantity :: Int,
revoked :: Bool,
price :: Maybe Integer,
currency :: Maybe Text
}
appleTransactionP :: J.Object -> JT.Parser AppleTransaction
appleTransactionP o = do
transactionId <- o J..: "transactionId"
productId <- o J..: "productId"
bundleId <- o J..: "bundleId"
environment <- o J..: "environment"
quantity <- o J..: "quantity"
revoked <- isJust <$> (o J..:? "revocationDate" :: JT.Parser (Maybe J.Value))
price <- o J..:? "price"
currency <- o J..:? "currency"
pure AppleTransaction {transactionId, productId, bundleId, environment, quantity, revoked, price, currency}
transaction :: Text -> AppleTransaction -> Either StoreRefusal VerifiedStoreTransaction
transaction ourBundleId AppleTransaction {transactionId, productId, bundleId, environment, quantity, revoked, price, currency}
-- the configured bundle id may be the wrong one, and refusing for good would destroy every genuine purchase
| bundleId /= ourBundleId = failed "another app's bundle id, or ours misconfigured"
| revoked = refused "refunded or revoked"
| otherwise = do
testPurchase <- case environment of
"Production" -> Right False
"Sandbox" -> Right True
_ -> failed "an environment this verifier does not know"
Right
VerifiedStoreTransaction
{ transactionRef = transactionId,
productId,
quantity,
testPurchase,
paid = paidOf price currency
}
-- | Apple's price is in milliunits of the currency, whatever its minor unit.
paidOf :: Maybe Integer -> Maybe Text -> Maybe (CurrencyAmount, Text)
paidOf price_ currency_ = do
milliunits <- price_
code <- currency_
digits <- minorUnitDigits code
let (minor, rest) = (milliunits * 10 ^ digits) `divMod` 1000
guard $ rest == 0 && minor >= 0 && minor <= toInteger (maxBound :: Word32)
pure (CurrencyAmount $ fromInteger minor, code)
-- | ISO 4217 as of its 2026-09-17 list; four-digit and non-currency codes are not recorded.
minorUnitDigits :: Text -> Maybe Integer
minorUnitDigits c
| c `elem` ["BIF", "CLP", "DJF", "GNF", "ISK", "JPY", "KMF", "KRW", "PYG", "RWF", "UGX", "VND", "VUV", "XAF", "XOF", "XPF"] = Just 0
| c `elem` ["BHD", "IQD", "JOD", "KWD", "LYD", "OMR", "TND"] = Just 3
| c `elem` ["CLF", "UYW", "UYI", "XAG", "XAU", "XBA", "XBB", "XBC", "XBD", "XDR", "XPD", "XPT", "XSU", "XTS", "XUA", "XXX"] = Nothing
| T.length c == 3 && T.all (\x -> x >= 'A' && x <= 'Z') c = Just 2
| otherwise = Nothing
jsonObject :: Text -> Maybe J.Object
jsonObject part = J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 part)
refused :: Text -> Either StoreRefusal a
refused = Left . SRInvalid
failed :: Text -> Either StoreRefusal a
failed = Left . SRVerifierFailed . ("apple verifier: " <>)
readAppleRoot :: FilePath -> IO (Either String SignedCertificate)
readAppleRoot path =
try (B.readFile path) >>= \case
Left (_ :: IOException) -> pure $ Left $ path <> ": could not be read"
Right der -> pure $ either (const $ Left $ path <> ": is not a DER certificate") Right $ decodeSignedCertificate der
@@ -0,0 +1,233 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module BadgeService.StoreReceipts.Google (playStoreVerifier) where
import BadgeService.Config (PlayStoreConfig (..))
import BadgeService.StoreReceipts (StoreRefusal (..), VerifiedStoreTransaction (..))
import Control.Concurrent.STM
import Control.Exception (IOException, try)
import Crypto.Hash.Algorithms (SHA256 (..))
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as RSA
import qualified Data.Aeson as J
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64.URL as B64U
import qualified Data.ByteString.Lazy as LB
import Data.Functor (($>))
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Data.X509 (PrivKey (..))
import Data.X509.Memory (readKeyFileFromMemory)
import Network.HTTP.Client
( HttpException (..),
Manager,
Request (..),
RequestBody (..),
Response (..),
brReadSome,
parseRequest,
withResponse,
)
import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Types (Status (..), hAuthorization, hContentType, methodPost, renderSimpleQuery)
import Simplex.Chat.PaymentService (googlePurchaseRef)
import Simplex.Messaging.Util (tshow)
data ServiceAccount = ServiceAccount {clientEmail :: Text, privateKey :: RSA.PrivateKey}
data PlayEnv = PlayEnv
{ config :: PlayStoreConfig,
account :: ServiceAccount,
manager :: Manager,
accessToken :: TVar (Maybe (ByteString, UTCTime))
}
playStoreVerifier :: PlayStoreConfig -> IO (Either String (Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction), Text -> Text -> IO (Either StoreRefusal ())))
playStoreVerifier config@PlayStoreConfig {gServiceAccountFile} =
readServiceAccount gServiceAccountFile >>= \case
Left e -> pure $ Left e
Right account -> do
manager <- newTlsManager
accessToken <- newTVarIO Nothing
let env = PlayEnv {config, account, manager, accessToken}
pure $ Right (verifyPurchase env, acknowledgePurchase env)
readServiceAccount :: FilePath -> IO (Either String ServiceAccount)
readServiceAccount path =
try (B.readFile path) >>= \case
Left (_ :: IOException) -> pure $ Left $ path <> ": could not be read"
Right s -> pure $ case J.decodeStrict' s of
Just (ServiceAccountFile clientEmail pem) -> case readKeyFileFromMemory (encodeUtf8 pem) of
[PrivKeyRSA privateKey] -> Right ServiceAccount {clientEmail, privateKey}
_ -> Left $ path <> ": private_key is not one RSA key"
Nothing -> Left $ path <> ": is not a service account key with client_email and private_key"
data ServiceAccountFile = ServiceAccountFile Text Text
instance J.FromJSON ServiceAccountFile where
parseJSON = J.withObject "service account key" $ \o -> ServiceAccountFile <$> o J..: "client_email" <*> o J..: "private_key"
verifyPurchase :: PlayEnv -> Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)
verifyPurchase env productId token = (>>= purchaseVerdict productId token) <$> readPurchase env productId token
-- | Acknowledged, never consumed: consuming drops the purchase from the app's purchase query,
-- which is how the app finds a purchase it has not yet settled.
acknowledgePurchase :: PlayEnv -> Text -> Text -> IO (Either StoreRefusal ())
acknowledgePurchase env productId token =
readPurchase env productId token >>= \case
Left refusal -> pure $ Left $ acknowledging refusal
Right ProductPurchase {alreadyAcknowledged = True} -> pure $ Right ()
Right _ -> bimap acknowledging (const ()) <$> playCall env (\req -> req {method = methodPost}) (purchaseUrl env productId token <> ":acknowledge")
where
acknowledging = \case
SRUnreachable reason -> SRUnreachable $ "acknowledging: " <> reason
SRVerifierFailed reason -> SRVerifierFailed $ "acknowledging: " <> reason
refusal -> refusal
readPurchase :: PlayEnv -> Text -> Text -> IO (Either StoreRefusal ProductPurchase)
readPurchase env productId token = (>>= decoded) <$> playCall env id (purchaseUrl env productId token)
where
decoded = either (const $ Left $ SRVerifierFailed "could not read Play's purchase record") Right . J.eitherDecode'
purchaseUrl :: PlayEnv -> Text -> Text -> Text
purchaseUrl PlayEnv {config = PlayStoreConfig {gApiHost, gPackageName}} productId token =
T.intercalate "/" [gApiHost, "androidpublisher/v3/applications", gPackageName, "purchases/products", productId, "tokens", token]
playCall :: PlayEnv -> (Request -> Request) -> Text -> IO (Either StoreRefusal LB.ByteString)
playCall env@PlayEnv {accessToken} prepare url =
bearerToken env >>= \case
Left refusal -> pure $ Left refusal
Right bearer ->
playRequest env (\req -> (prepare req) {requestHeaders = [(hAuthorization, "Bearer " <> bearer)]}) url >>= \case
Left refusal -> pure $ Left refusal
Right (code, body) | code >= 200 && code < 300 -> pure $ Right body
Right (401, _) -> atomically (writeTVar accessToken Nothing) $> Left (SRVerifierFailed "Play refused this service's access token")
Right (403, _) -> pure $ Left $ SRVerifierFailed "the service account lacks the Play Console permission for this call"
-- a 404 among them, which Play may answer for a token it issued but has not yet recorded
Right (code, _) -> pure $ Left $ SRUnreachable $ "Play answered HTTP " <> tshow code
purchaseVerdict :: Text -> Text -> ProductPurchase -> Either StoreRefusal VerifiedStoreTransaction
purchaseVerdict productId token ProductPurchase {purchaseState, purchaseType, purchaseQuantity, purchaseProductId}
| maybe False (/= productId) purchaseProductId = Left $ SRVerifierFailed "Play answered about another product"
| otherwise = case purchaseState of
0 -> purchased <$> testPurchaseOf purchaseType
-- a canceled purchase stays canceled, and buying again issues a new token
1 -> Left $ SRInvalid "canceled"
2 -> Left SRPending
s -> Left $ SRVerifierFailed $ "an unknown purchaseState " <> tshow s
where
purchased testPurchase =
VerifiedStoreTransaction
{ transactionRef = googlePurchaseRef token,
productId,
quantity = fromMaybe 1 purchaseQuantity,
testPurchase,
paid = Nothing
}
testPurchaseOf = \case
Nothing -> Right False
Just 0 -> Right True
-- a promo code, which only this app's developer can issue
Just 1 -> Right False
Just t -> Left $ SRVerifierFailed $ "a purchaseType this service does not credit: " <> tshow t
data ProductPurchase = ProductPurchase
{ purchaseState :: Int,
purchaseType :: Maybe Int,
purchaseQuantity :: Maybe Int,
purchaseProductId :: Maybe Text,
alreadyAcknowledged :: Bool
}
instance J.FromJSON ProductPurchase where
parseJSON = J.withObject "ProductPurchase" $ \o -> do
purchaseState <- o J..: "purchaseState"
purchaseType <- o J..:? "purchaseType"
purchaseQuantity <- o J..:? "quantity"
purchaseProductId <- o J..:? "productId"
acknowledgementState <- o J..:? "acknowledgementState"
consumptionState <- o J..:? "consumptionState"
let alreadyAcknowledged = acknowledgementState == Just (1 :: Int) || consumptionState == Just (1 :: Int)
pure ProductPurchase {purchaseState, purchaseType, purchaseQuantity, purchaseProductId, alreadyAcknowledged}
bearerToken :: PlayEnv -> IO (Either StoreRefusal ByteString)
bearerToken env@PlayEnv {accessToken} = do
now <- getCurrentTime
readTVarIO accessToken >>= \case
Just (bearer, validUntil) | now < validUntil -> pure $ Right bearer
_ -> requestAccessToken env now
requestAccessToken :: PlayEnv -> UTCTime -> IO (Either StoreRefusal ByteString)
requestAccessToken env@PlayEnv {config = PlayStoreConfig {gTokenUrl}, account, accessToken} now =
signedAssertion account gTokenUrl now >>= \case
Nothing -> pure $ Left $ SRVerifierFailed "could not sign the service account assertion"
Just assertion ->
playRequest env (tokenForm assertion) gTokenUrl >>= \case
Left refusal -> pure $ Left refusal
Right (200, body) -> case J.eitherDecode' body of
Right (GrantedToken bearer expiresIn) -> do
atomically $ writeTVar accessToken $ Just (bearer, addUTCTime (fromIntegral expiresIn - refreshMargin) now)
pure $ Right bearer
Left _ -> pure $ Left $ SRVerifierFailed "could not read Google's access token"
Right (code, _)
| code >= 500 || code == 429 -> pure $ Left $ SRUnreachable $ "Google's token endpoint answered HTTP " <> tshow code
| otherwise -> pure $ Left $ SRVerifierFailed $ "Google refused the service account assertion: HTTP " <> tshow code
where
tokenForm assertion req =
req
{ method = methodPost,
requestHeaders = [(hContentType, "application/x-www-form-urlencoded")],
requestBody = RequestBodyBS $ renderSimpleQuery False [("grant_type", "urn:ietf:params:oauth:grant-type:jwt-bearer"), ("assertion", assertion)]
}
refreshMargin :: NominalDiffTime
refreshMargin = 300
data GrantedToken = GrantedToken ByteString Int
instance J.FromJSON GrantedToken where
parseJSON = J.withObject "access token" $ \o -> GrantedToken . encodeUtf8 <$> o J..: "access_token" <*> o J..: "expires_in"
signedAssertion :: ServiceAccount -> Text -> UTCTime -> IO (Maybe ByteString)
signedAssertion ServiceAccount {clientEmail, privateKey} audience now =
either (const Nothing) (\sig -> Just $ signingInput <> "." <> B64U.encodeUnpadded sig) <$> RSA.signSafer (Just SHA256) privateKey signingInput
where
issuedAt = floor (utcTimeToPOSIXSeconds now) :: Int64
signingInput = segment (J.object ["alg" J..= ("RS256" :: Text), "typ" J..= ("JWT" :: Text)]) <> "." <> segment claims
claims =
J.object
[ "iss" J..= clientEmail,
"scope" J..= ("https://www.googleapis.com/auth/androidpublisher" :: Text),
"aud" J..= audience,
"iat" J..= issuedAt,
"exp" J..= (issuedAt + 3600)
]
segment = B64U.encodeUnpadded . LB.toStrict . J.encode
playRequest :: PlayEnv -> (Request -> Request) -> Text -> IO (Either StoreRefusal (Int, LB.ByteString))
playRequest PlayEnv {manager} prepare url =
try (parseRequest (T.unpack url) >>= \req -> withResponse (prepare req) manager readBody) >>= \case
-- http-client's exceptions show the request, whose URL can hold the purchase token, so only the kind is kept
Left (e :: HttpException) -> pure $ Left $ SRUnreachable $ "request to Google failed: " <> failureKind e
Right (code, body)
| LB.length body > maxPlayBytes -> pure $ Left $ SRVerifierFailed $ "Google answered HTTP " <> tshow code <> " with over " <> tshow maxPlayBytes <> " bytes"
| otherwise -> pure $ Right (code, body)
where
readBody resp = (statusCode (responseStatus resp),) <$> brReadSome (responseBody resp) (fromIntegral maxPlayBytes + 1)
failureKind = \case
HttpExceptionRequest _ content -> T.pack $ takeWhile (/= ' ') $ show content
InvalidUrlException _ _ -> "InvalidUrlException"
maxPlayBytes :: Int64
maxPlayBytes = 1024 * 1024
@@ -18,24 +18,24 @@ import Simplex.Messaging.Util (eitherToMaybe)
mockStoreVerifier :: StoreVerifier
mockStoreVerifier = noStoreVerifier {verifyApple = Just mockApple, verifyGoogle = Just mockGoogle}
mockApple :: Text -> Either Text VerifiedStoreTransaction
mockApple :: Text -> Either StoreRefusal VerifiedStoreTransaction
mockApple signed = case T.splitOn "." signed of
[_, payload, _] -> do
o <- case J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload) of
Just (J.Object obj) -> Right obj
_ -> Left "payload is not base64url JSON"
_ -> Left $ SRInvalid "payload is not base64url JSON"
productId <- case JM.lookup "productId" o of
Just (J.String p) -> Right p
_ -> Left "no productId"
transactionRef <- maybe (Left "no transactionId") Right $ appleTransactionId signed
_ -> Left $ SRInvalid "no productId"
transactionRef <- maybe (Left $ SRInvalid "no transactionId") Right $ appleTransactionId signed
Right $ vouched transactionRef productId
_ -> Left "not three dot-separated parts"
_ -> Left $ SRInvalid "not three dot-separated parts"
mockGoogle :: Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)
mockGoogle productId token = pure $ Right $ vouched (googlePurchaseRef token) productId
vouched :: Text -> Text -> VerifiedStoreTransaction
vouched transactionRef productId =
-- not a test purchase, though nothing was paid: a test purchase is refused as receipt_invalid, which is
-- not a test purchase, though nothing was paid: a test purchase is refused as test_purchase, which is
-- terminal and drops the client's keys, so every dev purchase would fail for good
VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase = False, paid = Nothing}
+1
View File
@@ -487,6 +487,7 @@ CredentialNotVerified:
- "code_expired"
- "receipt_invalid"
- "receipt_used"
- "test_purchase"
- "internal"
+22 -7
View File
@@ -34,12 +34,27 @@ The client never states what is signed. The tier is that of whatever funded the
- `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 other keys have taken all its uses (a code has one use unless issued with more), `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 response `receipt` is the recovery bearer secret (model § recovery); the service stores its hash; lifetime badges receive none.
- A store transaction is claimed by its own id, read from the evidence before verification, and credited only when the verified transaction carries that same id. A receipt already credited to the signing key is answered from the record, without asking the store.
- Errors: `receipt_invalid`, `payment_pending`, `provider_unavailable` — see the classes below; `receipt_used` when another key was credited with it; `product_unavailable` for a product this service does not price; `provider_not_configured` when this deployment has no verifier for the store, terminal for the request since retrying cannot deploy one. `receipt_invalid` and `receipt_used` are the only answers on which the client drops the keys it signed with and finishes the store transaction. Every other answer records nothing and leaves the purchase with its keys, to be presented again at the next trigger.
- **Which class an answer belongs to.** The two mistakes do not cost the same, so when it is not certain, answer unreachable. `receipt_invalid` tells the client the purchase is dead: it drops the keys it signed with and finishes the store transaction — consumed on Play, finished on StoreKit — and nothing can present it again, so a buyer answered this by mistake has paid for a badge they can never receive. Answering unreachable by mistake costs one more verification request each time the app presents the purchase again, and a Play purchase left unacknowledged for three days is refunded to the buyer.
- **Terminal**, `receipt_invalid` — the store answered about this purchase and cannot change its mind: an Apple signature or certificate chain that does not verify, another app's bundle id, a test purchase (Apple Sandbox, Play `purchaseType` test), a refunded or revoked purchase, Play `purchaseState` canceled.
- **Pending**, `payment_pending` — Play `purchaseState` pending.
- **Unreachable**, `provider_unavailable` — the store was not asked or did not answer: network, timeout, 5xx, quota, this service's own auth or permission failures, and every Play error response, a 404 from `purchases.products.get` or `purchases.subscriptionsv2.get` and a 400 or 410 calling the token invalid included. A 404 decides nothing: Play answers it both for a token it has just issued and not yet recorded, and for one that was never a purchase. Only a purchase record is a verdict. A token whose characters this service will not send is never sent, so Play never answers about it — and Play documents no token grammar, so that check is our guess, not its verdict. A product id outside the characters Play does document is terminal, since no product of this app can have one.
- Apple is verified offline, so it has no "not yet" and a negative answer about the signed evidence is terminal. Two things are not the store's answer and leave the client holding the purchase: the verifier's own failure, such as a root certificate it could not load, which is `internal`; and a product this service does not price, which is `product_unavailable` — the verifier vouched for the transaction either way.
- Errors: `receipt_invalid`, `test_purchase`, `payment_pending`, `provider_unavailable` — see the classes below; `receipt_used` when another key was credited with it; `product_unavailable` for a product this service does not price; `provider_not_configured` when this deployment has no verifier for the store. `receipt_invalid`, `test_purchase` and `receipt_used` are the only answers on which the client drops the keys it signed with and finishes the store transaction. Every other answer records nothing and leaves the purchase with its keys, to be presented again at the next trigger.
- **Which class an answer belongs to.** The two mistakes do not cost the same, so when it is not certain, answer unreachable. `receipt_invalid` tells the client the purchase is dead: it drops the keys it signed with and finishes the store transaction — consumed on Play, finished on StoreKit — and nothing can present it again, so a buyer answered this by mistake has paid for a badge they can never receive. Answering unreachable by mistake costs one more verification request each time the app presents the purchase again, and a Play purchase left unacknowledged for three days is refunded to the buyer. It also locks the buyer out: the app offers no Buy while a purchase is open, so until that receipt settles the profile holding it cannot buy any badge, and an answer that never changes leaves it that way for good.
- **Terminal**, `receipt_invalid` — only a verdict no later attempt could change: the store answered about this purchase and cannot change its mind, or the evidence can never verify. Anything that might answer differently later — the store's lag, an outage, this service's own misconfiguration or bug, a shape of evidence this service does not know yet — is one of the other classes.
- **Terminal and named**, `test_purchase` — the store vouched for a purchase that cost nothing: Apple's `Sandbox`, or Play's `purchaseType` test. It is separated from `receipt_invalid` for one reason: the device that made the purchase already knows it was a test one, so naming it reveals nothing a forger could iterate on, and it lets the app say why instead of reporting a generic failure. Every other refusal stays lumped together for exactly that reason.
- **Pending**, `payment_pending` — a real purchase the store has not settled.
- **Unreachable**, `provider_unavailable` — the store was not asked or did not answer.
- **Internal**, `internal` — this service's own failure, never the store's answer.
- **App Store.** Apple is verified offline, so it has no "not yet".
- `receipt_invalid`: a JWS that is not three base64url parts or names no `transactionId`; an `x5c` certificate that is not base64; a JWS signature that is not 64 bytes; a leaf whose signature does not verify against the intermediate; a JWS signature that does not verify against the leaf; a transaction with a `revocationDate`, refunded or revoked.
- `test_purchase`: refused by the service after the verifier vouched for it, a `Sandbox` transaction.
- `internal`: whatever this service's own configuration decides — an intermediate whose signature does not verify against the configured root, and another app's `bundleId`, since the configured root or bundle id may be the wrong one as likely as the receipt forged; a transaction from Xcode's StoreKit testing, which Xcode signs and not the App Store, so the configured root does not verify it; evidence in a shape this service does not know — a header that does not name `ES256` or carries no `x5c` of exactly three certificates, a certificate that does not decode, a leaf signature the intermediate's key cannot check, an algorithm or key type the library does not support, a chain without Apple's receipt-signing marker extensions, a leaf key that is not P-256, a payload with a missing or mistyped field or an unknown `environment`; the verifier's own failure or overrun; and, refused by the service, a verified transaction other than the one claimed, or a quantity other than 1.
- `product_unavailable`: a product this service does not price — the verifier vouched for the transaction either way.
- `provider_not_configured`: the deployment has no `[apple]` section.
- **Google Play.** Only a purchase record is a verdict.
- `receipt_invalid`: `purchaseState` canceled, which a purchase token never leaves, and a product id outside the characters Play documents, since no product of this app can have one.
- `test_purchase`: refused by the service after the verifier vouched for it, `purchaseType` test, a license tester's purchase.
- `payment_pending`: `purchaseState` pending.
- `provider_unavailable`: network failure or timeout, and every error response from `purchases.products.get` but 401 and 403 — a 404 included, which Play may answer both for a token it has just issued and not yet recorded and for one that was never a purchase, and a 400 or 410 calling the token invalid; a 5xx or 429 from the token endpoint; and a token this service will not send — whose characters fall outside the grammar it accepts, which is our guess since Play documents none, or which is only dots, which a URL path would resolve away.
- `internal`: Google refusing this service's credentials or permissions — a 401 or 403 from `purchases.products.get`, and any other refusal from the token endpoint; a response that cannot be read, is too large, or names another product; a `purchaseState` this service does not know; and a `purchaseType` other than test or promo — a promo code, which only this app's developer issues, is credited like a purchase.
- `product_unavailable` and `provider_not_configured` as for the App Store, the latter without a `[google]` section.
- Before crediting a purchase of a product it prices, the service acknowledges it, unless Play already reports it acknowledged or consumed. It acknowledges and never consumes, so the app's purchase query still lists the purchase. The app may not be honest, and only acknowledgement stops Play refunding the purchase after three days, so nothing is credited unacknowledged. A failed acknowledgement credits nothing and is answered like a failed read — `provider_unavailable` when Play does not answer, `internal` when it refuses this service, both logged with "acknowledging" in the reason — and the app presents the purchase again. A deployment whose service account lacks the permission to acknowledge therefore answers `internal` to every Play purchase the app has not already acknowledged itself.
- 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).
@@ -70,4 +85,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` — all its uses taken by other keys; `code_expired` — past its redemption deadline. `receipt_invalid` covers forged, malformed, another app's, refunded and test receipts alike, so a guesser learns nothing from the difference; `receipt_used` — credited to another key; `provider_not_configured` — no verifier for that store is deployed, so the receipt is neither credited nor refused. 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` — all its uses taken by other keys; `code_expired` — past its redemption deadline. `receipt_invalid` covers forged, malformed and refunded receipts alike, so a guesser learns nothing from the difference; `test_purchase` is named apart from them because the device that bought it already knows; `receipt_used` — credited to another key; `provider_not_configured` — no verifier for that store is deployed, so the receipt is neither credited nor refused. All other codes are terminal for the attempted command.
@@ -325,6 +325,7 @@ export enum BadgeServiceErrorCode {
Code_expired = "code_expired",
Receipt_invalid = "receipt_invalid",
Receipt_used = "receipt_used",
Test_purchase = "test_purchase",
Internal = "internal",
}
@@ -224,7 +224,7 @@ BadgeRedeemError = (
BadgeRedeemError_Tag = Literal["invalidCode", "invalidReceipt", "serviceNotConfigured", "badgeActive", "serviceError", "invalidResponse", "unknownKeyIndex", "credentialNotVerified"]
BadgeServiceErrorCode = Literal["bad_request", "unsupported_version", "unknown_purchase_key", "unknown_offer_id", "offer_disabled", "offer_mismatch", "product_unavailable", "payment_not_entitled", "payment_pending", "provider_unavailable", "provider_not_configured", "rate_limited", "code_invalid", "code_used", "code_expired", "receipt_invalid", "receipt_used", "internal"]
BadgeServiceErrorCode = Literal["bad_request", "unsupported_version", "unknown_purchase_key", "unknown_offer_id", "offer_disabled", "offer_mismatch", "product_unavailable", "payment_not_entitled", "payment_pending", "provider_unavailable", "provider_not_configured", "rate_limited", "code_invalid", "code_used", "code_expired", "receipt_invalid", "receipt_used", "test_purchase", "internal"]
BadgeStatus = Literal["active", "expired", "expiredOld", "failed", "unknownKey"]
@@ -36,6 +36,22 @@ session_minutes = 60
waiting_seconds = 3
idle_seconds = 60
; optional; without it every App Store receipt is answered provider_not_configured, which the app retries later.
; root_certificate is https://www.apple.com/certificateauthority/AppleRootCA-G3.cer, in DER;
; uncomment its mount in compose.yml.
;[apple]
;bundle_id = chat.simplex.app
;root_certificate = /etc/simplex-badge-service/AppleRootCA-G3.cer
; optional; without it every Play receipt is answered provider_not_configured, which the app retries later.
; service_account_file is the JSON key of a service account with the Play Console permissions "View
; financial data, orders, and cancellation survey responses" and "Manage orders and subscriptions", to
; read and acknowledge purchases. Without the second, a purchase the app has not already acknowledged
; itself is answered internal until the permission is granted. Uncomment its mount in compose.yml; the file must be readable by the service's user alone.
;[google]
;package_name = chat.simplex.app
;service_account_file = /etc/simplex-badge-service/play-service-account.json
; index is the one clients verify against; private_key is from `simplex-chat badge keygen`.
; To rotate, change both together, once clients trust the new index.
[issuer]
@@ -54,6 +70,7 @@ private_key = replace-me
;description = Welcome to the badges group
; local testing only, in both run modes: accepts any well-formed App Store or Play receipt without
; verifying it, so anyone who can reach this service can mint badges
; verifying it, so anyone who can reach this service can mint badges. The service refuses to start
; with this on beside an [apple] or [google] section.
[dev]
accept_unverified_store_receipts = off
+2
View File
@@ -20,5 +20,7 @@ services:
- "/etc/simplex-badge-service/badge_service.ini"
volumes:
- ./badge_service.ini:/etc/simplex-badge-service/badge_service.ini:ro
# - ./AppleRootCA-G3.cer:/etc/simplex-badge-service/AppleRootCA-G3.cer:ro
# - ./play-service-account.json:/etc/simplex-badge-service/play-service-account.json:ro
- ./web:/srv/webapp
stop_grace_period: 10s
+13
View File
@@ -447,6 +447,8 @@ executable simplex-badge-service
BadgeService.Store.Invoices
BadgeService.Store.Migrate
BadgeService.StoreReceipts
BadgeService.StoreReceipts.Apple
BadgeService.StoreReceipts.Google
BadgeService.StoreReceipts.Mock
BadgeService.Waiters
BadgeService.Web.Server
@@ -459,6 +461,9 @@ executable simplex-badge-service
, base64-bytestring >=1.0 && <1.3
, containers ==0.6.*
, crypton ==0.34.*
, crypton-x509 ==1.7.*
, crypton-x509-store ==1.6.*
, crypton-x509-validation ==1.6.*
, directory ==1.3.*
, filepath ==1.4.*
, http-client ==0.7.*
@@ -740,6 +745,8 @@ test-suite simplex-chat-test
BadgeService.Store.Invoices
BadgeService.Store.Migrate
BadgeService.StoreReceipts
BadgeService.StoreReceipts.Apple
BadgeService.StoreReceipts.Google
BadgeService.StoreReceipts.Mock
BadgeService.Waiters
BadgeService.Web.Server
@@ -748,10 +755,12 @@ test-suite simplex-chat-test
Bots.BadgeService.CatalogTests
Bots.BadgeService.ConfigTests
Bots.BadgeService.FakeBTCPay
Bots.BadgeService.FakePlay
Bots.BadgeService.FakeStore
Bots.BadgeService.FakeStripe
Bots.BadgeService.GroupIntegrationTests
Bots.BadgeService.GroupTests
Bots.BadgeService.StoreVerifierTests
Bots.BadgeService.StripeTests
Bots.BadgeService.WaitersTests
Bots.BadgeService.WebTests
@@ -798,10 +807,14 @@ test-suite simplex-chat-test
, composition ==1.0.*
, containers ==0.6.*
, crypton ==0.34.*
, crypton-x509 ==1.7.*
, crypton-x509-store ==1.6.*
, crypton-x509-validation ==1.6.*
, deepseq ==1.4.*
, directory ==1.3.*
, filepath ==1.4.*
, generic-random ==1.5.*
, hourglass ==0.2.*
, http-client ==0.7.*
, http-client-tls ==0.3.*
, http-types ==0.12.*
+3
View File
@@ -244,6 +244,7 @@ data BadgeServiceErrorCode
| BSECodeExpired
| BSEReceiptInvalid
| BSEReceiptUsed
| BSETestPurchase -- the store vouched for a purchase that cost nothing: Apple's sandbox, a Play license tester
| BSEInternal
| BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients
deriving (Eq, Show)
@@ -345,6 +346,7 @@ instance TextEncoding BadgeServiceErrorCode where
BSECodeExpired -> "code_expired"
BSEReceiptInvalid -> "receipt_invalid"
BSEReceiptUsed -> "receipt_used"
BSETestPurchase -> "test_purchase"
BSEInternal -> "internal"
BSEUnknown t -> t
textDecode s = Just $ case s of
@@ -365,6 +367,7 @@ instance TextEncoding BadgeServiceErrorCode where
"code_expired" -> BSECodeExpired
"receipt_invalid" -> BSEReceiptInvalid
"receipt_used" -> BSEReceiptUsed
"test_purchase" -> BSETestPurchase
"internal" -> BSEInternal
t -> BSEUnknown t
+1
View File
@@ -5308,6 +5308,7 @@ storeReceiptRefused :: BadgeServiceErrorCode -> Bool
storeReceiptRefused = \case
BSEReceiptInvalid -> True
BSEReceiptUsed -> True
BSETestPurchase -> True
_ -> False
-- | The same reference the service claims a transaction by, read without verifying anything.
+2 -2
View File
@@ -716,7 +716,7 @@ testServiceRetryAfter = do
badgeErrorRetryAfter BSEInternal `shouldBe` Nothing
mapM_
(\code -> badgeErrorRetryAfter code `shouldBe` Nothing)
[BSEBadRequest, BSEUnsupportedVersion, BSEUnknownPurchaseKey, BSECodeInvalid, BSECodeUsed, BSECodeExpired, BSEProviderNotConfigured, BSEUnknown "future_code"]
[BSEBadRequest, BSEUnsupportedVersion, BSEUnknownPurchaseKey, BSECodeInvalid, BSECodeUsed, BSECodeExpired, BSEProviderNotConfigured, BSETestPurchase, BSEUnknown "future_code"]
-- The app shows the recorded failure in a sentence, so an agent error is stored as the agent
-- error and not as the chat error wrapping it, whether or not it can clear on its own.
@@ -901,7 +901,7 @@ testGoogleTokenPath = do
mapM_ (\t -> unsent t `shouldBe` True) ["a/b", "../x", "t?x", "t#x", "t x", ""]
uncalledVerifier :: StoreVerifier
uncalledVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Just $ \_ _ -> error "verifier called", verifyTimeout = 500000}
uncalledVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Just $ \_ _ -> error "verifier called", acknowledgeGoogle = Nothing, verifyTimeout = 500000}
validPlayToken :: T.Text
validPlayToken = "fake-play-token.AO-J1Oz9x2kqE7wYt3"
+67 -4
View File
@@ -28,7 +28,7 @@ import ChatTests.DBUtils
import ChatTests.Utils
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, cancel)
import Control.Concurrent.STM (TQueue, atomically, readTMVar)
import Control.Concurrent.STM (TQueue, atomically, readTMVar, readTQueue)
import Control.Monad (forM_, void, when)
import Control.Exception (finally)
import qualified Data.Aeson as J
@@ -134,6 +134,7 @@ badgeServiceTests = do
it "should refuse a receipt another key was credited with" testStoreReceiptUsed
it "should refuse a receipt the store does not vouch for, with no retry" testStoreReceiptInvalid
it "should write nothing for a pending purchase, and credit it once when it settles" testStorePending
it "should acknowledge a Play purchase before crediting it, and credit nothing when acknowledging fails" testStoreAcknowledgesBeforeCrediting
it "should refuse a product that grants no badge" testStoreUnknownProduct
it "should refuse a store purchase that carries an upgrade" testStoreUpgradeRefused
it "should grant the badge of the product the receipt proves" testStoreBadgeTypeFromProduct
@@ -168,6 +169,7 @@ badgeServiceTests = do
it "should retry a receipt the service could not verify, and credit it with no trigger at all" testStoreReceiptRetried
it "should credit a second receipt while an earlier one waits for the store" testStoreReceiptNotBlocked
it "should answer a refused receipt from the record, sending nothing, and not list it" testStoreRefusalKept
it "should refuse a test purchase for good, and answer it from the record" testStoreTestPurchaseRefused
it "should announce a settlement to an owner that is not active, and print nothing for a hidden one" testStoreSettledOtherProfile
it "should resolve one new transaction handed over twice at once to one record" testStoreReceiptTwoAtOnce
it "should delete a month-old record that will fund no badge, and keep held and credited ones" testStoreReceiptCleanup
@@ -1723,8 +1725,8 @@ testStoreReceiptInvalid ps =
refused (googlePayment "badge_supporter_01" "not-a-purchase") `shouldReturn` (BSEReceiptInvalid, Nothing)
refused SPApple {jws = "not.a.jws"} `shouldReturn` (BSEReceiptInvalid, Nothing)
refused SPApple {jws = unsignedJWS "{\"transactionId\":\"2000000812345699\",\"productId\":\"BADGE_SUPPORTER_01\"}"} `shouldReturn` (BSEReceiptInvalid, Nothing)
-- refused by the service, which the store would have vouched for
refused SPApple {jws = appleSandboxJWS} `shouldReturn` (BSEReceiptInvalid, Nothing)
-- named rather than lumped in with a forgery, since the device that bought it already knows
refused SPApple {jws = appleSandboxJWS} `shouldReturn` (BSETestPurchase, Nothing)
nothingPurchased cc
testStorePending :: HasCallStack => TestParams -> IO ()
@@ -1743,6 +1745,34 @@ testStorePending ps =
rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
storePayments cc `shouldReturn` [("google", Nothing, Nothing, 1)]
testStoreAcknowledgesBeforeCrediting :: HasCallStack => TestParams -> IO ()
testStoreAcknowledgesBeforeCrediting ps = do
acknowledged <- newIORef []
acknowledgement <- newIORef $ Right ()
let acknowledging store = (fakeVerifier store) {acknowledgeGoogle = Just $ \_ token -> modifyIORef' acknowledged (token :) >> readIORef acknowledgement}
withBadgeServiceVerifier ps acknowledging $ \env@BadgeServiceEnv {bsController = cc} -> do
(purchaseKey, masterKey) <- newPurchaseKeys
let purchase payment = serviceCmd env purchaseKey $ purchaseCmd masterKey payment
unsettled <- purchase $ googlePayment "badge_supporter_01" googlePendingToken
fst (refusalOf unsettled) `shouldBe` BSEPaymentPending
unpriced <- purchase $ googlePayment "subscr_badge_supporter_01" googleSubscriptionToken
refusalOf unpriced `shouldBe` (BSEProductUnavailable, Nothing)
readIORef acknowledged `shouldReturn` []
writeIORef acknowledgement $ Left $ SRUnreachable "acknowledging: fake store is down"
unacknowledged <- purchase supporterPlay
refusalOf unacknowledged `shouldSatisfy` \(code, retryAfter) -> code == BSEProviderUnavailable && isJust retryAfter
writeIORef acknowledgement $ Left $ SRVerifierFailed "acknowledging: the service account lacks the Play Console permission for this call"
forbidden <- purchase supporterPlay
refusalOf forbidden `shouldBe` (BSEInternal, Nothing)
nothingPurchased cc
writeIORef acknowledgement $ Right ()
purchased <- purchase supporterPlay
badgeTypeOf purchased `shouldBe` Just BTSupporter
replayed <- purchase supporterPlay
credentialOf replayed `shouldBe` credentialOf purchased
readIORef acknowledged `shouldReturn` replicate 3 googleSupporterToken
rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
testStoreUnknownProduct :: HasCallStack => TestParams -> IO ()
testStoreUnknownProduct ps =
withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do
@@ -2166,6 +2196,18 @@ testStoreRefusalKept ps = do
verifications `shouldReturn` 1
storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)]
testStoreTestPurchaseRefused :: HasCallStack => TestParams -> IO ()
testStoreTestPurchaseRefused ps =
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsStore = FakeStore {appleSandboxJWS}} ->
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
invoiceId <- createInvoice alice 1
let purchase = purchaseWithInvoice 1 invoiceId SPApple {jws = appleSandboxJWS}
alice ##> purchase
alice <### [StartsWith (invoicePurchase "" invoiceId), ConsoleString (refusedLine "" invoiceId "service_error final test_purchase")]
heldStoreReceipts (chatController alice) `shouldReturn` 0
alice ##> purchase
alice <## "cannot get badge: badge service error: test_purchase"
testStoreSettledOtherProfile :: HasCallStack => TestParams -> IO ()
testStoreSettledOtherProfile ps =
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg} ->
@@ -2261,7 +2303,7 @@ testStoreReceiptAfterRestart ps = do
pure invoiceId
writeIORef broken False
withTestChatCfg ps cfg "alice" $ \alice -> do
inAnyOrder alice [["subscribed 1 connections on server localhost"], creditedLines "" invoiceId "1: supporter"]
expectLinesWithin 60 alice (creditedLines "" invoiceId "1: supporter") ["subscribed 1 connections on server localhost"]
heldStoreReceipts (chatController alice) `shouldReturn` 0
createInvoice :: HasCallStack => TestCC -> Int -> IO String
@@ -2330,6 +2372,27 @@ inAnyOrder cc blocks = do
start : _ -> start `isPrefixOf` l
[] -> False
-- | The required lines under one budget in any order, and the tolerated ones only if they come at
-- all: the agent announces UP for a subscription that was still pending in the session answering it
-- (simplexmq processSubOk), so "subscribed N connections" may never be printed, and when it is it
-- races a settlement that arrived in the same batch. getTermLine' would bound each line at 20s.
expectLinesWithin :: HasCallStack => Int -> TestCC -> [String] -> [String] -> IO ()
expectLinesWithin seconds cc@TestCC {termQ, printOutput} required tolerated = go (seconds * 10) required
where
go n outstanding =
100000 `timeout` atomically (readTQueue termQ) >>= \case
Just line -> do
when printOutput $ userName cc >>= \name -> putStrLn $ name <> ": " <> line
case break (`isPrefixOf` line) outstanding of
(earlier, _ : others) -> go n (earlier <> others)
_
| any (`isPrefixOf` line) tolerated -> go n outstanding
| otherwise -> error $ "unexpected " <> show line <> ", awaiting " <> show outstanding
Nothing
| null outstanding -> pure ()
| n > 0 -> go (n - 1) outstanding
| otherwise -> error $ "no line starting one of " <> show outstanding <> " in " <> show seconds <> " seconds"
-- | Counts the Google verifications the service makes, re-arming the one-shot hook each time.
countGoogleVerifications :: IORef (IO ()) -> IO (IO Int)
countGoogleVerifications hook = do
+50
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -51,6 +52,10 @@ badgeConfigTests = describe "badge service config" $ do
it "reads accept_unverified_store_receipts = on" testDevUnverifiedReceiptsOn
it "reads accept_unverified_store_receipts = off" testDevUnverifiedReceiptsOff
it "refuses an accept_unverified_store_receipts that is not on or off" testDevUnverifiedReceiptsNotBoolean
it "configures no store verifier when [apple] and [google] are absent" testStoresAbsent
it "reads [apple] and [google], defaulting Google's endpoints" testStoresRead
it "refuses an incomplete [apple] or [google], naming the key" testStoresIncomplete
it "refuses accept_unverified_store_receipts beside a real store verifier" testDevUnverifiedBesideVerifier
groupConfigTests
fullIni :: T.Text
@@ -380,6 +385,51 @@ testDevUnverifiedReceiptsNotBoolean = withDev "accept_unverified_store_receipts
withDev :: T.Text -> (Either String ServiceConfig -> IO a) -> IO a
withDev keys act = withIni (fullIni <> "[dev]\n" <> keys) $ \p -> readServiceConfig p >>= act
appleIni, googleIni :: T.Text
appleIni = "[apple]\nbundle_id = chat.simplex.app\nroot_certificate = /etc/badges/AppleRootCA-G3.cer\n"
googleIni = "[google]\npackage_name = chat.simplex.app\nservice_account_file = /etc/badges/play.json\n"
testStoresAbsent :: IO ()
testStoresAbsent = withIni fullIni $ \p -> do
Right cfg <- readServiceConfig p
appleStore cfg `shouldBe` Nothing
playStore cfg `shouldBe` Nothing
testStoresRead :: IO ()
testStoresRead = withIni (fullIni <> appleIni <> googleIni) $ \p -> do
Right cfg <- readServiceConfig p
appleStore cfg `shouldBe` Just AppleStoreConfig {aBundleId = "chat.simplex.app", aRootCertificate = "/etc/badges/AppleRootCA-G3.cer"}
playStore cfg
`shouldBe` Just
PlayStoreConfig
{ gPackageName = "chat.simplex.app",
gServiceAccountFile = "/etc/badges/play.json",
gApiHost = "https://androidpublisher.googleapis.com",
gTokenUrl = "https://oauth2.googleapis.com/token"
}
testStoresIncomplete :: IO ()
testStoresIncomplete = do
refused (T.replace "bundle_id = chat.simplex.app\n" "" appleIni) "apple.bundle_id"
refused (T.replace "root_certificate = /etc/badges/AppleRootCA-G3.cer\n" "" appleIni) "apple.root_certificate"
refused (T.replace "package_name = chat.simplex.app\n" "" googleIni) "google.package_name"
refused (T.replace "service_account_file = /etc/badges/play.json\n" "" googleIni) "google.service_account_file"
where
refused section key =
withIni (fullIni <> section) readServiceConfig >>= \case
Left e -> e `shouldContain` key
Right _ -> expectationFailure ("an incomplete section must fail at boot, naming " <> key)
testDevUnverifiedBesideVerifier :: IO ()
testDevUnverifiedBesideVerifier =
mapM_
( \stores ->
withIni (fullIni <> stores <> "[dev]\naccept_unverified_store_receipts = on\n") readServiceConfig >>= \case
Left e -> e `shouldContain` "accept_unverified_store_receipts"
Right _ -> expectationFailure "a service that verifies store receipts must not also accept unverified ones"
)
[appleIni, googleIni]
parseIni :: T.Text -> IO (Either String ServiceConfig)
parseIni t = withIni t readServiceConfig
+181
View File
@@ -0,0 +1,181 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Bots.BadgeService.FakePlay
( FakePlay (..),
PlayAnswer (..),
withFakePlay,
answerPurchase,
answerAcknowledgements,
answerTokenRequests,
grantTokensFor,
fakePackageName,
)
where
import BadgeService.Config (PlayStoreConfig (..))
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM
import Control.Monad (forever)
import Crypto.Hash.Algorithms (SHA256 (..))
import Crypto.Number.Serialize (i2osp)
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as RSA
import qualified Data.Aeson as J
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base64.URL as B64U
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as LB
import qualified Data.Map.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Network.HTTP.Types (Status, badRequest400, hAuthorization, hContentType, methodGet, methodPost, mkStatus, notFound404, ok200, parseSimpleQuery, unauthorized401)
import Network.Wai (Application, Response, pathInfo, requestHeaders, requestMethod, responseLBS, strictRequestBody)
import qualified Network.Wai.Handler.Warp as Warp
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import UnliftIO.Temporary (withTempDirectory)
data PlayAnswer = PlayRecord J.Value | PlayBody LB.ByteString | PlayStatus Int | PlayHang
data FakePlay = FakePlay
{ fpConfig :: PlayStoreConfig,
fpAnswers :: TVar (M.Map Text PlayAnswer),
-- a status the token endpoint answers instead of granting
fpTokenRefusal :: TVar (Maybe Int),
fpTokenSeconds :: TVar Int,
fpGrantedTokens :: TVar [B.ByteString],
fpPurchasePaths :: TVar [[Text]],
fpAcknowledgeRefusal :: TVar (Maybe Int),
fpAcknowledged :: TVar [Text]
}
fakePackageName :: Text
fakePackageName = "chat.simplex.app"
fakeClientEmail :: Text
fakeClientEmail = "badge-verifier@simplex-badges-test.iam.gserviceaccount.com"
-- | Warp chooses the port, so a server left over from an earlier run cannot answer instead.
-- The service account key is made per run, since a committed one trips secret scanning.
withFakePlay :: (FakePlay -> IO a) -> IO a
withFakePlay action = do
(key, privateKey) <- RSA.generate 128 65537
fpAnswers <- newTVarIO M.empty
fpTokenRefusal <- newTVarIO Nothing
fpTokenSeconds <- newTVarIO 3600
fpGrantedTokens <- newTVarIO []
fpPurchasePaths <- newTVarIO []
fpAcknowledgeRefusal <- newTVarIO Nothing
fpAcknowledged <- newTVarIO []
createDirectoryIfMissing True "tests/tmp"
withTempDirectory "tests/tmp" "fake-play" $ \d -> do
let accountFile = d </> "service-account.json"
fake base =
FakePlay
{ fpConfig = PlayStoreConfig {gPackageName = fakePackageName, gServiceAccountFile = accountFile, gApiHost = base, gTokenUrl = base <> "/token"},
fpAnswers,
fpTokenRefusal,
fpTokenSeconds,
fpGrantedTokens,
fpPurchasePaths,
fpAcknowledgeRefusal,
fpAcknowledged
}
LB.writeFile accountFile $ J.encode $ J.object ["client_email" J..= fakeClientEmail, "private_key" J..= decodeUtf8 (pkcs8Pem privateKey)]
Warp.testWithApplication (pure $ \req respond -> fakeApp key (fake $ origin req) req respond) $ \prt ->
action (fake $ "http://127.0.0.1:" <> T.pack (show prt))
where
-- the app needs the base URL for the audience it checks, and the request names the port it reached
origin req = maybe "" (("http://" <>) . T.pack . B8.unpack) (lookup "Host" (requestHeaders req))
-- | The PKCS#8 PEM Google puts in a service account key, so the service's own parser reads it.
pkcs8Pem :: RSA.PrivateKey -> B.ByteString
pkcs8Pem k =
"-----BEGIN PRIVATE KEY-----\n" <> B8.unlines (chunks $ B64.encode pkcs8) <> "-----END PRIVATE KEY-----\n"
where
RSA.PublicKey {RSA.public_n, RSA.public_e} = RSA.private_pub k
pkcs8 = der 0x30 $ derInteger 0 <> der 0x30 (rsaEncryption <> "\x05\x00") <> der 0x04 pkcs1
pkcs1 = der 0x30 $ foldMap derInteger [0, public_n, public_e, RSA.private_d k, RSA.private_p k, RSA.private_q k, RSA.private_dP k, RSA.private_dQ k, RSA.private_qinv k]
rsaEncryption = der 0x06 "\x2a\x86\x48\x86\xf7\x0d\x01\x01\x01"
derInteger n = der 0x02 $ case i2osp n of
bs | B.null bs || B.head bs >= 0x80 -> B.cons 0 bs
bs -> bs
der tag content = B.pack (tag : derLength (B.length content)) <> content
derLength n
| n < 0x80 = [fromIntegral n]
| otherwise = let bs = B.unpack (i2osp $ toInteger n) in 0x80 + fromIntegral (length bs) : bs
chunks bs
| B.null bs = []
| otherwise = let (line, rest) = B.splitAt 64 bs in line : chunks rest
answerPurchase :: FakePlay -> Text -> PlayAnswer -> IO ()
answerPurchase FakePlay {fpAnswers} token answer = atomically $ modifyTVar' fpAnswers $ M.insert token answer
answerTokenRequests :: FakePlay -> Maybe Int -> IO ()
answerTokenRequests FakePlay {fpTokenRefusal} = atomically . writeTVar fpTokenRefusal
grantTokensFor :: FakePlay -> Int -> IO ()
grantTokensFor FakePlay {fpTokenSeconds} = atomically . writeTVar fpTokenSeconds
answerAcknowledgements :: FakePlay -> Maybe Int -> IO ()
answerAcknowledgements FakePlay {fpAcknowledgeRefusal} = atomically . writeTVar fpAcknowledgeRefusal
fakeApp :: RSA.PublicKey -> FakePlay -> Application
fakeApp key FakePlay {fpConfig = PlayStoreConfig {gTokenUrl}, fpAnswers, fpTokenRefusal, fpTokenSeconds, fpGrantedTokens, fpPurchasePaths, fpAcknowledgeRefusal, fpAcknowledged} req respond =
case (requestMethod req, pathInfo req) of
(m, ["token"]) | m == methodPost -> strictRequestBody req >>= grant
(m, path@["androidpublisher", "v3", "applications", pkg, "purchases", "products", _, "tokens", token])
| m == methodGet && pkg == fakePackageName -> authorized $ do
atomically $ modifyTVar' fpPurchasePaths (<> [path])
purchase token
| m == methodPost && pkg == fakePackageName, Just acknowledgedToken <- T.stripSuffix ":acknowledge" token -> authorized $ acknowledge acknowledgedToken
_ -> respond $ status notFound404
where
authorized act = do
granted <- readTVarIO fpGrantedTokens
case lookup hAuthorization (requestHeaders req) of
Just auth | Just bearer <- B.stripPrefix "Bearer " auth, take 1 (reverse granted) == [bearer] -> act
_ -> respond $ status unauthorized401
acknowledge token =
readTVarIO fpAcknowledgeRefusal >>= \case
Just code -> respond $ status (mkStatus code "Refused")
Nothing -> do
atomically $ modifyTVar' fpAcknowledged (<> [token])
respond $ responseLBS ok200 [] ""
grant body =
readTVarIO fpTokenRefusal >>= \case
Just code -> respond $ status (mkStatus code "Refused")
Nothing
| validAssertion (parseSimpleQuery $ LB.toStrict body) -> do
bearer <- atomically $ stateTVar fpGrantedTokens $ \ts -> let t = "fake-access-" <> B8.pack (show (length ts)) in (t, ts <> [t])
seconds <- readTVarIO fpTokenSeconds
respond $ json ok200 $ J.object ["access_token" J..= B8.unpack bearer, "expires_in" J..= seconds, "token_type" J..= ("Bearer" :: Text)]
| otherwise -> respond $ json badRequest400 $ J.object ["error" J..= ("invalid_grant" :: Text)]
validAssertion form = case (lookup "grant_type" form, B8.split '.' <$> lookup "assertion" form) of
(Just "urn:ietf:params:oauth:grant-type:jwt-bearer", Just [header, claims, sig])
| Right sigBytes <- B64U.decodeUnpadded sig,
RSA.verify (Just SHA256) key (header <> "." <> claims) sigBytes,
Right claimBytes <- B64U.decodeUnpadded claims,
Just (J.Object c) <- J.decodeStrict' claimBytes ->
KM.lookup "aud" c == Just (J.String gTokenUrl)
&& KM.lookup "scope" c == Just (J.String "https://www.googleapis.com/auth/androidpublisher")
&& KM.lookup "iss" c == Just (J.String fakeClientEmail)
_ -> False
purchase token =
M.lookup token <$> readTVarIO fpAnswers >>= \case
Just (PlayRecord v) -> respond $ json ok200 v
Just (PlayBody b) -> respond $ responseLBS ok200 [(hContentType, "application/json")] b
Just (PlayStatus code) -> respond $ status (mkStatus code "Answer")
Just PlayHang -> forever $ threadDelay 1000000
Nothing -> respond $ status notFound404
json :: Status -> J.Value -> Response
json st = responseLBS st [(hContentType, "application/json")] . J.encode
status :: Status -> Response
status st = json st $ J.object ["error" J..= J.object ["code" J..= show st]]
+2 -2
View File
@@ -72,7 +72,7 @@ newFakeStore = do
]
verifyApple jws
| jws == appleThrowingJWS = error "fake verifier bug"
| otherwise = maybe (Left "not a fake receipt") Right $ lookup jws appleReceipts
| otherwise = maybe (Left $ SRInvalid "not a fake receipt") Right $ lookup jws appleReceipts
verifyGoogle = googleVerdict pendingSettled googleDown
pure
FakeStore
@@ -84,7 +84,7 @@ newFakeStore = do
appleQuantityJWS,
pendingSettled,
googleDown,
fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle, verifyTimeout = 500000}
fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle, acknowledgeGoogle = Nothing, verifyTimeout = 500000}
}
where
fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir </> name)
@@ -0,0 +1,560 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Bots.BadgeService.StoreVerifierTests (badgeStoreVerifierTests) where
import BadgeService.Config (PlayStoreConfig (..), ServiceConfig (..), readServiceConfig)
import BadgeService.Service (ServiceState (..), configureStoreVerifier, newServiceState)
import BadgeService.StoreReceipts
import BadgeService.StoreReceipts.Apple (readAppleRoot, verifyAppleTransaction)
import BadgeService.StoreReceipts.Google (playStoreVerifier)
import Bots.BadgeService.FakePlay
import Control.Concurrent.STM (readTVarIO)
import Control.Monad (forM_)
import Crypto.Hash.Algorithms (SHA256 (..))
import Crypto.Number.Serialize (i2osp, i2ospOf_)
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Generate as ECC
import qualified Crypto.PubKey.ECC.Types as ECC
import qualified Data.Aeson as J
import qualified Data.Aeson.KeyMap as KM
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base64.URL as B64U
import qualified Data.ByteString.Lazy as LB
import Data.Hourglass (Date (..), DateTime (..), Month (..), TimeOfDay (..))
import Data.List (isInfixOf)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.X509
import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef)
import Simplex.Chat.PaymentService.Types (CurrencyAmount (..))
import System.Directory (createDirectoryIfMissing)
import System.FilePath (takeDirectory, (</>))
import Test.Hspec
import UnliftIO.Temporary (withTempDirectory)
badgeStoreVerifierTests :: Spec
badgeStoreVerifierTests = describe "badge store verifiers" $ do
describe "App Store signed transactions" $ do
it "vouches for a transaction a chain to the trusted root signed, naming the transaction it was claimed by" testAppleVerdict
it "fails, rather than refuses, an intermediate the trusted root did not sign, since the root may be misconfigured" testAppleRootNotTrusted
it "refuses a leaf the intermediate did not sign, though the intermediate is genuine" testAppleForgedLeaf
it "fails, rather than refuses, a leaf signature the library cannot check" testAppleLeafUncheckable
it "refuses a tampered payload" testAppleTamperedPayload
it "fails, rather than refuses, a chain that is not exactly leaf, intermediate and root, a shape Apple may yet adopt" testAppleChainLength
it "fails, rather than refuses, a header that names another algorithm, a shape Apple may yet adopt" testAppleOtherAlgorithm
it "fails, rather than refuses, another app's bundle id, since ours may be misconfigured" testAppleOtherBundle
it "refuses a refunded transaction" testAppleRevoked
it "reports a Sandbox transaction as a test purchase" testAppleSandbox
it "fails, rather than refuses, a chain Apple did not mark for signing receipts" testAppleUnmarkedChain
it "fails, rather than refuses, a payload Apple signed in a shape it does not know" testAppleUnknownShape
it "fails, rather than refuses, a leaf holding a key it cannot read" testAppleLeafKey
it "records the price in the currency's minor units, or not at all" testApplePrice
it "reads the trusted root from a DER file, and reports one it cannot read" testReadAppleRoot
it "has nothing to acknowledge" testAppleNoAcknowledgement
describe "Google Play purchases" $ do
it "vouches for a purchased token, asking Play about that token in this app" testPlayPurchased
it "reports a license tester's purchase as a test purchase, and a promo code's as paid" testPlayTestAndPromo
it "refuses a canceled purchase" testPlayCanceled
it "answers a pending purchase as pending" testPlayPending
it "answers 404, 5xx and every other error but 401 and 403 as unreachable" testPlayErrorStatuses
it "fails on 401 and 403, and asks for a new access token after a 401" testPlayCredentialsRefused
it "fails when the token endpoint refuses the assertion, and is unreachable when it is down" testPlayTokenEndpoint
it "fails on a body it cannot read, another product, or an unknown state" testPlayUnreadable
it "answers a Play that does not answer, or cannot be reached, as unreachable" testPlayHangsOrIsGone
it "reuses its access token while it is valid" testPlayTokenCached
it "asks for a new access token once the one it holds is about to expire" testPlayTokenExpires
it "sends no token that is only dots, and describes a token outside the grammar without quoting it" testPlayTokensNotSent
it "acknowledges a purchase, unless it is acknowledged or consumed already" testPlayAcknowledges
it "reports an acknowledgement Play refuses or does not answer" testPlayAcknowledgementFails
it "acknowledges through the verifier a [google] section configures" testPlayConfiguredAcknowledges
-- * App Store
-- TestPurchase is the service's own refusal after a verifier vouched, so no verifier returns it here
data Outcome = Invalid | TestPurchase | Pending | Unreachable | Failed | NotConfigured | Verdict
deriving (Eq, Show)
outcome :: Either StoreRefusal a -> Outcome
outcome = \case
Left (SRInvalid _) -> Invalid
Left SRTestPurchase -> TestPurchase
Left SRPending -> Pending
Left (SRUnreachable _) -> Unreachable
Left (SRVerifierFailed _) -> Failed
Left SRNotConfigured -> NotConfigured
Right _ -> Verdict
reason :: Either StoreRefusal a -> Text
reason = \case
Left (SRInvalid r) -> r
Left (SRUnreachable r) -> r
Left (SRVerifierFailed r) -> r
_ -> ""
seamVerdict :: StoreVerifier -> ServicePayment -> IO (Either StoreRefusal VerifiedStoreTransaction)
seamVerdict verifier payment = case toStoreReceipt verifier payment of
Just (Right StoreReceipt {verifyReceipt}) -> verifyReceipt
Just (Left refusal) -> pure $ Left refusal
Nothing -> expectationFailure "not a store payment" >> undefined
ourBundleId :: Text
ourBundleId = "chat.simplex.app"
appleVerdict :: SignedCertificate -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)
appleVerdict root jws = seamVerdict noStoreVerifier {verifyApple = Just (verifyAppleTransaction root ourBundleId)} SPApple {jws}
data TestChain = TestChain
{ rootCert :: SignedCertificate,
intermediateCert :: SignedCertificate,
leafCert :: SignedCertificate,
intermediateKey :: ECDSA.PrivateKey,
leafKey :: ECDSA.PrivateKey
}
appleRootName, otherRootName, intermediateName, leafName :: DistinguishedName
appleRootName = DistinguishedName [([2, 5, 4, 3], "Apple Root CA - G3")]
otherRootName = DistinguishedName [([2, 5, 4, 3], "Some Other Root")]
intermediateName = DistinguishedName [([2, 5, 4, 3], "Apple Worldwide Developer Relations Certification Authority")]
leafName = DistinguishedName [([2, 5, 4, 3], "Prod ECC Mac App Store and iTunes Store Receipt Signing")]
receiptLeafMarker, intermediateMarker :: [Integer]
receiptLeafMarker = [1, 2, 840, 113635, 100, 6, 11, 1]
intermediateMarker = [1, 2, 840, 113635, 100, 6, 2, 1]
-- | Shaped as Apple's chain, under a root of the given name; the intermediate and the leaf carry the given markers.
newChain :: DistinguishedName -> [[Integer]] -> [[Integer]] -> IO TestChain
newChain rootName intermediateMarkers leafMarkers = do
(rootKey, rootPub) <- newKeyPair
(intermediateKey, intermediatePub) <- newKeyPair
(leafKey, leafPub) <- newKeyPair
rootCert <- certify rootKey rootName rootName rootPub []
intermediateCert <- certify rootKey rootName intermediateName intermediatePub intermediateMarkers
leafCert <- certify intermediateKey intermediateName leafName leafPub leafMarkers
pure TestChain {rootCert, intermediateCert, leafCert, intermediateKey, leafKey}
trustedChain :: IO TestChain
trustedChain = newChain appleRootName [intermediateMarker] [receiptLeafMarker]
newKeyPair :: IO (ECDSA.PrivateKey, PubKey)
newKeyPair = do
(ECDSA.PublicKey _ q, k) <- ECC.generate p256
case q of
ECC.Point x y -> pure (k, PubKeyEC $ PubKeyEC_Named ECC.SEC_p256r1 $ SerializedPoint $ B.cons 4 $ i2ospOf_ 32 x <> i2ospOf_ 32 y)
ECC.PointO -> newKeyPair
p256 :: ECC.Curve
p256 = ECC.getCurveByName ECC.SEC_p256r1
certify :: ECDSA.PrivateKey -> DistinguishedName -> DistinguishedName -> PubKey -> [[Integer]] -> IO SignedCertificate
certify = certifyWith $ SignatureALG HashSHA256 PubKeyALG_EC
certifyWith :: SignatureALG -> ECDSA.PrivateKey -> DistinguishedName -> DistinguishedName -> PubKey -> [[Integer]] -> IO SignedCertificate
certifyWith alg issuerKey issuerName subjectName subjectKey markers =
objectToSignedExactF sign certificate
where
certificate =
Certificate
{ certVersion = 2,
certSerial = 1,
certSignatureAlg = alg,
certIssuerDN = issuerName,
certValidity = (DateTime (Date 2020 January 1) (TimeOfDay 0 0 0 0), DateTime (Date 2040 January 1) (TimeOfDay 0 0 0 0)),
certSubjectDN = subjectName,
certPubKey = subjectKey,
certExtensions = Extensions $ Just [ExtensionRaw oid False "\x05\x00" | oid <- markers]
}
sign tbs = (\(ECDSA.Signature r s) -> (derSignature r s, alg)) <$> ECDSA.sign issuerKey SHA256 tbs
derSignature r s = der 0x30 (der 0x02 (unsigned r) <> der 0x02 (unsigned s))
der tag content = B.pack [tag, fromIntegral (B.length content)] <> content
unsigned n = let bs = i2osp n in if B.head bs >= 0x80 then B.cons 0 bs else bs
transactionPayload :: [(J.Key, J.Value)] -> [J.Key] -> J.Value
transactionPayload overrides removed =
J.Object $ foldr KM.delete (KM.fromList overrides `KM.union` base) removed
where
base =
KM.fromList
[ ("transactionId", "2000000900000001"),
("originalTransactionId", "2000000900000001"),
("bundleId", J.String ourBundleId),
("productId", "BADGE_SUPPORTER_01"),
("purchaseDate", J.toJSON (1790000000000 :: Int)),
("quantity", J.toJSON (1 :: Int)),
("type", "Consumable"),
("inAppOwnershipType", "PURCHASED"),
("signedDate", J.toJSON (1790000001000 :: Int)),
("environment", "Production"),
("transactionReason", "PURCHASE"),
("storefront", "USA"),
("price", J.toJSON (7000 :: Int)),
("currency", "USD")
]
signedTransaction :: TestChain -> [SignedCertificate] -> J.Value -> J.Value -> IO Text
signedTransaction TestChain {leafKey} x5c header payload = do
let signingInput = segment header' <> "." <> segment payload
header' = case header of
J.Object h -> J.Object $ KM.insert "x5c" (J.toJSON $ map (decodeUtf8 . B64.encode . encodeSignedObject) x5c) h
v -> v
ECDSA.Signature r s <- ECDSA.sign leafKey SHA256 signingInput
pure $ decodeUtf8 $ signingInput <> "." <> B64U.encodeUnpadded (i2ospOf_ 32 r <> i2ospOf_ 32 s)
segment :: J.Value -> ByteString
segment = B64U.encodeUnpadded . LB.toStrict . J.encode
es256 :: J.Value
es256 = J.object ["alg" J..= ("ES256" :: Text)]
signedBy :: TestChain -> J.Value -> IO Text
signedBy chain@TestChain {rootCert, intermediateCert, leafCert} = signedTransaction chain [leafCert, intermediateCert, rootCert] es256
testAppleVerdict :: IO ()
testAppleVerdict = do
chain <- trustedChain
jws <- signedBy chain $ transactionPayload [] []
appleVerdict (rootCert chain) jws
`shouldReturn` Right VerifiedStoreTransaction {transactionRef = "2000000900000001", productId = "BADGE_SUPPORTER_01", quantity = 1, testPurchase = False, paid = Just (CurrencyAmount 700, "USD")}
appleTransactionId jws `shouldBe` Just "2000000900000001"
testAppleRootNotTrusted :: IO ()
testAppleRootNotTrusted = do
trusted <- trustedChain
forM_ [appleRootName, otherRootName] $ \rootName -> do
untrusted <- newChain rootName [intermediateMarker] [receiptLeafMarker]
jws <- signedBy untrusted $ transactionPayload [] []
r <- appleVerdict (rootCert trusted) jws
outcome r `shouldBe` Failed
reason r `shouldSatisfy` ("configured root" `T.isInfixOf`)
testAppleForgedLeaf :: IO ()
testAppleForgedLeaf = do
chain@TestChain {rootCert, intermediateCert} <- trustedChain
(forgedKey, forgedPub) <- newKeyPair
forgedLeaf <- certify forgedKey intermediateName leafName forgedPub [receiptLeafMarker]
jws <- signedTransaction chain {leafKey = forgedKey} [forgedLeaf, intermediateCert, rootCert] es256 $ transactionPayload [] []
outcome <$> appleVerdict rootCert jws `shouldReturn` Invalid
testAppleLeafUncheckable :: IO ()
testAppleLeafUncheckable = do
chain@TestChain {rootCert, intermediateCert} <- trustedChain
(otherKey, otherPub) <- newKeyPair
rsaLabelled <- certifyWith (SignatureALG HashSHA256 PubKeyALG_RSA) otherKey intermediateName leafName otherPub [receiptLeafMarker]
jws <- signedTransaction chain {leafKey = otherKey} [rsaLabelled, intermediateCert, rootCert] es256 $ transactionPayload [] []
r <- appleVerdict rootCert jws
outcome r `shouldBe` Failed
reason r `shouldSatisfy` ("cannot check" `T.isInfixOf`)
testAppleTamperedPayload :: IO ()
testAppleTamperedPayload = do
chain <- trustedChain
jws <- signedBy chain $ transactionPayload [] []
case T.splitOn "." jws of
[header, _, signature] -> do
let tampered = T.intercalate "." [header, decodeUtf8 $ segment $ transactionPayload [("productId", "BADGE_LEGEND_01")] [], signature]
outcome <$> appleVerdict (rootCert chain) tampered `shouldReturn` Invalid
_ -> expectationFailure "not a JWS"
testAppleChainLength :: IO ()
testAppleChainLength = do
chain@TestChain {rootCert, intermediateCert, leafCert} <- trustedChain
forM_ [[leafCert, rootCert], [leafCert, intermediateCert], [leafCert, intermediateCert, rootCert, rootCert]] $ \x5c -> do
jws <- signedTransaction chain x5c es256 $ transactionPayload [] []
outcome <$> appleVerdict rootCert jws `shouldReturn` Failed
testAppleOtherAlgorithm :: IO ()
testAppleOtherAlgorithm = do
chain@TestChain {rootCert, intermediateCert, leafCert} <- trustedChain
let x5c = [leafCert, intermediateCert, rootCert]
forM_ ["none", "HS256", "ES384"] $ \alg -> do
jws <- signedTransaction chain x5c (J.object ["alg" J..= (alg :: Text)]) $ transactionPayload [] []
outcome <$> appleVerdict rootCert jws `shouldReturn` Failed
testAppleOtherBundle :: IO ()
testAppleOtherBundle = do
chain <- trustedChain
jws <- signedBy chain $ transactionPayload [("bundleId", "com.example.other")] []
r <- appleVerdict (rootCert chain) jws
outcome r `shouldBe` Failed
reason r `shouldSatisfy` ("bundle id" `T.isInfixOf`)
testAppleRevoked :: IO ()
testAppleRevoked = do
chain <- trustedChain
jws <- signedBy chain $ transactionPayload [("revocationDate", J.toJSON (1790000500000 :: Int)), ("revocationReason", J.toJSON (0 :: Int))] []
outcome <$> appleVerdict (rootCert chain) jws `shouldReturn` Invalid
testAppleSandbox :: IO ()
testAppleSandbox = do
chain <- trustedChain
jws <- signedBy chain $ transactionPayload [("environment", "Sandbox")] []
fmap testPurchase <$> appleVerdict (rootCert chain) jws `shouldReturn` Right True
testAppleUnmarkedChain :: IO ()
testAppleUnmarkedChain =
forM_ [([intermediateMarker], []), ([], [receiptLeafMarker])] $ \(intermediateMarkers, leafMarkers) -> do
unmarked <- newChain appleRootName intermediateMarkers leafMarkers
jws <- signedBy unmarked $ transactionPayload [] []
outcome <$> appleVerdict (rootCert unmarked) jws `shouldReturn` Failed
testAppleUnknownShape :: IO ()
testAppleUnknownShape = do
chain <- trustedChain
let failsOn payload = do
jws <- signedBy chain payload
outcome <$> appleVerdict (rootCert chain) jws `shouldReturn` Failed
failsOn $ transactionPayload [("environment", "Staging")] []
failsOn $ transactionPayload [("environment", "Xcode")] []
failsOn $ transactionPayload [("environment", "LocalTesting")] []
failsOn $ transactionPayload [] ["productId"]
failsOn $ transactionPayload [("quantity", "1")] []
-- | The key is read before the signature it would check, so the chain and the payload are genuine.
testAppleLeafKey :: IO ()
testAppleLeafKey = do
chain@TestChain {rootCert, intermediateCert, intermediateKey} <- trustedChain
let failsOnLeafKey pub = do
leaf <- certify intermediateKey intermediateName leafName pub [receiptLeafMarker]
jws <- signedTransaction chain [leaf, intermediateCert, rootCert] es256 $ transactionPayload [] []
outcome <$> appleVerdict rootCert jws `shouldReturn` Failed
failsOnLeafKey $ PubKeyEC $ PubKeyEC_Named ECC.SEC_p384r1 $ SerializedPoint $ B.cons 4 $ B.replicate 64 1
failsOnLeafKey $ PubKeyEC $ PubKeyEC_Named ECC.SEC_p256r1 $ SerializedPoint "\x04"
testApplePrice :: IO ()
testApplePrice = do
chain <- trustedChain
let paidFor fields removed = do
jws <- signedBy chain $ transactionPayload fields removed
fmap paid <$> appleVerdict (rootCert chain) jws
priced price currency = paidFor [("price", J.toJSON (price :: Int)), ("currency", currency)] []
-- Apple's own examples: $1.99, JPY 300 and KRW 3300
priced 1990 "USD" `shouldReturn` Right (Just (CurrencyAmount 199, "USD"))
priced 300000 "JPY" `shouldReturn` Right (Just (CurrencyAmount 300, "JPY"))
priced 3300000 "KRW" `shouldReturn` Right (Just (CurrencyAmount 3300, "KRW"))
priced 1234 "KWD" `shouldReturn` Right (Just (CurrencyAmount 1234, "KWD"))
priced 1995 "USD" `shouldReturn` Right Nothing
priced 1000 "CLF" `shouldReturn` Right Nothing
priced 1000 "usd" `shouldReturn` Right Nothing
paidFor [] ["price", "currency"] `shouldReturn` Right Nothing
testReadAppleRoot :: IO ()
testReadAppleRoot = do
TestChain {rootCert} <- trustedChain
createDirectoryIfMissing True "tests/tmp"
withTempDirectory "tests/tmp" "apple-root" $ \d -> do
B.writeFile (d </> "root.cer") (encodeSignedObject rootCert)
readAppleRoot (d </> "root.cer") `shouldReturn` Right rootCert
B.writeFile (d </> "root.pem") "-----BEGIN CERTIFICATE-----\n"
readAppleRoot (d </> "root.pem") >>= (`shouldSatisfy` either ("not a DER certificate" `isInfixOf`) (const False))
readAppleRoot (d </> "absent.cer") >>= (`shouldSatisfy` either ("could not be read" `isInfixOf`) (const False))
testAppleNoAcknowledgement :: IO ()
testAppleNoAcknowledgement = do
chain <- trustedChain
jws <- signedBy chain $ transactionPayload [] []
withFakePlay $ \fake -> do
verifier <- playVerifier fake
acknowledgement verifier {verifyApple = Just (verifyAppleTransaction (rootCert chain) ourBundleId)} SPApple {jws} `shouldReturn` Nothing
-- * Google Play
playVerifier :: FakePlay -> IO StoreVerifier
playVerifier fake =
playStoreVerifier (fpConfig fake) >>= \case
Right (verify, acknowledge) -> pure noStoreVerifier {verifyGoogle = Just verify, acknowledgeGoogle = Just acknowledge, verifyTimeout = 2000000}
Left e -> expectationFailure e >> undefined
acknowledgement :: StoreVerifier -> ServicePayment -> IO (Maybe (Either StoreRefusal ()))
acknowledgement verifier payment = case toStoreReceipt verifier payment of
Just (Right StoreReceipt {acknowledgeReceipt}) -> sequence acknowledgeReceipt
_ -> expectationFailure "not a store receipt" >> undefined
playVerdict :: StoreVerifier -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)
playVerdict verifier token = seamVerdict verifier SPGoogle {productId = "badge_supporter_01", token}
purchaseRecord :: Int -> [(J.Key, J.Value)] -> J.Value
purchaseRecord state fields =
J.Object $
KM.fromList fields
`KM.union` KM.fromList
[ ("kind", "androidpublisher#productPurchase"),
("purchaseTimeMillis", "1790000000000"),
("purchaseState", J.toJSON state),
("consumptionState", J.toJSON (0 :: Int)),
("orderId", "GPA.3312-4521-8899-01234"),
("acknowledgementState", J.toJSON (0 :: Int)),
("regionCode", "US")
]
testToken :: Text
testToken = "fake-play-token.AO-J1Oz9x2kqE7wYt3"
-- | Every reason reaches the service's log, which must never hold the token.
answeredAs :: StoreVerifier -> Text -> Outcome -> IO ()
answeredAs verifier token expected = do
r <- playVerdict verifier token
outcome r `shouldBe` expected
reason r `shouldNotSatisfy` (token `T.isInfixOf`)
testPlayPurchased :: IO ()
testPlayPurchased = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
playVerdict verifier testToken
`shouldReturn` Right VerifiedStoreTransaction {transactionRef = googlePurchaseRef testToken, productId = "badge_supporter_01", quantity = 1, testPurchase = False, paid = Nothing}
readTVarIO (fpPurchasePaths fake)
`shouldReturn` [["androidpublisher", "v3", "applications", fakePackageName, "purchases", "products", "badge_supporter_01", "tokens", testToken]]
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 [("quantity", J.toJSON (2 :: Int)), ("productId", "badge_supporter_01")]
fmap quantity <$> playVerdict verifier testToken `shouldReturn` Right 2
testPlayTestAndPromo :: IO ()
testPlayTestAndPromo = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 [("purchaseType", J.toJSON (0 :: Int))]
fmap testPurchase <$> playVerdict verifier testToken `shouldReturn` Right True
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 [("purchaseType", J.toJSON (1 :: Int))]
fmap testPurchase <$> playVerdict verifier testToken `shouldReturn` Right False
testPlayCanceled :: IO ()
testPlayCanceled = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 1 []
answeredAs verifier testToken Invalid
testPlayPending :: IO ()
testPlayPending = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 2 []
answeredAs verifier testToken Pending
testPlayErrorStatuses :: IO ()
testPlayErrorStatuses = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answeredAs verifier testToken Unreachable
forM_ [400, 404, 410, 429, 500, 503] $ \code -> do
answerPurchase fake testToken $ PlayStatus code
answeredAs verifier testToken Unreachable
testPlayCredentialsRefused :: IO ()
testPlayCredentialsRefused = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answerPurchase fake testToken $ PlayStatus 403
answeredAs verifier testToken Failed
answerPurchase fake testToken $ PlayStatus 401
answeredAs verifier testToken Failed
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
answeredAs verifier testToken Verdict
length <$> readTVarIO (fpGrantedTokens fake) `shouldReturn` 2
testPlayTokenEndpoint :: IO ()
testPlayTokenEndpoint = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
forM_ [400, 401] $ \code -> do
answerTokenRequests fake $ Just code
answeredAs verifier testToken Failed
forM_ [429, 503] $ \code -> do
answerTokenRequests fake $ Just code
answeredAs verifier testToken Unreachable
answerTokenRequests fake Nothing
answeredAs verifier testToken Verdict
readTVarIO (fpPurchasePaths fake) >>= (`shouldSatisfy` ((== 1) . length))
testPlayUnreadable :: IO ()
testPlayUnreadable = withFakePlay $ \fake -> do
verifier <- playVerifier fake
forM_
[ PlayBody "<html>not json</html>",
PlayBody "{\"purchaseState\":\"0\"}",
PlayRecord $ J.object ["kind" J..= ("androidpublisher#productPurchase" :: Text)],
PlayRecord $ purchaseRecord 0 [("productId", "badge_legend_01")],
PlayRecord $ purchaseRecord 3 [],
PlayRecord $ purchaseRecord 0 [("purchaseType", J.toJSON (2 :: Int))],
PlayBody $ J.encode (purchaseRecord 0 []) <> LB.replicate (1024 * 1024) 32
]
$ \answer -> do
answerPurchase fake testToken answer
answeredAs verifier testToken Failed
testPlayHangsOrIsGone :: IO ()
testPlayHangsOrIsGone = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answerPurchase fake testToken PlayHang
r <- playVerdict verifier testToken
(outcome r, reason r) `shouldBe` (Unreachable, "google verifier timed out")
-- not a stopped stub's port, which a test running alongside may already have been given
gone <- playVerifier fake {fpConfig = (fpConfig fake) {gApiHost = "http://127.0.0.1:1"}}
answeredAs gone testToken Unreachable
testPlayTokenCached :: IO ()
testPlayTokenCached = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
answeredAs verifier testToken Verdict
answeredAs verifier testToken Verdict
length <$> readTVarIO (fpGrantedTokens fake) `shouldReturn` 1
testPlayTokenExpires :: IO ()
testPlayTokenExpires = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
grantTokensFor fake 300
answeredAs verifier testToken Verdict
answeredAs verifier testToken Verdict
length <$> readTVarIO (fpGrantedTokens fake) `shouldReturn` 2
testPlayTokensNotSent :: IO ()
testPlayTokensNotSent = withFakePlay $ \fake -> do
verifier <- playVerifier fake
answeredAs verifier ".." Unreachable
let outside = "fake/play+token=AO-J1Oz9x2kqE7wYt3"
r <- playVerdict verifier outside
outcome r `shouldBe` Unreachable
reason r `shouldBe` "a Play token this service will not send: 34 characters: lowercase, uppercase, digits, '-', other printable ASCII"
readTVarIO (fpPurchasePaths fake) `shouldReturn` []
testPlayAcknowledges :: IO ()
testPlayAcknowledges = withFakePlay $ \fake -> do
verifier <- playVerifier fake
let acknowledging = acknowledgement verifier SPGoogle {productId = "badge_supporter_01", token = testToken}
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
acknowledging `shouldReturn` Just (Right ())
readTVarIO (fpAcknowledged fake) `shouldReturn` [testToken]
forM_ ["acknowledgementState", "consumptionState"] $ \state -> do
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 [(state, J.toJSON (1 :: Int))]
acknowledging `shouldReturn` Just (Right ())
readTVarIO (fpAcknowledged fake) `shouldReturn` [testToken]
testPlayAcknowledgementFails :: IO ()
testPlayAcknowledgementFails = withFakePlay $ \fake -> do
verifier <- playVerifier fake
let acknowledgedAs expected = do
r <- acknowledgement verifier SPGoogle {productId = "badge_supporter_01", token = testToken}
outcome <$> r `shouldBe` Just expected
maybe "" reason r `shouldSatisfy` ("acknowledging: " `T.isPrefixOf`)
maybe "" reason r `shouldNotSatisfy` (testToken `T.isInfixOf`)
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
answerAcknowledgements fake $ Just 403
acknowledgedAs Failed
answerAcknowledgements fake $ Just 503
acknowledgedAs Unreachable
answerAcknowledgements fake Nothing
answerPurchase fake testToken PlayHang
acknowledgedAs Unreachable
readTVarIO (fpAcknowledged fake) `shouldReturn` []
testPlayConfiguredAcknowledges :: IO ()
testPlayConfiguredAcknowledges = withFakePlay $ \fake@FakePlay {fpConfig} -> do
let ini = takeDirectory (gServiceAccountFile fpConfig) </> "badge_service.ini"
writeFile ini "[listener]\nstatic_dir = /srv/badges\n"
Right cfg <- readServiceConfig ini
ServiceState {storeVerifier} <- newServiceState >>= configureStoreVerifier (Just cfg {playStore = Just fpConfig})
answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 []
acknowledgement storeVerifier SPGoogle {productId = "badge_supporter_01", token = testToken} `shouldReturn` Just (Right ())
readTVarIO (fpAcknowledged fake) `shouldReturn` [testToken]
+2
View File
@@ -978,6 +978,8 @@ testServiceConfig staticDir trustForwarded =
btcpay = Nothing,
stripe = Nothing,
poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60},
appleStore = Nothing,
playStore = Nothing,
issuer = Nothing,
group = Nothing,
devAcceptUnverifiedStoreReceipts = False
+2
View File
@@ -9,6 +9,7 @@ import Bots.BadgeService.CatalogTests
import Bots.BadgeService.ConfigTests
import Bots.BadgeService.GroupIntegrationTests
import Bots.BadgeService.GroupTests
import Bots.BadgeService.StoreVerifierTests
import Bots.BadgeService.StripeTests
import Bots.BadgeService.WaitersTests
import Bots.BadgeService.WebTests
@@ -83,6 +84,7 @@ main = do
badgeWaitersTests
badgeBTCPayTests
badgeStripeTests
badgeStoreVerifierTests
describe "SimpleX chat markdown" markdownTests
describe "JSON Tests" jsonTests
describe "Member relations" memberRelationsTests