store: send Stripe idempotency key and order ref

apps/simplex-store-service/README.md

@@ -212,6 +212,14 @@ absent `[btcpay]` does for Bitcoin and Monero. Its keys:
   it expired and logs an error. Check such orders in the Stripe Dashboard. After a restart, the
   hour starts again.
 
+The service creates each payment intent with `metadata[order]`, the order's reference:
+`name:0x<order hash>` for a name order (`order_hash` in `sx_badge_service_name_registrations`) or
+`badge:0x<code hash>` for a badge (`code_hash` in `sx_badge_service_badge_codes`). Neither is a secret,
+and support finds an intent's order from it in the Dashboard. The create also sends an
+`Idempotency-Key` of that reference with the amount and currency, so a buyer who sends the same order
+again after the first answer was lost gets the same intent, not a second one; Stripe keeps the key
+for 24 hours.
+
 The service fills `publishable_key` into the shell at boot: the built `index.html` ships
 with an empty `<meta id="stripe-publishable-key" name="stripe-publishable-key" content="">`
 (`web/public/index.html`), and the listener serves a copy with the configured key

apps/simplex-store-service/src/StoreService/Providers.hs

@@ -103,9 +103,11 @@ expiresItself = \case
 settleWindow :: NominalDiffTime
 settleWindow = 72 * 3600
 
+-- | odReference names the order, the same on every retry of it, and is not secret.
 data OrderDraft = OrderDraft
   { odAmount :: CurrencyAmount,
-    odCurrency :: Text
+    odCurrency :: Text,
+    odReference :: Text
   }
   deriving (Eq, Show)
 

apps/simplex-store-service/src/StoreService/Providers/Stripe.hs

@@ -142,7 +142,7 @@ listOpen env@StripeEnv {seCfg} = do
           let q =
                 [("created[gte]", Just createdGte), ("limit", Just (B8.pack (show listPageSize)))]
                   <> maybe [] (\a -> [("starting_after", Just (TE.encodeUtf8 a))]) after
-          got <- stripeApi env listWhat methodGet ["v1", "payment_intents"] q Nothing
+          got <- stripeApi env listWhat methodGet ["v1", "payment_intents"] q [] Nothing
           case got >>= decodeStripe listWhat of
             Left e -> pure (Left e)
             Right IntentList {ilData, ilHasMore} ->
@@ -238,14 +238,20 @@ instance J.FromJSON CreatedIntent where
 
 createInvoice :: StripeEnv -> ServicePaymentMethod -> OrderDraft -> IO (Either ProviderError ProviderInvoice)
 createInvoice _ (SPMCrypto _) _ = pure (Left (ProviderError "stripe offers no crypto payment method"))
-createInvoice env (SPMCard CPStripe) OrderDraft {odAmount = CurrencyAmount minor, odCurrency} = do
-  let form =
-        [ ("amount", B8.pack (show minor)),
-          ("currency", TE.encodeUtf8 (T.toLower odCurrency)),
+createInvoice env (SPMCard CPStripe) OrderDraft {odAmount = CurrencyAmount minor, odCurrency, odReference} = do
+  let amount = B8.pack (show minor)
+      currency = TE.encodeUtf8 (T.toLower odCurrency)
+      reference = TE.encodeUtf8 odReference
+      form =
+        [ ("amount", amount),
+          ("currency", currency),
           -- Only card is offered, because a redirect-based method would navigate the top window out of the embedded frame.
-          ("allowed_payment_method_types[]", "card")
+          ("allowed_payment_method_types[]", "card"),
+          ("metadata[order]", reference)
         ]
-  created <- stripeApi env what methodPost ["v1", "payment_intents"] [] (Just form)
+      -- Stripe answers a create sent again with the same key, for 24 hours, with the intent the first one made.
+      idempotencyKey = B8.intercalate ":" [reference, amount, currency]
+  created <- stripeApi env what methodPost ["v1", "payment_intents"] [] [("Idempotency-Key", idempotencyKey)] (Just form)
   pure $ created >>= decodeStripe what <&> \CreatedIntent {ciId, ciClientSecret} ->
     ProviderInvoice {piProviderRef = ciId, piDestination = SPDCard CPStripe ciClientSecret}
   where
@@ -253,12 +259,12 @@ createInvoice env (SPMCard CPStripe) OrderDraft {odAmount = CurrencyAmount minor
 
 cancelInvoice :: StripeEnv -> Text -> IO (Either ProviderError ())
 cancelInvoice env pid =
-  fmap (fmap (const ())) $ stripeApi env "cancel intent" methodPost ["v1", "payment_intents", pid, "cancel"] [] (Just [])
+  fmap (fmap (const ())) $ stripeApi env "cancel intent" methodPost ["v1", "payment_intents", pid, "cancel"] [] [] (Just [])
 
 readInvoice :: StripeEnv -> Text -> IO (Either ProviderError (Maybe PaymentSignal))
 readInvoice env pid = do
   now <- getCurrentTime
-  got <- stripeApi env what methodGet ["v1", "payment_intents", pid] [("expand[]", Just "latest_charge")] Nothing
+  got <- stripeApi env what methodGet ["v1", "payment_intents", pid] [("expand[]", Just "latest_charge")] [] Nothing
   pure $ got >>= decodeStripe what >>= signalOf now
   where
     what = "read intent " <> pid
@@ -325,9 +331,10 @@ stripeApi ::
   Method ->
   [Text] ->
   Query ->
+  [Header] ->
   Maybe [(ByteString, ByteString)] ->
   IO (Either ProviderError LB.ByteString)
-stripeApi StripeEnv {seCfg, seManager} what verb segments query form = do
+stripeApi StripeEnv {seCfg, seManager} what verb segments query headers form = do
   r <- try $ do
     req0 <- parseRequest (T.unpack url)
     -- applyBasicAuth must wrap the record update, because updating requestHeaders after it would drop the header it adds.
@@ -338,7 +345,8 @@ stripeApi StripeEnv {seCfg, seManager} what verb segments query form = do
                 requestHeaders =
                   ("Accept", "application/json")
                     : ("Stripe-Version", stripeApiVersion)
-                    : [("Content-Type", "application/x-www-form-urlencoded") | isJust form],
+                    : [("Content-Type", "application/x-www-form-urlencoded") | isJust form]
+                    <> headers,
                 requestBody = RequestBodyBS (maybe "" (renderSimpleQuery False) form)
               }
     withResponse req seManager $ \resp -> do

apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs

@@ -23,6 +23,7 @@ import Data.Aeson ((.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as KM
 import Data.Bifunctor (first)
+import Data.ByteString (ByteString)
 import Data.Maybe (isJust, maybeToList)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime, addUTCTime)
@@ -38,6 +39,7 @@ import Simplex.Messaging.Util (tshow)
 import StoreService.Catalog (catalogCurrency)
 import StoreService.Config (NamesConfig (..), ServiceConfig)
 import StoreService.Log (logError, logInfo, logWarn)
+import StoreService.Names.Abi (hex)
 import StoreService.Names.Balances (Spend (..), checkSpendBalance, coveredOrderInsert, differenceOrderInsert, spendTerms)
 import StoreService.Names.Codes (CodeRefusal (..), readPrepaidCode)
 import StoreService.Names.Orders
@@ -97,7 +99,7 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters
   where
     what = "POST /api/invoice (name)"
     refuse = refused what
-    newOrder InvoiceOrder {ioRequest = req@OrderRequest {orFields = fields@OrderFields {ofLabelHash, ofLength, ofDuration}, orTimestamp}, ioMethod, ioPrice} = do
+    newOrder InvoiceOrder {ioRequest = req@OrderRequest {orOwner, orFields = fields@OrderFields {ofLabelHash, ofLength, ofDuration}, orTimestamp}, ioMethod, ioPrice} = do
       now <- oeNow
       let years = nYears $ oeConfig env
           price = fromIntegral ioPrice
@@ -111,12 +113,13 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters
           insert new paid db at = first (const OROrderExists) <$> createPaidRegistration db new (OTInvoice ioMethod price) paid at
       firstRefusal checks >>= \case
         Just refusal -> refuse refusal
-        Nothing -> createAtProvider env cfg providers waiters what InvoicedOrder {ivRequest = req, ivHolders = [], ivMethod = ioMethod, ivPrice = price, ivAmount = ioPrice, ivInsert = insert}
+        Nothing -> createAtProvider env cfg providers waiters what InvoicedOrder {ivRequest = req, ivOrderHash = orderHash orOwner fields (OTInvoice ioMethod price), ivHolders = [], ivMethod = ioMethod, ivPrice = price, ivAmount = ioPrice, ivInsert = insert}
 
--- | An order paid by invoice: the holders its transaction closes, the order's price, what its invoice asks
+-- | An order paid by invoice: its order hash, the holders its transaction closes, the order's price, what its invoice asks
 -- (less than the price when a balance paid the rest), and its insert after the invoice row's.
 data InvoicedOrder = InvoicedOrder
   { ivRequest :: OrderRequest,
+    ivOrderHash :: ByteString,
     ivHolders :: [NameRegistration],
     ivMethod :: ServicePaymentMethod,
     ivPrice :: Int,
@@ -126,7 +129,7 @@ data InvoicedOrder = InvoicedOrder
 
 -- | The invoice is made at the provider first, then the order is written with its invoice row; an order not written has its invoice cancelled there.
 createAtProvider :: OrdersEnv -> ServiceConfig -> [Provider] -> Waiters -> Text -> InvoicedOrder -> IO Answer
-createAtProvider env@OrdersEnv {oeStore, oeConfig, oeNow} cfg providers waiters what InvoicedOrder {ivRequest = req@OrderRequest {orOwner, orFields}, ivHolders, ivMethod, ivPrice, ivAmount, ivInsert} =
+createAtProvider env@OrdersEnv {oeStore, oeConfig, oeNow} cfg providers waiters what InvoicedOrder {ivRequest = req@OrderRequest {orOwner, orFields}, ivOrderHash, ivHolders, ivMethod, ivPrice, ivAmount, ivInsert} =
   case providerFor providers ivMethod of
     Nothing -> do
       logInfo (what <> " refused: no provider configured for " <> tshow ivMethod)
@@ -135,7 +138,7 @@ createAtProvider env@OrdersEnv {oeStore, oeConfig, oeNow} cfg providers waiters
       invId <- newInvoiceId
       now <- truncateToSecond <$> oeNow
       let amount = CurrencyAmount ivAmount
-      pCreateInvoice provider ivMethod OrderDraft {odAmount = amount, odCurrency = catalogCurrency} >>= \case
+      pCreateInvoice provider ivMethod OrderDraft {odAmount = amount, odCurrency = catalogCurrency, odReference = "name:" <> hex ivOrderHash} >>= \case
         Left (ProviderError e) -> do
           logError (what <> " failed: provider refused to create an invoice: " <> e)
           pure $ answerNow providerUnavailable
@@ -275,7 +278,7 @@ spendHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} cfg
         | spPrice - spBalance < minCardChargeCents -> refuse ORBadRequest
       Just method ->
         createAtProvider env cfg providers waiters what $
-          InvoicedOrder {ivRequest = order, ivHolders = maybeToList holder, ivMethod = method, ivPrice = spPrice, ivAmount = fromIntegral (spPrice - spBalance), ivInsert = differenceOrderInsert spend}
+          InvoicedOrder {ivRequest = order, ivOrderHash = orderHash orOwner orFields (spendTerms spend), ivHolders = maybeToList holder, ivMethod = method, ivPrice = spPrice, ivAmount = fromIntegral (spPrice - spBalance), ivInsert = differenceOrderInsert spend}
 
 -- | Stripe refuses a USD charge under 50 cents, so the page offers only crypto for a smaller difference.
 minCardChargeCents :: Int

apps/simplex-store-service/src/StoreService/Web/Server.hs

@@ -18,6 +18,7 @@ where
 
 import StoreService.Catalog (PricedOffer (..), priceOffer)
 import StoreService.Config (ListenerConfig (..), ServiceConfig (..), StripeConfig (..))
+import StoreService.Names.Abi (hex)
 import StoreService.Names.Env (NamesEnv)
 import StoreService.Names.Orders (OrdersEnv (..), ordersEnv)
 import StoreService.Names.Phases (RegistrationId, awaitChange)
@@ -419,7 +420,7 @@ createAtProvider WebEnv {weStore, weConfig} provider CreateRequest {crPriceId, c
       -- truncate once, so the response, the row and the provider get the same value
       now <- truncateToSecond <$> getCurrentTime
       let expiresAt = addUTCTime (invoiceWindow weConfig crMethod) now
-          draft = OrderDraft {odAmount = poAmount priced, odCurrency = poCurrency priced}
+          draft = OrderDraft {odAmount = poAmount priced, odCurrency = poCurrency priced, odReference = "badge:" <> hex crCodeHash}
       pCreateInvoice provider crMethod draft >>= \case
         Left (ProviderError e) -> failed ("provider refused to create an invoice: " <> e) providerUnavailable
         Right ProviderInvoice {piProviderRef, piDestination} -> do

tests/Bots/StoreService/BTCPayTests.hs

@@ -676,7 +676,8 @@ fiftyFourDollars :: OrderDraft
 fiftyFourDollars =
   OrderDraft
     { odAmount = CurrencyAmount 5400,
-      odCurrency = "usd"
+      odCurrency = "usd",
+      odReference = "badge:0x01"
     }
 
 exampleCeiling :: Int

tests/Bots/StoreService/FakeStripe.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 module Bots.StoreService.FakeStripe
   ( FakeStripe (..),
@@ -104,7 +105,9 @@ data FakeState = FakeState
     fsFail :: FailPlan,
     fsList :: Text,
     fsPageSize :: Maybe Int,
-    fsRequests :: [FakeRequest]
+    fsRequests :: [FakeRequest],
+    -- | The intent each Idempotency-Key created, which Stripe answers a repeated create with.
+    fsIdempotent :: M.Map ByteString Text
   }
 
 initialState :: FakeState
@@ -115,6 +118,7 @@ initialState =
       fsFail = FailPlan {fpCalls = 0, fpStatus = 0},
       fsList = "intent-list",
       fsPageSize = Nothing,
+      fsIdempotent = M.empty,
       fsRequests = []
     }
 
@@ -290,12 +294,16 @@ fakeApp stv req respond = do
       let form = parseSimpleQuery (LB.toStrict b)
           amount = fromMaybe 0 (lookup "amount" form >>= readMaybe . B8.unpack)
           currency = maybe "usd" TE.decodeUtf8 (lookup "currency" form)
+          key = lookup "Idempotency-Key" (requestHeaders req)
       (pid, s) <- atomically $ do
         st <- readTVar stv
-        let pid = "pi_test_" <> T.justifyRight 4 '0' (tshow (fsNextId st))
-            s = IntentState {isStatus = "requires_payment_method", isAmount = amount, isCurrency = currency}
-        writeTVar stv st {fsNextId = fsNextId st + 1, fsIntents = M.insert pid s (fsIntents st)}
-        pure (pid, s)
+        case (key >>= (`M.lookup` fsIdempotent st)) >>= \pid -> (pid,) <$> M.lookup pid (fsIntents st) of
+          Just created -> pure created
+          Nothing -> do
+            let pid = "pi_test_" <> T.justifyRight 4 '0' (tshow (fsNextId st))
+                s = IntentState {isStatus = "requires_payment_method", isAmount = amount, isCurrency = currency}
+            writeTVar stv st {fsNextId = fsNextId st + 1, fsIntents = M.insert pid s (fsIntents st), fsIdempotent = maybe id (`M.insert` pid) key (fsIdempotent st)}
+            pure (pid, s)
       serve (intentFixture s) (patchIntent pid s)
 
     -- Real Stripe can't cancel a card payment that is processing, paid or already cancelled.

tests/Bots/StoreService/NamesOrdersTests.hs

@@ -496,7 +496,8 @@ testPaidOrder = withOrders $ \ctx -> do
   field "price" r `shouldBe` Just (J.Number 10000)
   field "duration" r `shouldBe` Just (J.toJSON $ durationAt orderTime)
   field "terms" r `shouldBe` Just (J.String termsVersion)
-  stubCalls (cStub ctx) `shouldReturn` [StubCreate (SPMCrypto CCBtc) OrderDraft {odAmount = CurrencyAmount 10000, odCurrency = "usd"}]
+  let reference = "name:" <> hex (orderHash ownerA (fieldsOf aliceOrder) (OTInvoice (SPMCrypto CCBtc) 10000))
+  stubCalls (cStub ctx) `shouldReturn` [StubCreate (SPMCrypto CCBtc) OrderDraft {odAmount = CurrencyAmount 10000, odCurrency = "usd", odReference = reference}]
   reg <- invoiceRegistration ctx invId
   (nrPhase reg, nrLive reg, nrVersion reg, nrYears reg, nrPrice reg, nrPayment reg) `shouldBe` (PUnpaid, True, 1, 2, 10000, RPInvoice (SPMCrypto CCBtc) invId)
   nrOrderHash reg `shouldBe` orderHash ownerA (fieldsOf aliceOrder) (OTInvoice (SPMCrypto CCBtc) 10000)

tests/Bots/StoreService/NamesSpendTests.hs

@@ -286,9 +286,9 @@ testDifferenceSpend = withSpend $ \ctx -> do
       r = registrationOf <$> v
   (field "status" =<< v, field "amount" =<< v, field "expiresAt" =<< v) `shouldBe` (Just "open", Just (J.Number 4000), Just (J.toJSON expiry))
   (field "phase" =<< r, field "price" =<< r, field "fromBalance" =<< r) `shouldBe` (Just "unpaid", Just (J.Number 10000), Just (J.Number 6000))
-  stubCalls (cStub ctx) `shouldReturn` [StubCreate btc OrderDraft {odAmount = CurrencyAmount 4000, odCurrency = "usd"}]
   let invId = invoiceIdOf v
   holder <- invoiceRegistration ctx invId
+  stubCalls (cStub ctx) `shouldReturn` [StubCreate btc OrderDraft {odAmount = CurrencyAmount 4000, odCurrency = "usd", odReference = "name:" <> hex (nrOrderHash holder)}]
   (nrPhase holder, nrLive holder, nrPrice holder, nrPayment holder, nrBalanceSource holder, nrBalanceUsed holder) `shouldBe` (PUnpaid, True, 10000, RPInvoice btc invId, Just src, 6000)
   nrOrderHash holder `shouldBe` orderHash ownerA (fieldsOf aliceOrder) (OTBalance src 10000 6000 (Just btc))
   nrAgreedTerms holder `shouldBe` oTerms aliceOrder

tests/Bots/StoreService/StripeTests.hs

@@ -29,6 +29,7 @@ import Data.Maybe (isNothing)
 import Data.Word (Word32)
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import Data.Time.Clock (UTCTime, getCurrentTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Network.HTTP.Types (hAuthorization, parseSimpleQuery)
@@ -48,6 +49,7 @@ badgeStripeTests = describe "badge stripe adapter" $ do
   describe "against the fake Stripe" $ do
     it "creates a PaymentIntent and reads back the client secret" testFakeCreatesCard
     it "sends the create form Stripe documents, over HTTP Basic" testFakeCreateBody
+    it "sends an Idempotency-Key of the order, so a create sent again gets the same intent" testFakeCreateIsIdempotent
     it "is refused when the secret key is wrong, rather than passing silently" testFakeWrongSecretKey
     it "walks requires_payment_method through processing to succeeded, then refuses a cancel" testFakeLifecycle
     it "cancels an open intent once, then refuses a second cancel" testFakeCancel
@@ -75,7 +77,10 @@ badgeStripeTests = describe "badge stripe adapter" $ do
     it "accepts a signature up to 15 minutes from now, either way, and refuses one further out" testWebhookTimestampWindow
 
 fiftyFourDollars :: OrderDraft
-fiftyFourDollars = OrderDraft {odAmount = CurrencyAmount 5400, odCurrency = "usd"}
+fiftyFourDollars = OrderDraft {odAmount = CurrencyAmount 5400, odCurrency = "usd", odReference = sampleReference}
+
+sampleReference :: Text
+sampleReference = "name:0x6a3c0f1e9b2d4c5a8e7f60192a3b4c5d6e7f8091a2b3c4d5e6f708192a3b4c5d"
 
 fiftyFourDollarsReceived :: Received
 fiftyFourDollarsReceived = cardReceived 5400 5400
@@ -141,9 +146,21 @@ testFakeCreateBody = withProvider $ \fake p -> do
       lookup "currency" form `shouldBe` Just "usd"
       -- Card only keeps the client confirm from redirecting the top window out of the embedded frame.
       lookup "allowed_payment_method_types[]" form `shouldBe` Just "card"
+      lookup "metadata[order]" form `shouldBe` Just (TE.encodeUtf8 sampleReference)
+      lookup "Idempotency-Key" (frHeaders created) `shouldBe` Just (TE.encodeUtf8 sampleReference <> ":5400:usd")
       lookup hAuthorization (frHeaders created) `shouldSatisfy` maybe False ("Basic " `B8.isPrefixOf`)
     _ -> expectationFailure ("expected one create, got " <> show (length posts))
 
+-- | Stripe answers a create sent again with the same Idempotency-Key with the intent the first one made.
+testFakeCreateIsIdempotent :: IO ()
+testFakeCreateIsIdempotent = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = first} <- createdInvoice p (SPMCard CPStripe)
+  ProviderInvoice {piProviderRef = again} <- createdInvoice p (SPMCard CPStripe)
+  again `shouldBe` first
+  other <- pCreateInvoice p (SPMCard CPStripe) fiftyFourDollars {odReference = "badge:0x01"}
+  fmap piProviderRef other `shouldSatisfy` either (const False) (/= first)
+  length <$> fakeIntentIds fake `shouldReturn` 2
+
 testFakeWrongSecretKey :: IO ()
 testFakeWrongSecretKey = bounded $ withFakeStripe $ \fake -> do
   p <- stripeProvider (fsConfig fake) {sSecretKey = "sk_test_wrong"}

tests/Bots/StoreService/WebTests.hs

@@ -37,6 +37,7 @@ where
 import StoreService.Catalog (catalogCurrency, defaultCatalog)
 import StoreService.Config (BTCPayConfig (..), ListenerConfig (..), PollConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..))
 import StoreService.Log (logInfo)
+import StoreService.Names.Abi (hex)
 import StoreService.Orders (cancelOpenInvoice, codeLifetime, expireOverdue, settleOrder)
 import StoreService.Poller
 import StoreService.Providers
@@ -953,7 +954,7 @@ setVerifyThrows :: IORef StubState -> Bool -> IO ()
 setVerifyThrows ref throws = atomicModifyIORef' ref $ \s -> (s {ssVerifyThrows = throws}, ())
 
 sampleDraft :: OrderDraft
-sampleDraft = OrderDraft {odAmount = CurrencyAmount 500, odCurrency = "usd"}
+sampleDraft = OrderDraft {odAmount = CurrencyAmount 500, odCurrency = "usd", odReference = "badge:0x01"}
 
 sampleProviderInvoice :: ProviderInvoice
 sampleProviderInvoice = ProviderInvoice {piProviderRef = "pref-1", piDestination = SPDCrypto CCBtc "bc1qexampleaddress" "0.00050000"}
@@ -1841,6 +1842,7 @@ testCreateInvoice = bounded "create invoice" $ withCheckout $ \ref env client ->
       method `shouldBe` SPMCrypto CCBtc
       odAmount draft `shouldBe` CurrencyAmount 500
       odCurrency draft `shouldBe` "usd"
+      odReference draft `shouldBe` "badge:" <> hex (codeDigest sampleCode)
     other -> expectationFailure ("provider calls: " <> show other)
 
 testXmrReachesTheProviderAsXmr :: IO ()