diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md index 5340314da5..ef48a072ba 100644 --- a/apps/simplex-badge-service/README.md +++ b/apps/simplex-badge-service/README.md @@ -242,6 +242,8 @@ service_account_file = /etc/simplex-badge-service/play-service-account.json 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. + Play purchases are verified on a lane of their own, so a slow or unreachable Play delays only + other Play purchases, not code redemptions, renewals or App Store purchases. 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). diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 92eeeb195b..98a0a4c7ae 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -66,6 +66,7 @@ import Simplex.Chat.Bot.Store (withDB, withDB') import Simplex.Chat.Controller import Simplex.Chat.Core (sendChatCmd, simplexChatCore) import Simplex.Chat.Options (printDbOpts) +import Simplex.Chat.PaymentService (ServicePayment (..)) import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..)) import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal.Main (simplexChatCLI') @@ -288,9 +289,22 @@ issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = processQueuedRequests :: BadgeIssuerKey -> Maybe (TQueue GroupEvent) -> ServiceState -> IO () processQueuedRequests key trackerQ_ env = do cc <- atomically $ readTMVar $ serviceCC env - forever $ do - (u, reqId, sigKey, reqData) <- atomically $ readTQueue $ serviceRequestQ env - survive ("request " <> safeDecodeUtf8 (strEncode reqId)) $ handleServiceRequest key (storeVerifier env) cc trackerQ_ u reqId sigKey reqData + -- a Play hand-over can wait two verifyTimeouts on Play, so it waits on a lane of its own + playQ <- newTQueueIO + let answer (u, reqId, sigKey, reqData) = handleServiceRequest key (storeVerifier env) cc trackerQ_ u reqId sigKey reqData + route req@(_, _, _, reqData) + | presentsPlayReceipt reqData = atomically $ writeTQueue playQ req + | otherwise = answer req + lane q act = forever $ do + req@(_, reqId, _, _) <- atomically $ readTQueue q + survive ("request " <> safeDecodeUtf8 (strEncode reqId)) $ act req + raceAny_ [lane (serviceRequestQ env) route, lane playQ answer] + +-- | Only what creates a purchase leaves the main lane: an append to an existing ledger is guarded by nothing but that lane being serial. +presentsPlayReceipt :: J.Object -> Bool +presentsPlayReceipt reqData = case J.fromJSON (J.Object reqData) of + J.Success BadgeServiceRequest {request = BSCPurchaseBadge {payment = SPGoogle {}, upgrade = Nothing}} -> True + _ -> False -- | Cancellation is rethrown, since that is how the race stops this thread. The -- exception itself is not logged: it can quote the request, which carries codes and store receipts. @@ -465,10 +479,10 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTran Right (Left resp) -> resp _ -> errorResponse BSEInternal -- the product is read only for a receipt not yet credited, so retiring it leaves its replays answered - newPurchase VerifiedStoreTransaction {productId, paid} = case storeProduct provider productId of + newPurchase tx@VerifiedStoreTransaction {productId, paid} = case storeProduct provider productId of Nothing -> pure $ errorResponse BSEProductUnavailable Just StoreProduct {badgeType, months} -> - fromMaybe (pure $ Right ()) acknowledgeReceipt >>= \case + maybe (pure $ Right ()) ($ tx) acknowledgeReceipt >>= \case Left refusal -> storeRefusalResponse refusal Right () -> do now <- badgeNow cc diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs index 952a4d0152..2789e80c54 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs @@ -32,7 +32,8 @@ data VerifiedStoreTransaction = VerifiedStoreTransaction quantity :: Int, -- as the store reported it; the service refuses any but 1, as the apps never buy more -- costs the buyer nothing: Apple's Sandbox, which a public TestFlight build buys in, and Google's license testers testPurchase :: Bool, - paid :: Maybe (CurrencyAmount, Text) -- in minor units; Google's purchase record carries no price + paid :: Maybe (CurrencyAmount, Text), -- in minor units; Google's purchase record carries no price + alreadyAcknowledged :: Bool -- Play's record says acknowledged or consumed; other stores have nothing to acknowledge } deriving (Eq, Show) @@ -55,7 +56,7 @@ data StoreVerifier = StoreVerifier 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 + -- microseconds; a lane answers one request at a time, so a verifier that does not finish holds up the rest of its lane verifyTimeout :: Int } @@ -63,7 +64,7 @@ data StoreVerifier = StoreVerifier data StoreReceipt = StoreReceipt { txRef :: StoreTransactionRef, verifyReceipt :: IO (Either StoreRefusal VerifiedStoreTransaction), - acknowledgeReceipt :: Maybe (IO (Either StoreRefusal ())) + acknowledgeReceipt :: Maybe (VerifiedStoreTransaction -> IO (Either StoreRefusal ())) } noStoreVerifier :: StoreVerifier @@ -87,7 +88,7 @@ toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, veri StoreReceipt (StoreTransactionRef PPGoogle (googlePurchaseRef token)) (maybe unconfigured (\verify -> online "google verifier" $ verify productId token) verifyGoogle) - ((\acknowledge -> online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogle) + ((\acknowledge VerifiedStoreTransaction {alreadyAcknowledged} -> if alreadyAcknowledged then pure (Right ()) else online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogle) SPInvoice {} -> Nothing SPReceipt {} -> Nothing where diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Apple.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Apple.hs index 90cc69915c..42200fcc0c 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Apple.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Apple.hs @@ -143,7 +143,8 @@ transaction ourBundleId AppleTransaction {transactionId, productId, bundleId, en productId, quantity, testPurchase, - paid = paidOf price currency + paid = paidOf price currency, + alreadyAcknowledged = False } -- | Apple's price is in milliunits of the currency, whatever its minor unit. diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs index f70d8cba77..98cb1fc050 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Google.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -85,10 +86,7 @@ verifyPurchase env productId token = (>>= purchaseVerdict productId token) <$> r -- 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") + bimap acknowledging (const ()) <$> playCall env (\req -> req {method = methodPost}) (purchaseUrl env productId token <> ":acknowledge") where acknowledging = \case SRUnreachable reason -> SRUnreachable $ "acknowledging: " <> reason @@ -118,7 +116,7 @@ playCall env@PlayEnv {accessToken} prepare url = 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} +purchaseVerdict productId token ProductPurchase {purchaseState, purchaseType, purchaseQuantity, purchaseProductId, alreadyAcknowledged} | maybe False (/= productId) purchaseProductId = Left $ SRVerifierFailed "Play answered about another product" | otherwise = case purchaseState of 0 -> purchased <$> testPurchaseOf purchaseType @@ -133,7 +131,8 @@ purchaseVerdict productId token ProductPurchase {purchaseState, purchaseType, pu productId, quantity = fromMaybe 1 purchaseQuantity, testPurchase, - paid = Nothing + paid = Nothing, + alreadyAcknowledged } testPurchaseOf = \case Nothing -> Right False diff --git a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs index 5de05fbf99..f7b1a14c9b 100644 --- a/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs +++ b/apps/simplex-badge-service/src/BadgeService/StoreReceipts/Mock.hs @@ -38,4 +38,4 @@ vouched :: Text -> Text -> VerifiedStoreTransaction vouched transactionRef productId = -- 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} + VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase = False, paid = Nothing, alreadyAcknowledged = False} diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 2c52cc3445..dcc53d30b2 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -26,7 +26,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB import ChatClient import ChatTests.DBUtils import ChatTests.Utils -import Control.Concurrent (threadDelay) +import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay) import Control.Concurrent.Async (async, cancel) import Control.Concurrent.STM (TQueue, atomically, readTMVar, readTQueue) import Control.Monad (forM_, void, when) @@ -175,6 +175,8 @@ badgeServiceTests = do it "should delete a month-old record that will fund no badge, and keep held and credited ones" testStoreReceiptCleanup it "should keep a receipt whose attempt throws" testStoreReceiptAttemptThrows it "should credit a held receipt after the app restarts" testStoreReceiptAfterRestart + describe "the Play lane" $ do + it "should answer other requests while a Play receipt is with the store, and credit it once Play answers" testPlayHoldsNoOtherRequest badgeBotName :: Text badgeBotName = "SimpleX Badges" @@ -2306,6 +2308,40 @@ testStoreReceiptAfterRestart ps = do expectLinesWithin 60 alice (creditedLines "" invoiceId "1: supporter") ["subscribed 1 connections on server localhost"] heldStoreReceipts (chatController alice) `shouldReturn` 0 +testPlayHoldsNoOtherRequest :: HasCallStack => TestParams -> IO () +testPlayHoldsNoOtherRequest ps = do + entered <- newEmptyMVar + release <- newEmptyMVar + hook <- newIORef $ putMVar entered () >> takeMVar release + -- past the 20s line wait, so a request queued behind the held call cannot be answered in time + let holding store = (googleVerifierWithHook hook store) {verifyTimeout = 60000000} + withBadgeServiceVerifier ps holding $ \BadgeServiceEnv {bsClientCfg, bsAddress, bsController = cc, bsStore = FakeStore {appleSupporterJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> + withNewTestChatCfg ps bsClientCfg "cath" cathProfile $ \cath -> do + alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + storePurchaseOpen alice "" + timeout 30000000 (takeMVar entered) `shouldReturn` Just () + code <- issueCode cc BTSupporter 1 + bob ##> ("/_redeem_badge_code 1 " <> codeArg code) + bob <## "badge redeemed" + bob <## "supporter badge - active" + bob <##. "expires " + cath ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS}) + cath <### [StartsWith (openPurchase ""), StartsWith "1: supporter"] + g <- C.newRandom + (upgradeKey, upgradePriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519) + (fromPurchaseKey, fromPriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519) + masterKey <- generateMasterKey g + now <- getCurrentTime + let upgrade = BadgeUpgrade {fromPurchaseKey, receipt = "receipt", receiptSignature = C.sign' fromPriv "receipt", balance = BadgeBalance {lastEntry = emptyEntry now BTSupporter}} + upgradeReq = LB.unpack $ J.encode $ requestObject upgradeKey BSCPurchaseBadge {masterKey, payment = supporterPlay, upgrade = Just upgrade} + bob ##> ("/_service_request 1 " <> bsAddress <> " sign_key=" <> B.unpack (strEncode $ C.StoredPrivateKey upgradePriv) <> " " <> upgradeReq) + bob <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}" + putMVar release () + expectLinesWithin 60 alice ["1: supporter"] [] + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 3 + createInvoice :: HasCallStack => TestCC -> Int -> IO String createInvoice cc userId = do cc ##> ("/_badge invoice " <> show userId) diff --git a/tests/Bots/BadgeService/FakePlay.hs b/tests/Bots/BadgeService/FakePlay.hs index cc479853c7..f5b346a5e3 100644 --- a/tests/Bots/BadgeService/FakePlay.hs +++ b/tests/Bots/BadgeService/FakePlay.hs @@ -50,7 +50,8 @@ data FakePlay = FakePlay fpTokenSeconds :: TVar Int, fpGrantedTokens :: TVar [B.ByteString], fpPurchasePaths :: TVar [[Text]], - fpAcknowledgeRefusal :: TVar (Maybe Int), + -- what the acknowledge endpoint answers instead of acknowledging + fpAcknowledgeRefusal :: TVar (Maybe PlayAnswer), fpAcknowledged :: TVar [Text] } @@ -122,7 +123,7 @@ answerTokenRequests FakePlay {fpTokenRefusal} = atomically . writeTVar fpTokenRe grantTokensFor :: FakePlay -> Int -> IO () grantTokensFor FakePlay {fpTokenSeconds} = atomically . writeTVar fpTokenSeconds -answerAcknowledgements :: FakePlay -> Maybe Int -> IO () +answerAcknowledgements :: FakePlay -> Maybe PlayAnswer -> IO () answerAcknowledgements FakePlay {fpAcknowledgeRefusal} = atomically . writeTVar fpAcknowledgeRefusal fakeApp :: RSA.PublicKey -> FakePlay -> Application @@ -143,7 +144,7 @@ fakeApp key FakePlay {fpConfig = PlayStoreConfig {gTokenUrl}, fpAnswers, fpToken _ -> respond $ status unauthorized401 acknowledge token = readTVarIO fpAcknowledgeRefusal >>= \case - Just code -> respond $ status (mkStatus code "Refused") + Just answer -> answerWith answer Nothing -> do atomically $ modifyTVar' fpAcknowledged (<> [token]) respond $ responseLBS ok200 [] "" @@ -168,11 +169,13 @@ fakeApp key FakePlay {fpConfig = PlayStoreConfig {gTokenUrl}, fpAnswers, fpToken _ -> 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 + Just answer -> answerWith answer Nothing -> respond $ status notFound404 + answerWith = \case + PlayRecord v -> respond $ json ok200 v + PlayBody b -> respond $ responseLBS ok200 [(hContentType, "application/json")] b + PlayStatus code -> respond $ status (mkStatus code "Answer") + PlayHang -> forever $ threadDelay 1000000 json :: Status -> J.Value -> Response json st = responseLBS st [(hContentType, "application/json")] . J.encode diff --git a/tests/Bots/BadgeService/FakeStore.hs b/tests/Bots/BadgeService/FakeStore.hs index bede2de8e7..c8c7048a48 100644 --- a/tests/Bots/BadgeService/FakeStore.hs +++ b/tests/Bots/BadgeService/FakeStore.hs @@ -89,7 +89,7 @@ newFakeStore = do where fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir name) appleTransaction transactionRef productId testPurchase cents = - VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase, paid = Just (CurrencyAmount cents, "USD")} + VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase, paid = Just (CurrencyAmount cents, "USD"), alreadyAcknowledged = False} googleVerdict :: IORef Bool -> IORef Bool -> Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction) googleVerdict pendingSettled googleDown productId token = @@ -106,7 +106,7 @@ googleVerdict pendingSettled googleDown productId token = | 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} + 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 diff --git a/tests/Bots/BadgeService/StoreVerifierTests.hs b/tests/Bots/BadgeService/StoreVerifierTests.hs index be4e6f2e26..e428e0ed1e 100644 --- a/tests/Bots/BadgeService/StoreVerifierTests.hs +++ b/tests/Bots/BadgeService/StoreVerifierTests.hs @@ -71,6 +71,7 @@ badgeStoreVerifierTests = describe "badge store verifiers" $ do 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 "reads a purchase once to verify and acknowledge it, and acknowledges only what that read found unacknowledged" testPlayReadsPurchaseOnce it "reports an acknowledgement Play refuses or does not answer" testPlayAcknowledgementFails it "acknowledges through the verifier a [google] section configures" testPlayConfiguredAcknowledges @@ -219,7 +220,7 @@ 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")} + `shouldReturn` Right VerifiedStoreTransaction {transactionRef = "2000000900000001", productId = "BADGE_SUPPORTER_01", quantity = 1, testPurchase = False, paid = Just (CurrencyAmount 700, "USD"), alreadyAcknowledged = False} appleTransactionId jws `shouldBe` Just "2000000900000001" testAppleRootNotTrusted :: IO () @@ -371,7 +372,10 @@ playVerifier fake = acknowledgement :: StoreVerifier -> ServicePayment -> IO (Maybe (Either StoreRefusal ())) acknowledgement verifier payment = case toStoreReceipt verifier payment of - Just (Right StoreReceipt {acknowledgeReceipt}) -> sequence acknowledgeReceipt + Just (Right StoreReceipt {verifyReceipt, acknowledgeReceipt}) -> + verifyReceipt >>= \case + Right tx -> traverse ($ tx) acknowledgeReceipt + Left refusal -> expectationFailure ("not verified: " <> show refusal) >> undefined _ -> expectationFailure "not a store receipt" >> undefined playVerdict :: StoreVerifier -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction) @@ -406,7 +410,7 @@ 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} + `shouldReturn` Right VerifiedStoreTransaction {transactionRef = googlePurchaseRef testToken, productId = "badge_supporter_01", quantity = 1, testPurchase = False, paid = Nothing, alreadyAcknowledged = False} 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")] @@ -530,6 +534,18 @@ testPlayAcknowledges = withFakePlay $ \fake -> do acknowledging `shouldReturn` Just (Right ()) readTVarIO (fpAcknowledged fake) `shouldReturn` [testToken] +testPlayReadsPurchaseOnce :: IO () +testPlayReadsPurchaseOnce = do + requestsFor [] `shouldReturn` (1, [testToken]) + forM_ ["acknowledgementState", "consumptionState"] $ \state -> + requestsFor [(state, J.toJSON (1 :: Int))] `shouldReturn` (1, []) + where + requestsFor fields = withFakePlay $ \fake -> do + verifier <- playVerifier fake + answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 fields + acknowledgement verifier SPGoogle {productId = "badge_supporter_01", token = testToken} `shouldReturn` Just (Right ()) + (,) <$> (length <$> readTVarIO (fpPurchasePaths fake)) <*> readTVarIO (fpAcknowledged fake) + testPlayAcknowledgementFails :: IO () testPlayAcknowledgementFails = withFakePlay $ \fake -> do verifier <- playVerifier fake @@ -539,12 +555,11 @@ testPlayAcknowledgementFails = withFakePlay $ \fake -> do maybe "" reason r `shouldSatisfy` ("acknowledging: " `T.isPrefixOf`) maybe "" reason r `shouldNotSatisfy` (testToken `T.isInfixOf`) answerPurchase fake testToken $ PlayRecord $ purchaseRecord 0 [] - answerAcknowledgements fake $ Just 403 + answerAcknowledgements fake $ Just $ PlayStatus 403 acknowledgedAs Failed - answerAcknowledgements fake $ Just 503 + answerAcknowledgements fake $ Just $ PlayStatus 503 acknowledgedAs Unreachable - answerAcknowledgements fake Nothing - answerPurchase fake testToken PlayHang + answerAcknowledgements fake $ Just PlayHang acknowledgedAs Unreachable readTVarIO (fpAcknowledged fake) `shouldReturn` []