core, badge service: share one store transaction reference, and mark a verified transaction as such

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

@@ -30,7 +30,7 @@ where
 import BadgeService.Config (PollConfig (..))
 import BadgeService.Orders (decide, settleOrder)
 import BadgeService.Providers (ListPass (..), PaymentSignal (..), Provider (..), ProviderError (..), Received (..), expiresItself, settleWindow)
-import BadgeService.Store.Invoices (InvoiceRow (..), OverdueInvoice (..), expireOverdue, getInvoiceByProviderRef, overdueInvoices, providerText, unpaidRefs)
+import BadgeService.Store.Invoices (InvoiceRow (..), OverdueInvoice (..), expireOverdue, getInvoiceByProviderRef, overdueInvoices, unpaidRefs)
 import BadgeService.Waiters (Waiters, publish, waitingCount, waitingCountSTM)
 import Control.Concurrent.STM
 import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try)
@@ -47,6 +47,7 @@ import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCu
 import Numeric.Natural (Natural)
 import Simplex.Chat.PaymentService.Types (InvoiceStatus (..), PaymentProvider)
 import Simplex.Messaging.Agent.Store.Common (DBStore)
+import Simplex.Messaging.Encoding.String (textEncode)
 import Simplex.Messaging.Util (tshow)
 
 -- | Allows for our clock running ahead of the provider's; an expired invoice can still be marked paid.
@@ -145,7 +146,7 @@ readsPerPass = 25
 
 coveringProvider :: PollerEnv -> UTCTime -> (Text, Text) -> IO (Maybe Provider)
 coveringProvider env@PollerEnv {peProviders} now (provider, ref) =
-  case find ((== provider) . providerText . pProvider) peProviders of
+  case find ((== provider) . textEncode . pProvider) peProviders of
     Just p -> pure (Just p)
     Nothing -> do
       due <- dueToWarn env now ("no provider for " <> provider)

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

@@ -66,6 +66,7 @@ import Simplex.Chat.Core (sendChatCmd, simplexChatCore)
 import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..), ciContentToText)
 import Simplex.Chat.Options (printDbOpts)
+import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
 import Simplex.Chat.Types (AgentInvId (..), Contact, User (..))
@@ -451,7 +452,7 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText
 -- | Every refusal is answered before anything is written, so it leaves the receipt unclaimed; and
 -- nothing is written until the credential is signed.
 purchaseWithReceipt :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeMasterKey -> StoreReceipt -> IO BadgeServiceResponse
-purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {provider, providerRef, verifyReceipt} =
+purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = providerRef}, verifyReceipt} =
   withDB' "getStorePayment" cc (\db -> getStorePaymentClaim db provider providerRef) >>= \case
     Left _ -> pure $ errorResponse BSEInternal
     Right claim
@@ -461,9 +462,9 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {provider, provide
           verifyReceipt >>= \case
             Left refusal -> storeRefusalResponse refusal
             -- the claim was read from the evidence before it was verified, so it must name the transaction the store vouched for
-            Right StoreTransaction {transactionRef}
+            Right VerifiedStoreTransaction {transactionRef}
               | transactionRef /= providerRef -> storeRefusalResponse $ SRVerifierFailed "verified a transaction other than the one claimed"
-            Right StoreTransaction {environment = SETest} -> storeRefusalResponse $ SRInvalid "test purchase"
+            Right VerifiedStoreTransaction {testPurchase = True} -> storeRefusalResponse $ SRInvalid "test purchase"
             -- another key's claim is told only once the store vouched for the receipt, or it would reveal which transactions were credited
             Right tx -> case claim of
               Unclaimed -> newPurchase tx
@@ -477,7 +478,7 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {provider, provide
         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 StoreTransaction {productId, quantity, paid} = case storeProduct provider productId of
+    newPurchase VerifiedStoreTransaction {productId, quantity, paid} = case storeProduct provider productId of
       Nothing -> pure $ errorResponse BSEProductUnavailable
       Just StoreProduct {badgeType, months} -> do
         now <- badgeNow cc

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

@@ -30,7 +30,7 @@ module BadgeService.Store
   )
 where
 
-import BadgeService.Store.Invoices (executeChanging, paymentStatusText, providerText)
+import BadgeService.Store.Invoices (executeChanging, paymentStatusText)
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -46,6 +46,7 @@ import Simplex.Chat.Store.Shared (insertedRowId)
 import Simplex.Messaging.Agent.Store.DB (Binary (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String (textEncode)
 import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow')
 
 #if defined(dbPostgres)
@@ -134,7 +135,7 @@ getStorePaymentClaim db provider providerRef =
         ORDER BY i.period_end DESC
         LIMIT 1
       |]
-      (providerText provider, providerRef)
+      (textEncode provider, providerRef)
 
 fundingClaim :: Maybe Int64 -> Maybe C.PublicKeyEd25519 -> Maybe (Binary ByteString) -> FundingClaim
 fundingClaim purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of
@@ -297,7 +298,7 @@ createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid,
         VALUES (?,?,?,?,?,?,?,?)
         ON CONFLICT (provider, provider_ref) DO NOTHING
       |]
-      (paymentId, providerText provider, providerRef, (\(CurrencyAmount a) -> a) . fst <$> paid, snd <$> paid, paymentStatusText PSSettled, now, now)
+      (paymentId, textEncode provider, providerRef, (\(CurrencyAmount a) -> a) . fst <$> paid, snd <$> paid, paymentStatusText PSSettled, now, now)
   if claimed == 0
     then pure Nothing
     else do

apps/simplex-badge-service/src/BadgeService/Store/Invoices.hs

@@ -17,7 +17,6 @@ module BadgeService.Store.Invoices
     getInvoice,
     getInvoiceByProviderRef,
     unpaidRefs,
-    providerText,
     codeHashExists,
     OverdueInvoice (..),
     overdueInvoices,
@@ -59,7 +58,7 @@ import Simplex.Chat.Store.Shared (insertedRowId)
 import Simplex.Chat.PaymentService.Types (CardProvider (..), CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore, withConnection, withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
-import Simplex.Messaging.Encoding.String (textEncode)
+import Simplex.Messaging.Encoding.String (textDecode, textEncode)
 import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 
 #if defined(dbPostgres)
@@ -290,25 +289,6 @@ qSeedBadgeOffer =
     "INSERT INTO @badge_offers (offer_id, price_id, months, free_months, discount, status, created_at) "
       <> "VALUES (?,?,?,?,?,?,?) ON CONFLICT (offer_id) DO NOTHING"
 
-providerText :: PaymentProvider -> Text
-providerText = \case
-  PPApple -> "apple"
-  PPGoogle -> "google"
-  PPStripe -> "stripe"
-  PPCrypto -> "crypto"
-  PPCode -> "code"
-  PPReceipt -> "receipt"
-
-textToProvider :: Text -> Maybe PaymentProvider
-textToProvider = \case
-  "apple" -> Just PPApple
-  "google" -> Just PPGoogle
-  "stripe" -> Just PPStripe
-  "crypto" -> Just PPCrypto
-  "code" -> Just PPCode
-  "receipt" -> Just PPReceipt
-  _ -> Nothing
-
 cryptoCurrencyText :: CryptoCurrency -> Text
 cryptoCurrencyText CCBtc = "btc"
 cryptoCurrencyText CCXmr = "xmr"
@@ -380,7 +360,7 @@ mkInvoiceRow
       :. (cryptoAmt, expiresAt, statusTxt, createdAt)
       :. (pAmount, pCryptoPaid, pCryptoDue, pPaidInFull, pStatus, pUpdatedAt)
     ) = do
-    provider <- note "invoices.provider" (textToProvider providerTxt)
+    provider <- note "invoices.provider" (textDecode providerTxt)
     status <- note "invoices.status" (textToInvoiceStatus statusTxt)
     destination <- note "invoice payment destination" (mkDestination url addr cryptoCur cryptoAmt)
     pure
@@ -462,7 +442,7 @@ insertInvoiceRows db NewInvoice {..} = do
   DB.execute
     db
     qInsertInvoice
-    ( (invId, providerText niProvider, price, discountAmount, Nothing :: Maybe Word32, amount, niCurrency)
+    ( (invId, textEncode niProvider, price, discountAmount, Nothing :: Maybe Word32, amount, niCurrency)
         :. (url, addr, cryptoCur, cryptoAmt, expiresAt, invoiceStatusText ISOpen, createdAt, createdAt)
     )
   DB.execute
@@ -526,7 +506,7 @@ overdueInvoices st cutoff = withConnection st $ \db -> do
   rows <- DB.query db qOverdueInvoices (Only (truncateToSecond cutoff))
   either (E.throwIO . StoreDecodeError) pure (traverse toOverdue rows)
   where
-    toOverdue (i, providerTxt, oiProviderRef, oiCreatedAt) = case textToProvider providerTxt of
+    toOverdue (i, providerTxt, oiProviderRef, oiCreatedAt) = case textDecode providerTxt of
       Just oiProvider -> Right OverdueInvoice {oiInvoiceId = InvoiceId i, oiProvider, oiProviderRef, oiCreatedAt}
       Nothing -> Left ("invoices.provider: " <> providerTxt)
 
@@ -591,7 +571,7 @@ upsertPayment db InvoiceRow {irInvoiceId, irProvider, irProviderRef, irCurrency}
   DB.execute
     db
     qUpsertPayment
-    ( (invId, invId, providerText irProvider, irProviderRef, amount)
+    ( (invId, invId, textEncode irProvider, irProviderRef, amount)
         :. (irCurrency, cryptoAmount, cryptoDue, if paidInFull then 1 :: Int else 0, paymentStatusText status, at, at)
     )
   where

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

@@ -4,8 +4,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module BadgeService.StoreReceipts
-  ( StoreTransaction (..),
-    StoreEnvironment (..),
+  ( VerifiedStoreTransaction (..),
     StoreRefusal (..),
     StoreVerifier (..),
     StoreReceipt (..),
@@ -21,25 +20,22 @@ 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.Chat.PaymentService.Types (CurrencyAmount, PaymentProvider (..), StoreTransactionRef (..))
 import Simplex.Messaging.Util (catchOwn')
 import System.Timeout (timeout)
 
 -- | What a store vouches for about one completed transaction.
-data StoreTransaction = StoreTransaction
+-- PaymentFunding's PFApple and PFGoogle hold much the same; the two are reconciled when PaymentFunding is built out.
+data VerifiedStoreTransaction = VerifiedStoreTransaction
   { transactionRef :: Text, -- from what was verified: Apple's transactionId, googlePurchaseRef of the token asked about
     productId :: Text,
     quantity :: Int,
-    environment :: StoreEnvironment,
+    -- 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
   }
   deriving (Eq, Show)
 
--- | A test purchase costs the buyer nothing: Apple's Sandbox, which a public TestFlight build buys
--- in, and Google's license testers.
-data StoreEnvironment = SEProduction | SETest
-  deriving (Eq, Show)
-
 -- | The reasons are for the service's log alone and must never quote the receipt.
 data StoreRefusal
   = SRInvalid Text -- a verdict that cannot change, and the client consumes the purchase: forged, malformed, another app's, refunded
@@ -52,17 +48,16 @@ data StoreRefusal
 -- | Not a Provider: a receipt is presented once as proof, with nothing to create, watch or cancel.
 -- Apple is checked offline, so its verifier is pure and cannot be unreachable; only Google is asked.
 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
+  { verifyApple :: Maybe (Text -> Either Text VerifiedStoreTransaction), -- the JWS; Left is why Apple did not sign it
+    verifyGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)), -- 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.
 data StoreReceipt = StoreReceipt
-  { provider :: PaymentProvider,
-    providerRef :: Text,
-    verifyReceipt :: IO (Either StoreRefusal StoreTransaction)
+  { txRef :: StoreTransactionRef,
+    verifyReceipt :: IO (Either StoreRefusal VerifiedStoreTransaction)
   }
 
 noStoreVerifier :: StoreVerifier
@@ -74,14 +69,14 @@ storeReceipt :: StoreVerifier -> ServicePayment -> Maybe (Either StoreRefusal St
 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
+    Just ref -> Right $ StoreReceipt (StoreTransactionRef PPApple ref) $ maybe unconfigured (\verify -> offline $ first SRInvalid $ verify jws) verifyApple
   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) -> Just $ Left $ SRInvalid "not a Play product id"
     -- Play documents no token grammar, so this is our guess, and refusing to ask Play is not its verdict
     | not (googleToken token) -> Just $ Left $ SRUnreachable "a Play token this service will not send"
-    | otherwise -> Just $ Right $ StoreReceipt PPGoogle (googlePurchaseRef token) $ maybe unconfigured (\verify -> online $ verify productId token) verifyGoogle
+    | otherwise -> Just $ Right $ StoreReceipt (StoreTransactionRef PPGoogle (googlePurchaseRef token)) $ maybe unconfigured (\verify -> online $ verify productId token) verifyGoogle
   SPInvoice {} -> Nothing
   SPReceipt {} -> Nothing
   where

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

@@ -18,7 +18,7 @@ import Simplex.Messaging.Util (eitherToMaybe)
 mockStoreVerifier :: StoreVerifier
 mockStoreVerifier = noStoreVerifier {verifyApple = Just mockApple, verifyGoogle = Just mockGoogle}
 
-mockApple :: Text -> Either Text StoreTransaction
+mockApple :: Text -> Either Text VerifiedStoreTransaction
 mockApple signed = case T.splitOn "." signed of
   [_, payload, _] -> do
     o <- case J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload) of
@@ -31,11 +31,11 @@ mockApple signed = case T.splitOn "." signed of
     Right $ vouched transactionRef productId
   _ -> Left "not three dot-separated parts"
 
-mockGoogle :: Text -> Text -> IO (Either StoreRefusal StoreTransaction)
+mockGoogle :: Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)
 mockGoogle productId token = pure $ Right $ vouched (googlePurchaseRef token) productId
 
-vouched :: Text -> Text -> StoreTransaction
+vouched :: Text -> Text -> VerifiedStoreTransaction
 vouched transactionRef productId =
-  -- not SETest, though nothing was paid: a test purchase is refused as receipt_invalid, which is
+  -- not a test purchase, though nothing was paid: a test purchase is refused as receipt_invalid, which is
   -- terminal and drops the client's keys, so every dev purchase would fail for good
-  StoreTransaction {transactionRef, productId, quantity = 1, environment = SEProduction, paid = Nothing}
+  VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase = False, paid = Nothing}

src/Simplex/Chat/Library/Commands.hs

@@ -77,6 +77,7 @@ import Simplex.Chat.Messages.CIContent.Events
 import Simplex.Chat.Operators
 import Simplex.Chat.Options
 import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef)
+import Simplex.Chat.PaymentService.Types (PaymentProvider (..), StoreTransactionRef (..))
 import Simplex.Chat.ProfileGenerator (generateRandomProfile)
 import Simplex.Chat.Protocol
 import Simplex.Chat.Remote
@@ -5280,8 +5281,8 @@ purchaseBadge nm presentingUser echoedInvoiceId payment = do
 -- | The same reference the service claims a transaction by, read without verifying anything.
 storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef
 storeTransactionRef = \case
-  SPApple {jws} -> StoreTransactionRef "apple" <$> appleTransactionId jws
-  SPGoogle {token} -> Just $ StoreTransactionRef "google" $ googlePurchaseRef token
+  SPApple {jws} -> StoreTransactionRef PPApple <$> appleTransactionId jws
+  SPGoogle {token} -> Just $ StoreTransactionRef PPGoogle $ googlePurchaseRef token
   SPInvoice {} -> Nothing
   SPReceipt {} -> Nothing
 

src/Simplex/Chat/PaymentService/Types.hs

@@ -1,6 +1,9 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.PaymentService.Types
@@ -8,6 +11,7 @@ module Simplex.Chat.PaymentService.Types
     InvoiceId (..),
     PaymentId (..),
     PaymentProvider (..),
+    StoreTransactionRef (..),
     CardProvider (..),
     CryptoCurrency (..),
     ServicePaymentMethod (..),
@@ -26,7 +30,16 @@ import Data.ByteString.Char8 (ByteString)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word32)
+import Simplex.Messaging.Agent.Store.DB (fromTextField_)
+import Simplex.Messaging.Encoding.String (TextEncoding (..))
 import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON)
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 -- USD etc. are in minor units, following Stripe etc. convention
 newtype CurrencyAmount = CurrencyAmount Word32
@@ -45,6 +58,32 @@ newtype PaymentId = PaymentId Text
 data PaymentProvider = PPApple | PPGoogle | PPStripe | PPCrypto | PPCode | PPReceipt
   deriving (Eq, Show)
 
+instance TextEncoding PaymentProvider where
+  textEncode = \case
+    PPApple -> "apple"
+    PPGoogle -> "google"
+    PPStripe -> "stripe"
+    PPCrypto -> "crypto"
+    PPCode -> "code"
+    PPReceipt -> "receipt"
+  textDecode = \case
+    "apple" -> Just PPApple
+    "google" -> Just PPGoogle
+    "stripe" -> Just PPStripe
+    "crypto" -> Just PPCrypto
+    "code" -> Just PPCode
+    "receipt" -> Just PPReceipt
+    _ -> Nothing
+
+instance FromField PaymentProvider where fromField = fromTextField_ textDecode
+
+instance ToField PaymentProvider where toField = toField . textEncode
+
+-- | A store and its own id for one transaction. The evidence is not the key: the store may sign it
+-- again, and a retry of the same purchase has to find the same stash.
+data StoreTransactionRef = StoreTransactionRef {provider :: PaymentProvider, transactionRef :: Text}
+  deriving (Eq, Show)
+
 data CardProvider = CPStripe
   deriving (Eq, Show)
 
@@ -100,6 +139,7 @@ data StoredPayment = StoredPayment
   deriving (Show)
 
 -- to review
+-- PFApple and PFGoogle hold much what the service's VerifiedStoreTransaction does; the two are reconciled when this is built out.
 data PaymentFunding
   = PFInvoice
       { invoiceId :: InvoiceId,

src/Simplex/Chat/Store/Badges.hs

@@ -9,7 +9,6 @@
 module Simplex.Chat.Store.Badges
   ( BadgeStash (..),
     BadgeStashRef (..),
-    StoreTransactionRef (..),
     UserBadgePurchase (..),
     getUserBadgePurchase,
     getBadgePurchase,
@@ -52,6 +51,7 @@ import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
 import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..), OpenStorePurchase (..))
+import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..))
 import Simplex.Chat.Store.Shared (insertedRowId)
 import Simplex.Chat.Types
 import Simplex.Messaging.Agent.Protocol (UserId)
@@ -80,11 +80,6 @@ data BadgeStash = BadgeStash
 
 data BadgeStashRef = BSRCodeRedemption Int64 | BSRStoreReceipt Int64
 
--- | A store and its own id for one transaction. The evidence is not the key: the store may sign it
--- again, and a retry of the same purchase has to find the same stash.
-data StoreTransactionRef = StoreTransactionRef {provider :: Text, transactionRef :: Text}
-  deriving (Eq, Show)
-
 getBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO (Maybe BadgeStash)
 getBadgeCodeRedemption db User {userId} code =
   maybeFirstRow (toBadgeStash BSRCodeRedemption) $

tests/BadgeTests.hs

@@ -10,7 +10,7 @@
 module BadgeTests (badgeTests) where
 
 import BadgeService.Service (badgeErrorRetryAfter, shownServiceRequest, survive)
-import BadgeService.StoreReceipts (StoreEnvironment (..), StoreReceipt (..), StoreRefusal (..), StoreTransaction (..), StoreVerifier (..), storeReceipt)
+import BadgeService.StoreReceipts (StoreReceipt (..), StoreRefusal (..), StoreVerifier (..), VerifiedStoreTransaction (..), storeReceipt)
 import BadgeService.StoreReceipts.Mock (mockStoreVerifier)
 import Control.Concurrent (forkIO, killThread, threadDelay)
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
@@ -39,8 +39,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 (..), PaymentProvider (..))
-import Simplex.Chat.Store.Badges (StoreTransactionRef (..))
+import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..), StoreTransactionRef (..))
 import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), AgentServiceError (..), SMPAgentError (..))
 import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay)
 import Simplex.Messaging.Crypto.BBS
@@ -843,14 +842,14 @@ testStoreTransactionRef = do
       part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
       apple = storeTransactionRef . SPApple
   -- the store may sign the same transaction again, and a retry must find the keys it stashed
-  apple (jws "2000000812345671" "c2lnbmVkIG9uY2U") `shouldBe` Just (StoreTransactionRef "apple" "2000000812345671")
+  apple (jws "2000000812345671" "c2lnbmVkIG9uY2U") `shouldBe` Just (StoreTransactionRef PPApple "2000000812345671")
   apple (jws "2000000812345671" "c2lnbmVkIGFnYWlu") `shouldBe` apple (jws "2000000812345671" "c2lnbmVkIG9uY2U")
   apple (jws "2000000812345672" "c2lnbmVkIG9uY2U") `shouldNotBe` apple (jws "2000000812345671" "c2lnbmVkIG9uY2U")
   apple "not.a-jws" `shouldBe` Nothing
   apple (T.intercalate "." [part "{}", part "{\"productId\":\"BADGE_SUPPORTER_01\"}", "sig"]) `shouldBe` Nothing
   -- a Play token is a bearer secret, so it is kept only as its hash
   let google = storeTransactionRef SPGoogle {productId = "badge_supporter_01", token = "play-token"}
-  google `shouldSatisfy` maybe False (\(StoreTransactionRef provider ref) -> provider == "google" && ref /= "play-token")
+  google `shouldSatisfy` maybe False (\(StoreTransactionRef provider ref) -> provider == PPGoogle && ref /= "play-token")
   google `shouldBe` storeTransactionRef SPGoogle {productId = "badge_supporter_01", token = "play-token"}
   storeTransactionRef SPInvoice {invoiceId = InvoiceId "inv"} `shouldBe` Nothing
 
@@ -873,7 +872,7 @@ testGoogleProductIdPath = do
         _ -> False
   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
+    Just (Right StoreReceipt {txRef = StoreTransactionRef {provider}}) -> provider `shouldBe` PPGoogle
     _ -> expectationFailure "a valid product id and token were refused"
 
 testGoogleTokenPath :: IO ()
@@ -894,9 +893,9 @@ testMockVouchesForClaim = do
   let part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
       signed = T.intercalate "." [part "{\"alg\":\"ES256\"}", part "{\"transactionId\":\"2000000812345671\",\"productId\":\"BADGE_SUPPORTER_01\"}", "c2lnbmVk"]
       vouchesForClaim payment = case storeReceipt mockStoreVerifier payment of
-        Just (Right StoreReceipt {providerRef, verifyReceipt}) ->
+        Just (Right StoreReceipt {txRef = StoreTransactionRef {transactionRef = providerRef}, verifyReceipt}) ->
           verifyReceipt >>= \case
-            Right StoreTransaction {transactionRef, environment} -> (transactionRef, environment) `shouldBe` (providerRef, SEProduction)
+            Right VerifiedStoreTransaction {transactionRef, testPurchase} -> (transactionRef, testPurchase) `shouldBe` (providerRef, False)
             Left refusal -> expectationFailure ("the mock refused: " <> show refusal)
         _ -> expectationFailure "refused before the mock was asked"
   vouchesForClaim SPApple {jws = signed}

tests/Bots/BadgeService/FakeStore.hs

@@ -59,11 +59,11 @@ newFakeStore = do
   pendingSettled <- newIORef False
   googleDown <- newIORef False
   let appleReceipts =
-        [ (appleSupporterJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" SEProduction 700),
-          (appleLegendJWS, appleTransaction "2000000812345672" "BADGE_LEGEND_01" SEProduction 7000),
-          (appleSandboxJWS, appleTransaction "2000000812345673" "BADGE_LEGEND_01" SETest 7000),
+        [ (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" SEProduction 700)
+          (appleMisnamedJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" False 700)
         ]
       verifyApple jws
         | jws == appleThrowingJWS = error "fake verifier bug"
@@ -82,10 +82,10 @@ newFakeStore = do
       }
   where
     fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir </> name)
-    appleTransaction transactionRef productId environment cents =
-      StoreTransaction {transactionRef, productId, quantity = 1, environment, paid = Just (CurrencyAmount cents, "USD")}
+    appleTransaction transactionRef productId testPurchase cents =
+      VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase, paid = Just (CurrencyAmount cents, "USD")}
 
-googleVerdict :: IORef Bool -> IORef Bool -> Text -> Text -> IO (Either StoreRefusal StoreTransaction)
+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"
@@ -100,7 +100,7 @@ googleVerdict pendingSettled googleDown productId token =
       | token == googleHangingToken -> forever $ threadDelay 1000000
       | otherwise -> pure $ Left $ SRInvalid "not a fake purchase"
   where
-    purchased = StoreTransaction {transactionRef = googlePurchaseRef token, productId, quantity = 1, environment = SEProduction, paid = Nothing}
+    purchased = VerifiedStoreTransaction {transactionRef = googlePurchaseRef token, productId, quantity = 1, testPurchase = False, paid = Nothing}
 
 settlePending :: FakeStore -> IO ()
 settlePending FakeStore {pendingSettled} = writeIORef pendingSettled True