badge-service: answer Play purchases on a lane of their own (#7712)

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).

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

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

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.

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

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}