core: don't reveal another profile when delivering a store purchase; bound store checks and restrict Play ids

apps/simplex-badge-service/src/BadgeService/StoreReceipts.hs

@@ -16,8 +16,10 @@ where
 
 import Control.Exception (evaluate)
 import Data.Bifunctor (first)
+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
+import qualified Data.Text as T
 import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (CurrencyAmount, PaymentProvider (..))
 import Simplex.Messaging.Util (catchOwn')
@@ -50,7 +52,9 @@ data StoreRefusal
 -- A store with no verifier deployed is unreachable: its purchases may be real.
 data StoreVerifier = StoreVerifier
   { verifyApple :: Maybe (Text -> Either Text StoreTransaction), -- the JWS; Left is why Apple did not sign it
-    verifyGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal StoreTransaction)) -- the product id and the token
+    verifyGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal StoreTransaction)), -- the product id and the token
+    -- microseconds; requests are answered one at a time, so a verifier that does not finish holds up every other one
+    verifyTimeout :: Int
   }
 
 -- | A store payment, named by the store's own reference before anything is verified.
@@ -61,28 +65,38 @@ data StoreReceipt = StoreReceipt
   }
 
 noStoreVerifier :: StoreVerifier
-noStoreVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Nothing}
+noStoreVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Nothing, verifyTimeout = 10000000}
 
 -- | Nothing for a payment no store made. Exceptions are not logged, since they can quote the receipt
 -- or, from Google, a URL holding the token.
 storeReceipt :: StoreVerifier -> ServicePayment -> Maybe (Either StoreRefusal StoreReceipt)
-storeReceipt StoreVerifier {verifyApple, verifyGoogle} = \case
+storeReceipt StoreVerifier {verifyApple, verifyGoogle, verifyTimeout} = \case
   SPApple {jws} -> Just $ case appleTransactionId jws of
     Nothing -> Left $ SRInvalid "names no transaction"
     Just ref -> Right $ StoreReceipt PPApple ref $ maybe unconfigured (\verify -> offline $ first SRInvalid $ verify jws) verifyApple
-  SPGoogle {productId, token} -> Just $ Right $ StoreReceipt PPGoogle (googlePurchaseRef token) $ maybe unconfigured (\verify -> online $ verify productId token) verifyGoogle
+  SPGoogle {productId, token}
+    -- the claim is the token's hash, so neither string may name any purchase but the one it claims,
+    -- whatever path a verifier builds from them
+    | not (googleProductId productId && googleToken token) -> Just $ Left $ SRInvalid "not a Play product id and token"
+    | otherwise -> Just $ Right $ StoreReceipt PPGoogle (googlePurchaseRef token) $ maybe unconfigured (\verify -> online $ verify productId token) verifyGoogle
   SPInvoice {} -> Nothing
   SPReceipt {} -> Nothing
   where
     unconfigured = pure $ Left $ SRUnreachable "no verifier configured"
-    -- nothing was fetched, so a throw is a bug or a malformed receipt, never an outage
-    offline verdict = forced verdict `catchOwn'` \_ -> pure $ Left $ SRVerifierFailed "apple verifier threw"
+    -- nothing was fetched, so a throw or an overrun is a bug or a malformed receipt, never an outage
+    offline verdict =
+      (fromMaybe (Left $ SRVerifierFailed "apple verifier timed out") <$> timeout verifyTimeout (forced verdict))
+        `catchOwn'` \_ -> pure $ Left $ SRVerifierFailed "apple verifier threw"
     online verify =
-      (fromMaybe (Left $ SRUnreachable "google verifier timed out") <$> timeout storeVerifyTimeout (verify >>= forced))
+      (fromMaybe (Left $ SRUnreachable "google verifier timed out") <$> timeout verifyTimeout (verify >>= forced))
         `catchOwn'` \_ -> pure $ Left $ SRUnreachable "google verifier threw"
     -- a verdict holding a thunk that throws would otherwise throw later, outside these handlers
     forced = either (fmap Left . evaluate) (fmap Right . evaluate)
 
--- | Requests are answered one at a time, so a store that does not answer holds up every other one.
-storeVerifyTimeout :: Int
-storeVerifyTimeout = 10000000
+googleProductId :: Text -> Bool
+googleProductId pid = case T.uncons pid of
+  Just (c, _) -> T.length pid <= 150 && (isAsciiLower c || isDigit c) && T.all (\x -> isAsciiLower x || isDigit x || x == '_' || x == '.') pid
+  Nothing -> False
+
+googleToken :: Text -> Bool
+googleToken t = not (T.null t) && T.length t <= 4096 && T.all (\x -> isAsciiLower x || isAsciiUpper x || isDigit x || x == '.' || x == '_' || x == '-') t

bots/src/API/Docs/Responses.hs

@@ -135,6 +135,7 @@ undocumentedResponses =
     "CRArchiveExported",
     "CRArchiveImported",
     "CRBadgeLedger",
+    "CRBadgePurchaseDelivered",
     "CRBadgeRedeemed",
     "CRBadgeState",
     "CRBroadcastSent",

src/Simplex/Chat/Controller.hs

@@ -871,6 +871,7 @@ data ChatResponse
   | CRServiceResponse {user :: User, responseData :: J.Object}
   | CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId}
   | CRBadgeRedeemed {user :: User, redeemedBadge :: LocalBadge, newBadge :: Bool, badgeState :: Maybe BadgeState}
+  | CRBadgePurchaseDelivered {user :: User} -- delivered to the profile it was first presented under, which may be hidden
   | CRBadgeState {user :: User, badgeState :: Maybe BadgeState}
   | CRBadgeLedger {user :: User, badgeLedger :: [StatementEntry]}
   | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}

src/Simplex/Chat/Library/Commands.hs

@@ -5257,8 +5257,10 @@ purchaseBadge nm presentingUser payment = do
     requestStashedBadge nm user sendTarget stash BSCPurchaseBadge {masterKey, payment, upgrade = Nothing} terminalReceiptError
   -- outside the badge lock: the chat lock must not be taken under it
   mapM_ presentUserBadgeToContacts present_
-  pure purchased
+  -- the owner may be hidden, so the answer is the same whether it is or not, and names only the presenter
+  pure $ if userId == presentingUserId then purchased else CRBadgePurchaseDelivered presentingUser
   where
+    User {userId = presentingUserId} = presentingUser
     -- the receipt will never be credited to this key; any other refusal may pass on a retry
     terminalReceiptError = \case
       BSEReceiptInvalid -> True

src/Simplex/Chat/View.hs

@@ -193,6 +193,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
   CRServiceReplyAccepted u (AgentConnId cId) -> ttyUser u [plain $ "service reply accepted, connection id: " <> safeDecodeUtf8 (strEncode cId)]
   -- the badge is only shown when it is the one now on the profile; a replayed code's badge may not be
   CRBadgeRedeemed u badge newBadge _ -> ttyUser u $ if newBadge then "badge redeemed" : viewContactBadge (Just badge) else ["badge already redeemed"]
+  CRBadgePurchaseDelivered u -> ttyUser u ["badge purchase delivered to another profile"]
   CRBadgeState u st -> ttyUser u $ viewUserBadgeState st
   CRBadgeLedger u entries -> ttyUser u $ viewBadgeLedger entries
   CRGroupCreated u g -> ttyUser u $ viewGroupCreated g testView

tests/BadgeTests.hs

@@ -10,6 +10,7 @@
 module BadgeTests (badgeTests) where
 
 import BadgeService.Service (badgeErrorRetryAfter, shownServiceRequest)
+import BadgeService.StoreReceipts (StoreReceipt (..), StoreRefusal (..), StoreVerifier (..), storeReceipt)
 import Control.Concurrent.STM (atomically)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Base64.URL as B64U
@@ -34,7 +35,7 @@ import Simplex.Chat (defaultChatConfig)
 import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..), badgeRetryInterval, chatErrorAgent)
 import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, storeTransactionRef)
 import Simplex.Chat.PaymentService (ServicePayment (..))
-import Simplex.Chat.PaymentService.Types (InvoiceId (..))
+import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..))
 import Simplex.Chat.Store.Badges (StoreTransactionRef (..))
 import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), AgentServiceError (..), SMPAgentError (..))
 import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay)
@@ -104,6 +105,7 @@ 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
 
 proofOf :: BadgeProof -> BBSProof
 proofOf (BadgeProof _ _ p _) = p
@@ -856,6 +858,19 @@ 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
+        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
+    Just (Right StoreReceipt {provider}) -> provider `shouldBe` PPGoogle
+    _ -> expectationFailure "a valid product id and token were refused"
+
 testCredentialResponseJSON :: IO ()
 testCredentialResponseJSON = do
   Right (_, sk) <- bbsKeyGen

tests/Bots/BadgeService/BotTests.hs

@@ -133,6 +133,7 @@ badgeServiceTests = do
     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
+    it "should deliver a purchase to a hidden profile without naming it" testPurchaseDeliveredToHiddenProfile
 
 badgeProfile :: Profile
 badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing}
@@ -1660,7 +1661,7 @@ testPurchaseSameReceiptOtherProfile ps =
       showActiveUser alice "alisa"
       -- the store transaction is the device's, so it stays with the profile it was bought under
       alice ##> ("/_badge purchase 2 " <> paymentArg supporterPlay)
-      alice <## "[user: alice] badge already redeemed"
+      alice <## "badge purchase delivered to another profile"
       rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
       alice ##> "/p"
       showActiveUser alice "alisa"
@@ -1677,10 +1678,28 @@ testPurchaseStrandedUnderOtherProfile ps =
       settlePending store
       -- presented again under whichever profile is active, the purchase reaches the keys alice stashed
       alice ##> unsettled 2
-      alice <## "[user: alice] badge redeemed"
-      alice <## "supporter badge - active"
-      alice <##. "expires "
+      alice <## "badge purchase delivered to another profile"
       rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1
       rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
       alice ##> "/user alice"
       showActiveUser alice "alice (Alice, * supporter)"
+
+testPurchaseDeliveredToHiddenProfile :: HasCallStack => TestParams -> IO ()
+testPurchaseDeliveredToHiddenProfile ps =
+  withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsStore = store} ->
+    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 redeem badge code: badge service error: payment_pending"
+      alice ##> "/create user alisa"
+      showActiveUser alice "alisa"
+      alice ##> "/_hide user 1 \"password\""
+      alice <## "user alice:"
+      alice <## "messages are hidden (use /tail to view)"
+      alice <## "profile is hidden"
+      settlePending store
+      -- the answer names only the presenting profile, and nothing printed names the hidden one
+      alice ##> unsettled 2
+      alice <## "badge purchase delivered to another profile"
+      alice ##> "/user alice password"
+      showActiveUser alice "alice (Alice, * supporter)"

tests/Bots/BadgeService/FakeStore.hs

@@ -73,7 +73,7 @@ newFakeStore = do
         appleThrowingJWS,
         pendingSettled,
         googleDown,
-        fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle}
+        fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle, verifyTimeout = 500000}
       }
   where
     fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir </> name)