mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-11-04 15:07:32 +00:00
241 lines
12 KiB
Haskell
241 lines
12 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Bots.StoreService.FakeStore
|
|
( FakeStore (..),
|
|
newFakeStore,
|
|
googleVerifierWithHook,
|
|
subscriptionCheckWithHook,
|
|
settlePending,
|
|
setGoogleDown,
|
|
googleSupporterToken,
|
|
googlePendingToken,
|
|
googleUnreachableToken,
|
|
googleThrowingToken,
|
|
googleHangingToken,
|
|
googleSubscriptionToken,
|
|
googleUnknownProductToken,
|
|
appleSubscriptionOriginalId,
|
|
appleSecondSubscriptionOriginalId,
|
|
setSubscription,
|
|
subscriptionChecks,
|
|
googlePayment,
|
|
subscriptionJWS,
|
|
unsignedJWS,
|
|
)
|
|
where
|
|
|
|
import StoreService.StoreReceipts
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Monad (forever)
|
|
import qualified Data.Aeson as J
|
|
import Data.Aeson.Types (Pair)
|
|
import qualified Data.ByteString.Base64.URL as B64U
|
|
import qualified Data.ByteString.Char8 as B
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import Data.Int (Int64)
|
|
import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionRef, googlePurchaseRef)
|
|
import Simplex.Chat.PaymentService.Types (CurrencyAmount (..))
|
|
import Simplex.Messaging.Util (safeDecodeUtf8)
|
|
import System.FilePath ((</>))
|
|
|
|
fixtureDir :: FilePath
|
|
fixtureDir = "apps" </> "simplex-store-service" </> "test-fixtures" </> "apple"
|
|
|
|
-- | The Apple JWS are the fixtures under no real signature, so they are accepted as these exact
|
|
-- strings only, never because a payload decodes - which a real verifier must refuse to do.
|
|
data FakeStore = FakeStore
|
|
{ appleSupporterJWS :: Text,
|
|
appleLegendJWS :: Text,
|
|
appleSandboxJWS :: Text,
|
|
appleThrowingJWS :: Text,
|
|
appleMisnamedJWS :: Text,
|
|
appleQuantityJWS :: Text,
|
|
-- two transactions of the subscription appleSubscriptionOriginalId names, the renewal bought later, one
|
|
-- from Apple's Sandbox, and a later one Apple revoked, which the fake does not vouch for
|
|
appleSubscriptionJWS :: Text,
|
|
appleRenewalSubscriptionJWS :: Text,
|
|
appleSandboxSubscriptionJWS :: Text,
|
|
appleRevokedSubscriptionJWS :: Text,
|
|
-- a transaction of the same subscription after it was changed to annual Legend
|
|
appleLegendSubscriptionJWS :: Text,
|
|
-- two other subscriptions, the first under appleSecondSubscriptionOriginalId and the second one the store does not know
|
|
appleSecondSubscriptionJWS :: Text,
|
|
appleThirdSubscriptionJWS :: Text,
|
|
pendingSettled :: IORef Bool,
|
|
googleDown :: IORef Bool,
|
|
-- what the store answers about each subscription: Apple's by original id, Google's by token
|
|
subscriptions :: IORef (M.Map (Either Text Text) SubscriptionCheck),
|
|
subscriptionCheckCount :: IORef Int,
|
|
fakeVerifier :: StoreVerifier
|
|
}
|
|
|
|
newFakeStore :: IO FakeStore
|
|
newFakeStore = do
|
|
appleSupporterJWS <- fixtureJWS "transaction-supporter.json"
|
|
appleLegendJWS <- fixtureJWS "transaction-legend.json"
|
|
appleSandboxJWS <- fixtureJWS "transaction-sandbox.json"
|
|
let appleThrowingJWS = unsignedJWS "{\"transactionId\":\"2000000812345679\",\"productId\":\"BADGE_SUPPORTER_01\"}"
|
|
appleMisnamedJWS = unsignedJWS "{\"transactionId\":\"2000000812345698\",\"productId\":\"BADGE_SUPPORTER_01\"}"
|
|
appleQuantityJWS = unsignedJWS "{\"transactionId\":\"2000000812345697\",\"productId\":\"BADGE_SUPPORTER_01\"}"
|
|
appleSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345681" [purchasedAt 1767225600000]
|
|
appleRenewalSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345683" [purchasedAt 1769904000000]
|
|
appleSandboxSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345682" [purchasedAt 1767225600000]
|
|
appleRevokedSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345684" [purchasedAt 1769904000000, "revocationDate" J..= (1770000000000 :: Int64)]
|
|
appleLegendSubscriptionJWS = subscriptionJWS appleSubscriptionOriginalId "2000000812345688" [purchasedAt 1769904000000, "productId" J..= ("SUBSCR_BADGE_LEGEND_YEAR_01" :: Text)]
|
|
appleSecondSubscriptionJWS = subscriptionJWS appleSecondSubscriptionOriginalId "2000000812345701" [purchasedAt 1767225600000]
|
|
appleThirdSubscriptionJWS = subscriptionJWS "2000000812345710" "2000000812345711" [purchasedAt 1767225600000]
|
|
pendingSettled <- newIORef False
|
|
googleDown <- newIORef False
|
|
subscriptions <- newIORef M.empty
|
|
subscriptionCheckCount <- newIORef 0
|
|
let appleReceipts =
|
|
[ (appleSupporterJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" False 700),
|
|
(appleLegendJWS, appleTransaction "2000000812345672" "BADGE_LEGEND_01" False 7000),
|
|
(appleSandboxJWS, appleTransaction "2000000812345673" "BADGE_LEGEND_01" True 7000),
|
|
-- a verifier vouching for another transaction than the one the evidence names
|
|
(appleMisnamedJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" False 700),
|
|
(appleQuantityJWS, (appleTransaction "2000000812345697" "BADGE_SUPPORTER_01" False 1400) {quantity = 2}),
|
|
-- vouched by the ref the claim reads, the subscription's original id
|
|
(appleSubscriptionJWS, appleSubscription appleSubscriptionJWS False),
|
|
(appleRenewalSubscriptionJWS, appleSubscription appleRenewalSubscriptionJWS False),
|
|
(appleSandboxSubscriptionJWS, appleSubscription appleSandboxSubscriptionJWS True),
|
|
(appleLegendSubscriptionJWS, appleTransaction appleSubscriptionOriginalId "SUBSCR_BADGE_LEGEND_YEAR_01" False 7000),
|
|
(appleSecondSubscriptionJWS, appleSubscription appleSecondSubscriptionJWS False),
|
|
(appleThirdSubscriptionJWS, appleSubscription appleThirdSubscriptionJWS False)
|
|
]
|
|
verifyApple jws
|
|
| jws == appleThrowingJWS = error "fake verifier bug"
|
|
| otherwise = maybe (Left $ SRInvalid "not a fake receipt") Right $ lookup jws appleReceipts
|
|
verifyGoogle = googleVerdict pendingSettled googleDown
|
|
checkSubscription ref _ = do
|
|
modifyIORef' subscriptionCheckCount (+ 1)
|
|
down <- readIORef googleDown
|
|
case ref of
|
|
SubscriptionGoogle _ | down -> pure $ Left $ SRUnreachable "fake store is down"
|
|
_ -> maybe (Left $ SRUnreachable "the fake store knows no such subscription") Right . M.lookup (subscriptionKey ref) <$> readIORef subscriptions
|
|
pure
|
|
FakeStore
|
|
{ appleSupporterJWS,
|
|
appleLegendJWS,
|
|
appleSandboxJWS,
|
|
appleThrowingJWS,
|
|
appleMisnamedJWS,
|
|
appleQuantityJWS,
|
|
appleSubscriptionJWS,
|
|
appleRenewalSubscriptionJWS,
|
|
appleSandboxSubscriptionJWS,
|
|
appleRevokedSubscriptionJWS,
|
|
appleLegendSubscriptionJWS,
|
|
appleSecondSubscriptionJWS,
|
|
appleThirdSubscriptionJWS,
|
|
pendingSettled,
|
|
googleDown,
|
|
subscriptions,
|
|
subscriptionCheckCount,
|
|
fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle, acknowledgeGoogle = Nothing, acknowledgeGoogleSubscription = Nothing, checkSubscription = Just checkSubscription, verifyTimeout = 500000, storeChecks = ChecksAfterCoverage, creditTestPurchases = False}
|
|
}
|
|
where
|
|
fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir </> name)
|
|
appleTransaction transactionRef productId testPurchase cents =
|
|
VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase, paid = Just (CurrencyAmount cents, "USD"), alreadyAcknowledged = False}
|
|
purchasedAt ms = "purchaseDate" J..= (ms :: Int64)
|
|
appleSubscription jws testPurchase =
|
|
VerifiedStoreTransaction {transactionRef = fromMaybe "" (appleTransactionRef jws), productId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", quantity = 1, testPurchase, paid = Just (CurrencyAmount 700, "USD"), alreadyAcknowledged = False}
|
|
|
|
-- | A transaction of the subscription the original id names, with the payload fields given.
|
|
subscriptionJWS :: Text -> Text -> [Pair] -> Text
|
|
subscriptionJWS originalId transactionId fields =
|
|
unsignedJWS $
|
|
LB.toStrict $
|
|
J.encode $
|
|
J.object $
|
|
[ "transactionId" J..= transactionId,
|
|
"originalTransactionId" J..= originalId,
|
|
"type" J..= ("Auto-Renewable Subscription" :: Text),
|
|
"productId" J..= ("SUBSCR_BADGE_SUPPORTER_MONTH_01" :: Text)
|
|
]
|
|
<> fields
|
|
|
|
subscriptionKey :: SubscriptionRef -> Either Text Text
|
|
subscriptionKey = \case
|
|
SubscriptionApple originalId -> Left originalId
|
|
SubscriptionGoogle token -> Right token
|
|
|
|
setSubscription :: FakeStore -> SubscriptionRef -> SubscriptionCheck -> IO ()
|
|
setSubscription FakeStore {subscriptions} ref checked = modifyIORef' subscriptions $ M.insert (subscriptionKey ref) checked
|
|
|
|
subscriptionChecks :: FakeStore -> IO Int
|
|
subscriptionChecks FakeStore {subscriptionCheckCount} = readIORef subscriptionCheckCount
|
|
|
|
googleVerdict :: IORef Bool -> IORef Bool -> Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)
|
|
googleVerdict pendingSettled googleDown productId token =
|
|
readIORef googleDown >>= \case
|
|
True -> pure $ Left $ SRUnreachable "fake store is down"
|
|
False
|
|
| (productId, token) == ("badge_supporter_01", googleSupporterToken) -> pure $ Right purchased
|
|
| (productId, token) == ("badge_unknown_01", googleUnknownProductToken) -> pure $ Right purchased
|
|
| (productId, token) == ("badge_supporter_01", googlePendingToken) -> do
|
|
settled <- readIORef pendingSettled
|
|
pure $ if settled then Right purchased else Left SRPending
|
|
| token == googleUnreachableToken -> pure $ Left $ SRUnreachable "fake store is down"
|
|
| token == googleThrowingToken -> ioError $ userError "fake connection reset"
|
|
| token == googleHangingToken -> forever $ threadDelay 1000000
|
|
| otherwise -> pure $ Left $ SRInvalid "not a fake purchase"
|
|
where
|
|
purchased = VerifiedStoreTransaction {transactionRef = googlePurchaseRef token, productId, quantity = 1, testPurchase = False, paid = Nothing, alreadyAcknowledged = False}
|
|
|
|
-- | The fake store, running the hook's action once, inside the first Google verification, before it answers.
|
|
googleVerifierWithHook :: IORef (IO ()) -> FakeStore -> StoreVerifier
|
|
googleVerifierWithHook hook FakeStore {fakeVerifier = v@StoreVerifier {verifyGoogle}} =
|
|
v {verifyGoogle = hooked <$> verifyGoogle, verifyTimeout = 10000000}
|
|
where
|
|
hooked verify productId token = do
|
|
action <- atomicModifyIORef' hook (pure (),)
|
|
action
|
|
verify productId token
|
|
|
|
-- | The fake store, running the hook's action once, inside the first subscription check, before it answers.
|
|
subscriptionCheckWithHook :: IORef (IO ()) -> FakeStore -> StoreVerifier
|
|
subscriptionCheckWithHook hook FakeStore {fakeVerifier = v@StoreVerifier {checkSubscription}} =
|
|
v {checkSubscription = hooked <$> checkSubscription, verifyTimeout = 10000000}
|
|
where
|
|
hooked check ref product_ = do
|
|
action <- atomicModifyIORef' hook (pure (),)
|
|
action
|
|
check ref product_
|
|
|
|
settlePending :: FakeStore -> IO ()
|
|
settlePending FakeStore {pendingSettled} = writeIORef pendingSettled True
|
|
|
|
setGoogleDown :: FakeStore -> Bool -> IO ()
|
|
setGoogleDown FakeStore {googleDown} = writeIORef googleDown
|
|
|
|
googleSupporterToken, googlePendingToken, googleUnreachableToken, googleThrowingToken, googleHangingToken, googleSubscriptionToken, googleUnknownProductToken :: Text
|
|
googleSupporterToken = "fake-play-token-supporter.AO-J1Oz9x2kqE7wYt3"
|
|
googlePendingToken = "fake-play-token-pending.AO-J1Oy8w1jpD6vXs2"
|
|
googleUnreachableToken = "fake-play-token-unreachable.AO-J1Ox7v0ioC5uWr1"
|
|
googleThrowingToken = "fake-play-token-throwing.AO-J1Ov5t8gmA3sUp9"
|
|
googleHangingToken = "fake-play-token-hanging.AO-J1Ou4s7flZ2rTo8"
|
|
googleSubscriptionToken = "fake-play-token-subscription.AO-J1Ow6u9hnB4tVq0"
|
|
googleUnknownProductToken = "fake-play-token-unknown-product.AO-J1Ot3r6ekY1qSn7"
|
|
|
|
appleSubscriptionOriginalId, appleSecondSubscriptionOriginalId :: Text
|
|
appleSubscriptionOriginalId = "2000000812345680"
|
|
appleSecondSubscriptionOriginalId = "2000000812345700"
|
|
|
|
googlePayment :: Text -> Text -> ServicePayment
|
|
googlePayment productId token = SPGoogle {productId, token}
|
|
|
|
unsignedJWS :: B.ByteString -> Text
|
|
unsignedJWS payload = safeDecodeUtf8 $ B.intercalate "." $ map B64U.encodeUnpadded [header, payload, "not a signature"]
|
|
where
|
|
header = LB.toStrict $ J.encode $ J.object ["alg" J..= ("ES256" :: Text), "x5c" J..= (["leaf", "intermediate", "root"] :: [Text])]
|