badge service: do not treat a Play token the service will not send as Play's refusal

tests/BadgeTests.hs

@@ -109,7 +109,8 @@ badgeTests = do
   describe "store purchases" $ do
     it "keys a purchase by the store's transaction id, not by the evidence signed over it" testStoreTransactionRef
     it "shows a service request in the terminal as its type alone" testShownServiceRequest
-    it "refuses a Play product id or token that could name another purchase, before any verifier" testGooglePathStrings
+    it "refuses for good a Play product id that could name another purchase, before any verifier" testGoogleProductIdPath
+    it "does not send a Play token that could name another purchase, and leaves it retryable" testGoogleTokenPath
     it "has the dev mock vouch for the transaction its claim names, as a production purchase" testMockVouchesForClaim
   describe "badge service request loop" $ do
     it "survives a request that throws, and still stops when cancelled" testSurviveRequestFailure
@@ -865,19 +866,29 @@ testShownServiceRequest = do
   shown BSCPurchaseBadge {masterKey = mk, payment = SPApple {jws = "a.b.c"}, upgrade = Nothing} `shouldBe` typeOnly "purchaseBadge"
   shown BSCRedeemBadgeCode {masterKey = mk, code = "SB-00000-00000-00000-00001"} `shouldBe` typeOnly "redeemBadgeCode"
 
-testGooglePathStrings :: IO ()
-testGooglePathStrings = do
-  let calledVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Just $ \_ _ -> error "verifier called", verifyTimeout = 500000}
-      refused productId token = case storeReceipt calledVerifier SPGoogle {productId, token} of
+testGoogleProductIdPath :: IO ()
+testGoogleProductIdPath = do
+  let refused productId = case storeReceipt uncalledVerifier SPGoogle {productId, token = validPlayToken} of
         Just (Left SRInvalid {}) -> True
         _ -> False
-      validToken = "fake-play-token.AO-J1Oz9x2kqE7wYt3"
-  mapM_ (\p -> refused p validToken `shouldBe` True) ["badge_legend_01/tokens/other?", "badge_legend_01?x", "badge_legend_01#x", "..", "../badge_legend_01", "Badge_legend_01", ""]
-  mapM_ (\t -> refused "badge_supporter_01" t `shouldBe` True) ["a/b", "../x", "t?x", "t#x", "t x", ""]
-  case storeReceipt calledVerifier SPGoogle {productId = "badge_supporter_01", token = validToken} of
+  mapM_ (\p -> refused p `shouldBe` True) ["badge_legend_01/tokens/other?", "badge_legend_01?x", "badge_legend_01#x", "..", "../badge_legend_01", "Badge_legend_01", ""]
+  case storeReceipt uncalledVerifier SPGoogle {productId = "badge_supporter_01", token = validPlayToken} of
     Just (Right StoreReceipt {provider}) -> provider `shouldBe` PPGoogle
     _ -> expectationFailure "a valid product id and token were refused"
 
+testGoogleTokenPath :: IO ()
+testGoogleTokenPath = do
+  let unsent token = case storeReceipt uncalledVerifier SPGoogle {productId = "badge_supporter_01", token} of
+        Just (Left SRUnreachable {}) -> True
+        _ -> False
+  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}
+
+validPlayToken :: T.Text
+validPlayToken = "fake-play-token.AO-J1Oz9x2kqE7wYt3"
+
 testMockVouchesForClaim :: IO ()
 testMockVouchesForClaim = do
   let part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8

tests/Bots/BadgeService/BotTests.hs

@@ -134,6 +134,7 @@ badgeServiceTests = do
     it "should redeem a Play purchase into a badge, and replay it as the same badge" testPurchaseBadge
     it "should redeem an App Store purchase by its JWS" testPurchaseBadgeAppStore
     it "should drop the keys of a receipt refused for good, and keep them while it is pending" testPurchaseStash
+    it "should keep the keys of a Play token the service will not send to Play" testPurchaseUnsentPlayToken
     it "should refuse a store purchase while a badge is held, before anything is sent" testPurchaseWhileBadgeHeld
     it "should answer a receipt presented under a second profile as the profile that bought it" testPurchaseSameReceiptOtherProfile
     it "should deliver a purchase first presented under another profile to that profile" testPurchaseStrandedUnderOtherProfile
@@ -315,10 +316,10 @@ testRedeemUnknownCode ps =
       g <- C.newRandom
       unknown <- randomBadgeCode g
       alice ##> ("/_redeem_badge_code 1 " <> codeArg unknown)
-      alice <## "cannot get badge:badge service error: code_invalid"
+      alice <## "cannot get badge: badge service error: code_invalid"
       -- a failed check character is refused before anything leaves the device
       alice ##> "/_redeem_badge_code 1 SB-00000-00000-00000-00001"
-      alice <## "cannot get badge:invalid code"
+      alice <## "cannot get badge: invalid code"
       -- sent straight to the service, past the client's own check, the two are one answer
       (_, redeemPriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
       redeemDirect alice bsLink redeemPriv (T.unpack $ badgeCodeText unknown)
@@ -369,7 +370,7 @@ testRedeemSecondCode ps =
       alice <## "supporter badge - active"
       alice <##. "expires "
       alice ##> ("/_redeem_badge_code 1 " <> codeArg legend)
-      alice <## "cannot get badge:badge already active"
+      alice <## "cannot get badge: badge already active"
       alice ##> "/p"
       showActiveUser alice "alice (Alice, * supporter)"
       alice ##> "/create user alisa"
@@ -391,7 +392,7 @@ testRedeemSameCodeOtherProfile ps =
       alice ##> "/create user alisa"
       showActiveUser alice "alisa"
       alice ##> ("/_redeem_badge_code 2 " <> codeArg code)
-      alice <## "cannot get badge:badge service error: code_used"
+      alice <## "cannot get badge: badge service error: code_used"
       alice ##> "/p"
       showActiveUser alice "alisa"
       alice ##> "/user alice"
@@ -1306,7 +1307,7 @@ testRedeemUnpaidCode ps =
     withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
       unpaid <- issueCodeAs cc BTSupporter 1 "unpaid"
       alice ##> ("/_redeem_badge_code 1 " <> codeArg unpaid)
-      alice <## "cannot get badge:badge service error: payment_pending"
+      alice <## "cannot get badge: badge service error: payment_pending"
       paid <- issueCodeAs cc BTSupporter 1 "paid"
       alice ##> ("/_redeem_badge_code 1 " <> codeArg paid)
       alice <## "badge redeemed"
@@ -1323,7 +1324,7 @@ testExpiredCode ps =
       withDB' "markCodePaid" cc (\db -> markCodePaid db (badgeCodeHash code) (addUTCTime (-60) now))
         `shouldReturn` Right ()
       alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
-      alice <## "cannot get badge:badge service error: code_expired"
+      alice <## "cannot get badge: badge service error: code_expired"
 
 testRedeemedBeforeTheDeadline :: HasCallStack => TestParams -> IO ()
 testRedeemedBeforeTheDeadline ps =
@@ -1377,7 +1378,7 @@ testRevokedCode ps =
       paid <- issueCodeAs cc BTSupporter 1 "paid"
       revokeCodeAs cc paid `shouldReturn` "revoked"
       alice ##> ("/_redeem_badge_code 1 " <> codeArg paid)
-      alice <## "cannot get badge:badge service error: code_invalid"
+      alice <## "cannot get badge: badge service error: code_invalid"
       second <- revokeCodeAs cc paid
       second `shouldSatisfy` T.isInfixOf "revoked already"
 
@@ -1575,7 +1576,7 @@ testPurchaseWithNoVerifier ps =
     nothingPurchased cc
     withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
       alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
-      alice <## "cannot get badge:badge service error: provider_not_configured"
+      alice <## "cannot get badge: badge service error: provider_not_configured"
       -- not yet rather than never, so the keys stay for the retry once a verifier is deployed
       rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1
 
@@ -1646,17 +1647,17 @@ testPurchaseStash ps =
       let stashes = rowCount (chatController alice) "badge_store_receipts"
       -- the store does not vouch for it, so the keys stashed for it can never be credited
       alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "not-a-purchase"))
-      alice <## "cannot get badge:badge service error: receipt_invalid"
+      alice <## "cannot get badge: badge service error: receipt_invalid"
       stashes `shouldReturn` 0
       -- no store transaction to key a stash by, so nothing is stashed or sent
       alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = "not.a-jws"})
-      alice <## "cannot get badge:invalid store receipt"
+      alice <## "cannot get badge: invalid store receipt"
       stashes `shouldReturn` 0
       nothingPurchased cc
       -- pending keeps the keys, and the settled purchase is credited to them, once
       let unsettled = "/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken)
       alice ##> unsettled
-      alice <## "cannot get badge:badge service error: payment_pending"
+      alice <## "cannot get badge: badge service error: payment_pending"
       stashes `shouldReturn` 1
       settlePending store
       alice ##> unsettled
@@ -1666,6 +1667,15 @@ testPurchaseStash ps =
       stashes `shouldReturn` 1
       rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
 
+testPurchaseUnsentPlayToken :: HasCallStack => TestParams -> IO ()
+testPurchaseUnsentPlayToken ps =
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "token/other"))
+      alice <## "cannot get badge: badge service error: provider_unavailable"
+      rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1
+      nothingPurchased cc
+
 testPurchaseWhileBadgeHeld :: HasCallStack => TestParams -> IO ()
 testPurchaseWhileBadgeHeld ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->
@@ -1673,7 +1683,7 @@ testPurchaseWhileBadgeHeld ps =
       code <- issueCode cc BTSupporter 1
       redeemFirstBadge alice code
       alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay)
-      alice <## "cannot get badge:badge already active"
+      alice <## "cannot get badge: badge already active"
       rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 0
       rowCount cc "sx_badge_service_payments" `shouldReturn` 0
 
@@ -1700,7 +1710,7 @@ testPurchaseStrandedUnderOtherProfile ps =
     withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
       let unsettled userId = "/_badge purchase " <> show (userId :: Int) <> " " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken)
       alice ##> unsettled 1
-      alice <## "cannot get badge:badge service error: payment_pending"
+      alice <## "cannot get badge: badge service error: payment_pending"
       alice ##> "/create user alisa"
       showActiveUser alice "alisa"
       settlePending store
@@ -1719,7 +1729,7 @@ testPurchaseDeliveredToHiddenProfile ps =
     withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
       let unsettled userId = "/_badge purchase " <> show (userId :: Int) <> " " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken)
       alice ##> unsettled 1
-      alice <## "cannot get badge:badge service error: payment_pending"
+      alice <## "cannot get badge: badge service error: payment_pending"
       alice ##> "/create user alisa"
       showActiveUser alice "alisa"
       alice ##> "/_hide user 1 \"password\""