mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-11-11 13:57:42 +00:00
spacedandy-agents-simplex
664e5388ff
A held Apple subscription record is keyed by its original transaction id, so every renewal resolves to it. It kept the payment's back-off when a new transaction arrived, and adopted any payment handed over, including a revoked renewal, which the service refuses as receipt_invalid and so would refuse the whole subscription. A held Apple record now adopts a JWS only for another transaction with a later purchaseDate and no revocationDate, read from the unverified payload, and is then due at once with its retry delay and credit error cleared. A re-delivered or re-signed copy changes nothing. A failed attempt writes its back-off only if the record still holds the payment it sent. Run: 003-badge-subscriptions-ui, slice 5
107 lines
4.0 KiB
Haskell
107 lines
4.0 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Simplex.Chat.PaymentService
|
|
( ServiceInvoice (..),
|
|
ServicePayment (..),
|
|
AppleTransactionFacts (..),
|
|
applePayload,
|
|
appleTransactionRef,
|
|
applePayloadRef,
|
|
appleTransactionFacts,
|
|
googlePurchaseRef,
|
|
module Simplex.Chat.PaymentService.Types,
|
|
) where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad ((<=<))
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.Aeson.KeyMap as JM
|
|
import qualified Data.Aeson.TH as JQ
|
|
import qualified Data.Aeson.Types as JT
|
|
import qualified Data.ByteString.Base64.URL as B64U
|
|
import Data.Int (Int64)
|
|
import Data.Maybe (isJust)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Data.Time.Clock (UTCTime)
|
|
import Simplex.Chat.PaymentService.Types
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Encoding.String (strEncode)
|
|
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
|
|
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
|
|
|
|
data ServiceInvoice = ServiceInvoice
|
|
{ invoiceId :: InvoiceId,
|
|
price :: CurrencyAmount,
|
|
discount :: Maybe CurrencyAmount, -- discount amount from the price
|
|
credit :: Maybe CurrencyAmount, -- credit for upgrade
|
|
amount :: CurrencyAmount, -- price - discount - credit
|
|
currency :: Text,
|
|
expiresAt :: UTCTime,
|
|
paymentTo :: ServicePaymentDestination
|
|
}
|
|
deriving (Show)
|
|
|
|
data ServicePayment
|
|
= SPApple {jws :: Text}
|
|
| SPGoogle {productId :: Text, token :: Text} -- the Publisher API finds a purchase by product and token
|
|
| SPInvoice {invoiceId :: InvoiceId}
|
|
| SPReceipt {receipt :: Text} -- transfer of unissued months
|
|
deriving (Show)
|
|
|
|
-- | Read without verifying the signature: it names the transaction, and proves nothing about it.
|
|
applePayload :: Text -> Maybe J.Object
|
|
applePayload signed = case T.splitOn "." signed of
|
|
[_, payload, _] -> do
|
|
J.Object o <- J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload)
|
|
Just o
|
|
_ -> Nothing
|
|
|
|
appleTransactionRef :: Text -> Maybe Text
|
|
appleTransactionRef = applePayloadRef <=< applePayload
|
|
|
|
-- | What an unverified payload says about its transaction, which decides only which payment a held record
|
|
-- presents next: the service verifies whatever it is sent.
|
|
data AppleTransactionFacts = AppleTransactionFacts
|
|
{ transactionId :: Text,
|
|
purchaseDate :: Maybe Int64, -- epoch milliseconds
|
|
revoked :: Bool,
|
|
autoRenewable :: Bool
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
-- | A purchaseDate or type that does not read is taken as absent rather than failing the whole payload.
|
|
appleTransactionFacts :: Text -> Maybe AppleTransactionFacts
|
|
appleTransactionFacts = JT.parseMaybe facts <=< applePayload
|
|
where
|
|
facts o = do
|
|
transactionId <- o J..: "transactionId"
|
|
purchaseDate <- o J..:? "purchaseDate" <|> pure Nothing
|
|
-- as the service reads it: null is not revoked
|
|
revoked <- isJust <$> (o J..:? "revocationDate" :: JT.Parser (Maybe J.Value))
|
|
type_ <- o J..:? "type" <|> pure Nothing
|
|
pure AppleTransactionFacts {transactionId, purchaseDate, revoked, autoRenewable = type_ == Just ("Auto-Renewable Subscription" :: Text)}
|
|
|
|
-- | A subscription is named by its original transaction id, which every renewal keeps, so all its
|
|
-- charges claim one purchase; any other transaction by its own id.
|
|
applePayloadRef :: J.Object -> Maybe Text
|
|
applePayloadRef o = case JM.lookup "type" o of
|
|
Just (J.String "Auto-Renewable Subscription") -> field "originalTransactionId"
|
|
_ -> field "transactionId"
|
|
where
|
|
field k = case JM.lookup k o of
|
|
Just (J.String t) -> Just t
|
|
_ -> Nothing
|
|
|
|
-- | A purchase token is a bearer secret, so a purchase is named by its hash.
|
|
googlePurchaseRef :: Text -> Text
|
|
googlePurchaseRef = safeDecodeUtf8 . strEncode . C.sha256Hash . encodeUtf8
|
|
|
|
$(JQ.deriveJSON defaultJSON ''ServiceInvoice)
|
|
|
|
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SP") ''ServicePayment)
|