badges: webapp feature branch (#7548)

* badges: webapp (#7433)

* badges: service migrations, store and catalog

* badges: BTCPay provider and settlement poller

* badges: web listener and /api endpoints

* web: checkout single-page app

* badges: tests and BTCPay fixtures

* badges: README and ini reference

* badges: fix hex16 build on GHC 8.10.7

* badges: Stripe card lane

* badges: fix Stripe card checkout, add theming

* badges: add a discount row to the order summary

* badges: site navbar, embedding, theme, Forget move

* badges: use SB code prefix in web checkout

* badges: rename sxb app namespace to sb

* badges: embed checkout nav via site; keep original app navbar

* badges: post iframe height, apply site background when embedded

* badges: embed dark surfaces, steadier iframe height

* badges: hide app footer when embedded

* badges: size embedded body to content, not viewport

* badges: declare color-scheme to stop reload flash

* badges: fade shell in on load, no reload blank

* badges: prerender app shell into index.html

* badges: pre-paint theme, hide shell on deep reload

* badges: logo returns to landing client-side

* badges: embedded wizard back, buy-a-code, resume

* badges: signal app-managed screens, resume across reload

* badges: rebuild wizard history on deep load so Back walks it

* badges: carry welcome-page height as the iframe floor

* badges: keep selection on Buy a code; rename to Your codes

* badges: read web shell as UTF-8, not locale

* badges: resume the exact paid order after Stripe card redirect

* badges: move docker deploy under scripts

* badges: add serve_webapp toggle and webapp export

* badges: wire split webapp deploy in docker config

* badges: quiet agent logs by default

* badges: resume card redirect in the embedded frame

* badges: migrate Stripe adapter to PaymentIntents

* badges: correct Stripe restricted key scopes in ini example

* badges: card via Payment Element and PaymentIntents

* badges: fix stale Checkout Session wording in Stripe adapter

* badges: fix stale CheckoutActions reference in card comment

* badges: order shell stylesheet before bootstrap script

* badges: remove development card stand-in

* badges: theme the Stripe card form with the site palette

* badges: exclude web from the Haskell build stage

* badges: unify invoice cancel and mark canceled

* badges: default log level to info

* badges: unify closed-invoice buy-again button

* badges: mute agent connection logs at info level

* badges: show purchase time in local timezone in Your codes

* badges: log service events on own channel, quiet agent

* badges: fold service migrations into one baseline

* badges: run compose on postgres over host network

* badges: use high-res hero art

* badges: add web CI to catch stale builds

* badges: rebuild web shell from committed source

* badges: normalize invoice-code link and columns

* badges: drop unused columns, rename index

* badges: note deferred receipt_hash in migrations

* badges: apply code-review fixes

* badges: reduce comments across service and web

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>

* badges: improve web page (#7546)

* badges: improve web page

* improve layout

* improve layout

* fix

* small changes

---------

Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>

* badges: read one issuer key from the ini

* badges: move and group the service tests

* badges: service fixes (#7567)

* badges: match the redeem error wording in tests

* badges: drop unused imports in the bot tests

* badges: cancel Stripe orders when they expire

* badges: correct the Stripe config and docs

* badges: refuse to revoke a redeemed code

* badges: make the fake Stripe cancel like Stripe

* badges: limit replayed webhook deliveries

---------

Co-authored-by: sh <37271604+shumvgolove@users.noreply.github.com>
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
Co-authored-by: shum <github.shum@liber.li>
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

tests/Bots/BadgeService/BTCPayTests.hs

@@ -0,0 +1,794 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Bots.BadgeService.BTCPayTests (badgeBTCPayTests) where
+
+import BadgeService.Config (BTCPayConfig (..))
+import BadgeService.Providers
+  ( Funded (..),
+    ListPass (..),
+    OrderDraft (..),
+    PaymentSignal (..),
+    Provider (..),
+    ProviderError (..),
+    ProviderInvoice (..),
+    Received (..),
+    WebhookError (..),
+    settleWindow,
+  )
+import BadgeService.Providers.BTCPay (btcMethodId, btcpayProvider, listSignals, minorToDecimal, paymentMethodsSignal, verifyBTCPaySig, xmrMethodId)
+import Bots.BadgeService.FakeBTCPay
+import Control.Exception (evaluate)
+import Control.Monad (join)
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as KM
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy as LB
+import Data.Char (toUpper)
+import Data.Foldable (toList)
+import Data.Scientific (Scientific, scientific)
+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.Header (Header, hAuthorization)
+import Simplex.Chat.PaymentService.Types
+  ( CryptoCurrency (..),
+    CurrencyAmount (..),
+    ServicePaymentDestination (..),
+    ServicePaymentMethod (..),
+  )
+import System.Timeout (timeout)
+import Test.Hspec
+import Text.Read (readMaybe)
+
+badgeBTCPayTests :: Spec
+badgeBTCPayTests = describe "badge btcpay adapter" $ do
+  describe "minor units to the provider's decimal string" $
+    it "pins the eight values a wrong pad would charge wrongly" testMinorToDecimal
+  describe "the status table" $ do
+    it "settles on Settled, timed by the latest Settled payment" testSettled
+    it "falls back to the read time when a Settled invoice was marked by hand" testSettledManuallyMarked
+    it "funds on Processing" testProcessing
+    it "closes on Expired and on Invalid" testClosed
+    it "funds on New with something received" testNewWithPayment
+    it "funds on New with a payment worth less than a minor unit" testNewWithDust
+    it "reports no change on New with nothing received" testNewWithNothing
+    it "refuses a decimal whose exponent would build a billion-digit number" testAbsurdExponentIsRefused
+    it "clamps a figure too wrong to charge, rather than wrapping it" testAbsurdAmountIsClamped
+    it "refuses the same exponent sent as a JSON number, without formatting it" testAbsurdExponentAsANumberIsRefused
+    it "accepts a rate written at full decimal scale" testLongRateIsAccepted
+    it "names an unknown status rather than reporting no change" testUnknownStatus
+    it "does not know Complete, which is the legacy invoice API's name" testNoCompleteStatus
+    it "names the payment methods it found when none is one of ours" testUnknownPaymentMethod
+    it "names a response it cannot read" testUnreadableResponse
+  describe "amounts" $ do
+    it "reads paymentMethodPaid and never totalPaid" testReadsPaymentMethodPaid
+    it "keeps the crypto amount exactly as the provider wrote it" testCryptoAmountVerbatim
+    it "multiplies the decimals exactly, where a Double would be a cent out" testExactDecimalMultiplication
+    it "reads a numeric field sent as a JSON number as well as a string" testNumberAsWellAsString
+  describe "the list pass" $ do
+    it "skips an invoice whose status it does not know, and settles the rest" testListSkipsUnknownStatus
+    it "skips an invoice it cannot parse, and settles the rest" testListSkipsUnparseable
+    it "skips an invoice paid by a method it does not know, and settles the rest" testListSkipsUnknownMethod
+    it "fails the pass when the payment methods are absent, rather than reporting health" testListFailsWithoutPaymentMethods
+    it "skips an invoice it cannot even name, unaccounted for" testListSkipsWithoutId
+    it "fails the pass on a response it cannot read" testListFailsOnUnreadableBody
+  describe "BTCPay-Sig" $ do
+    it "accepts the indented bytes as received, for each acted-on type" testWebhookAccepts
+    it "finds the header whatever its case" testWebhookHeaderCase
+    it "accepts an uppercase hex signature" testWebhookUppercaseHex
+    it "ignores a valid signature over a type this service does not act on" testWebhookIgnoresOtherType
+    it "ignores a valid signature over a payload with no event in it" testWebhookIgnoresUnreadableBody
+    it "rejects the same body signed with a different secret" testWebhookWrongSecret
+    it "rejects a re-serialised body, whose bytes are not the ones signed" testWebhookReserialised
+    it "rejects a missing, unprefixed or non-hex signature" testWebhookMalformed
+  describe "against the fake Greenfield" $ do
+    it "creates a bitcoin invoice and reads back where to pay" testFakeCreatesBtc
+    it "creates a monero invoice and reads back where to pay" testFakeCreatesXmr
+    it "sends the api key as `token <key>` on every call it makes" testFakeSendsApiKey
+    it "is refused when the api key is wrong, rather than passing silently" testFakeWrongApiKey
+    it "sends the documented create body, and no redirectURL" testFakeCreateBody
+    it "walks New to Processing to Settled, two calls per read" testFakeLifecycle
+    it "closes on Expired and on Invalid" testFakeClosed
+    it "names a status the provider invented" testFakeUnknownStatus
+    it "reads paymentMethodPaid over the wire, never totalPaid" testFakePaymentMethodPaid
+    it "makes a 500 at checkout a ProviderError" testFakeCreate500
+    it "abandons an invoice it created but could not learn the address of" testFakeCreatePostFailure
+    it "names the payment method a created invoice does not offer" testFakeCreateWrongMethod
+    it "names a payment method with no destination, and writes nothing" testFakeCreateNoDestination
+    it "names a payment method with no amount, and writes nothing" testFakeCreateNoAmount
+    it "refuses an answer past the size it will hold, and reads again after" testFakeOversizeAnswer
+    it "makes a 500 on a read a ProviderError the next read recovers from" testFakeRead500
+    it "verifies a webhook with the secret it was configured with" testFakeWebhookSecretWiring
+    it "keeps totalPaid distinguishable in every fixture an amount is asserted from" testFixturesGuardTotalPaid
+    it "keeps due distinguishable from networkFee, so the wrong field cannot be read" testFixturesGuardDue
+  describe "the list pass against the fake Greenfield" $ do
+    it "returns the invoices whose state moved and omits the one that did not" testFakeListMoved
+    it "bounds the request at 72 hours plus one invoice window" testFakeListWindow
+    it "skips an invoice whose status it does not know, and settles the rest" testFakeListAlienStatus
+    it "skips an invoice paid by a method it does not know, and settles the rest" testFakeListAlienMethod
+    it "fails the pass when the payment methods are absent" testFakeListNoPaymentMethods
+    it "skips an invoice it cannot even name, unaccounted for" testFakeListNoId
+
+testMinorToDecimal :: IO ()
+testMinorToDecimal =
+  map (minorToDecimal . CurrencyAmount) [0, 5, 99, 100, 700, 4200, 42000, 100000000]
+    `shouldBe` ["0.00", "0.05", "0.99", "1.00", "7.00", "42.00", "420.00", "1000000.00"]
+
+readTime :: UTCTime
+readTime = posixSecondsToUTCTime 1800000000
+
+ref :: Text
+ref = "GREENFIELDINVOICEID"
+
+btcPaid :: Text -> [J.Value] -> J.Value
+btcPaid paid payments =
+  J.object
+    [ "paymentMethodId" .= btcMethodId,
+      "destination" .= ("bc1qexampleaddress" :: Text),
+      "amount" .= ("0.00050000" :: Text),
+      "rate" .= ("108000.12" :: Text),
+      "paymentMethodPaid" .= paid,
+      "totalPaid" .= ("9.99999999" :: Text),
+      "due" .= dueAfter paid,
+      "networkFee" .= ("0.00000500" :: Text),
+      "payments" .= payments
+    ]
+
+-- | The due each payment figure leaves owed on a 0.00050000 invoice. The dust case does not use
+-- the difference between amount and paid, because a partial payment adds a network fee, so a body
+-- computed by subtraction would also pass an adapter that subtracted instead of reading the field.
+dueAfter :: Text -> Text
+dueAfter = \case
+  "0.00050000" -> "0.00000000"
+  "0.00000001" -> "0.00050499"
+  _ -> "0.00050000"
+
+payment :: Text -> Integer -> J.Value
+payment status receivedDate =
+  J.object
+    [ "id" .= ("txid" <> T.pack (show receivedDate)),
+      "status" .= status,
+      "receivedDate" .= receivedDate,
+      "value" .= ("0.00025000" :: Text),
+      "fee" .= ("0.00000100" :: Text)
+    ]
+
+methodsBody :: [J.Value] -> LB.ByteString
+methodsBody = J.encode
+
+signalOf :: Text -> [J.Value] -> Either ProviderError (Maybe PaymentSignal)
+signalOf status methods = paymentMethodsSignal readTime ref status (methodsBody methods)
+
+halfMilliBtc :: Received
+halfMilliBtc = Received {rcvAmount = CurrencyAmount 5400, rcvCrypto = Just "0.00050000", rcvDue = Just "0.00000000"}
+
+nothingReceived :: Text -> Received
+nothingReceived due = Received {rcvAmount = CurrencyAmount 0, rcvCrypto = Nothing, rcvDue = Just due}
+
+testSettled :: IO ()
+testSettled =
+  signalOf "Settled" [btcPaid "0.00050000" [payment "Settled" 1700003600, payment "Settled" 1700000000, payment "Processing" 1700007200]]
+    `shouldBe` Right (Just (SigSettled halfMilliBtc (posixSecondsToUTCTime 1700003600)))
+
+testSettledManuallyMarked :: IO ()
+testSettledManuallyMarked =
+  signalOf "Settled" [btcPaid "0.00050000" []]
+    `shouldBe` Right (Just (SigSettled halfMilliBtc readTime))
+
+testProcessing :: IO ()
+testProcessing =
+  signalOf "Processing" [btcPaid "0.00050000" [payment "Processing" 1700000000]]
+    `shouldBe` Right (Just (SigFunded halfMilliBtc PaidInFull))
+
+testClosed :: IO ()
+testClosed = do
+  signalOf "Expired" [btcPaid "0.00050000" [payment "Processing" 1700000000]]
+    `shouldBe` Right (Just (SigClosed halfMilliBtc))
+  signalOf "Invalid" [btcPaid "0.00000000" []]
+    `shouldBe` Right (Just (SigClosed (nothingReceived "0.00050000")))
+
+testNewWithPayment :: IO ()
+testNewWithPayment =
+  signalOf "New" [btcPaid "0.00050000" [payment "Processing" 1700000000]]
+    `shouldBe` Right (Just (SigFunded halfMilliBtc PaidInPart))
+
+testNewWithDust :: IO ()
+testNewWithDust =
+  signalOf "New" [btcPaid "0.00000001" [payment "Processing" 1700000000]]
+    `shouldBe` Right (Just (SigFunded Received {rcvAmount = CurrencyAmount 0, rcvCrypto = Just "0.00000001", rcvDue = Just "0.00050499"} PaidInPart))
+
+testNewWithNothing :: IO ()
+testNewWithNothing = signalOf "New" [btcPaid "0.00000000" []] `shouldBe` Right Nothing
+
+-- | A figure with an absurd exponent parses as a Scientific and then asks for a number with that
+-- many digits, which never returns. The test bounds the call with a timeout, since the guard must
+-- refuse it before anything rounds or formats it.
+testAbsurdExponentIsRefused :: IO ()
+testAbsurdExponentIsRefused = do
+  answered <- timeout 5000000 (evaluate (signalOf "Settled" [btcPaid "1e1000000000" []]))
+  case answered of
+    Nothing -> expectationFailure "a decimal with a billion-digit exponent was not refused"
+    Just r -> r `shouldSatisfy` namesInError "exponent out of range"
+
+-- | BTCPay sends `receivedDate` as a bare JSON number, so the same absurd figure must be refused
+-- in that form too, and the refusal must not format it on the way out or the guard rebuilds it.
+testAbsurdExponentAsANumberIsRefused :: IO ()
+testAbsurdExponentAsANumberIsRefused = do
+  let huge = J.Number (scientific 1 1000000000)
+      method =
+        J.object
+          [ "paymentMethodId" .= btcMethodId,
+            "destination" .= ("bc1qexampleaddress" :: Text),
+            "amount" .= huge,
+            "rate" .= ("108000.12" :: Text),
+            "paymentMethodPaid" .= ("0.00050000" :: Text),
+            "due" .= ("0.00000000" :: Text),
+            "networkFee" .= ("0.00000500" :: Text),
+            "payments" .= ([] :: [J.Value])
+          ]
+  answered <- timeout 5000000 (evaluate (signalOf "Settled" [method]))
+  case answered of
+    Nothing -> expectationFailure "a JSON number with a billion-digit exponent was not refused"
+    Just r -> r `shouldSatisfy` namesInError "exponent out of range"
+
+testLongRateIsAccepted :: IO ()
+testLongRateIsAccepted =
+  signalOf "Settled" [longRate] `shouldSatisfy` \case
+    Right (Just SigSettled {}) -> True
+    _ -> False
+  where
+    longRate =
+      J.object
+        [ "paymentMethodId" .= btcMethodId,
+          "destination" .= ("bc1qexampleaddress" :: Text),
+          "amount" .= ("0.00050000" :: Text),
+          "rate" .= ("0.3333333333333333333333333333" :: Text),
+          "paymentMethodPaid" .= ("0.00050000" :: Text),
+          "due" .= ("0.00000000" :: Text),
+          "networkFee" .= ("0.00000500" :: Text),
+          "payments" .= ([] :: [J.Value])
+        ]
+
+testUnknownStatus :: IO ()
+testUnknownStatus = signalOf "Frobnicated" [btcPaid "0.00050000" []] `shouldSatisfy` namesInError "Frobnicated"
+
+testNoCompleteStatus :: IO ()
+testNoCompleteStatus =
+  signalOf "Complete" [btcPaid "0.00050000" [payment "Settled" 1700000000]] `shouldSatisfy` namesInError "Complete"
+
+testUnknownPaymentMethod :: IO ()
+testUnknownPaymentMethod = do
+  let ltc = J.object ["paymentMethodId" .= ("LTC-CHAIN" :: Text), "rate" .= ("1" :: Text), "paymentMethodPaid" .= ("0" :: Text)]
+  signalOf "Settled" [ltc] `shouldSatisfy` namesInError "LTC-CHAIN"
+  signalOf "Settled" [ltc] `shouldSatisfy` namesInError btcMethodId
+  signalOf "Settled" [ltc] `shouldSatisfy` namesInError xmrMethodId
+
+testUnreadableResponse :: IO ()
+testUnreadableResponse =
+  paymentMethodsSignal readTime ref "Settled" "<html>502 Bad Gateway</html>" `shouldSatisfy` namesInError "could not read the response"
+
+namesInError :: Text -> Either ProviderError a -> Bool
+namesInError what = \case
+  Left (ProviderError e) -> what `T.isInfixOf` e
+  Right _ -> False
+
+listEntry :: Text -> Text -> Maybe [J.Value] -> J.Value
+listEntry invId status methods =
+  J.object $
+    [ "id" .= invId,
+      "status" .= status,
+      "additionalStatus" .= ("None" :: Text),
+      "amount" .= ("54.00" :: Text),
+      "currency" .= ("USD" :: Text)
+    ]
+      <> maybe [] (\ms -> ["paymentMethods" .= ms]) methods
+
+oursSettled :: J.Value
+oursSettled = listEntry ref "Settled" (Just [btcPaid "0.00050000" [payment "Settled" 1700000000]])
+
+oursSettledSignal :: (Text, PaymentSignal)
+oursSettledSignal = (ref, SigSettled halfMilliBtc (posixSecondsToUTCTime 1700000000))
+
+movedOnly :: [(Text, PaymentSignal)] -> Either ProviderError ListPass
+movedOnly moved = Right ListPass {lpMoved = moved, lpSkipped = []}
+
+skippedReason :: HasCallStack => Either ProviderError ListPass -> IO Text
+skippedReason = fmap snd . skipped
+
+skipped :: HasCallStack => Either ProviderError ListPass -> IO (Maybe Text, Text)
+skipped = \case
+  Right ListPass {lpSkipped = [skip]} -> pure skip
+  other -> failWith ("expected exactly one skipped invoice, got " <> show other)
+
+testListSkipsUnknownStatus :: IO ()
+testListSkipsUnknownStatus = do
+  let alien = listEntry "SOMEONEELSESINVOICE" "Frobnicated" (Just [btcPaid "0.00050000" []])
+      r = listSignals readTime (J.encode [alien, oursSettled])
+  lpMoved <$> r `shouldBe` Right [oursSettledSignal]
+  (skippedRef, reason) <- skipped r
+  reason `shouldSatisfy` T.isInfixOf "Frobnicated"
+  reason `shouldSatisfy` T.isInfixOf "SOMEONEELSESINVOICE"
+  skippedRef `shouldBe` Just "SOMEONEELSESINVOICE"
+
+-- | Each invoice is decoded on its own, not the whole page at once, because XMR payments come from
+-- a BTCPay plugin and one malformed entry must not stop every other invoice settling on every pass.
+testListSkipsUnparseable :: IO ()
+testListSkipsUnparseable = do
+  let noStatus =
+        J.object
+          [ "paymentMethodId" .= btcMethodId,
+            "destination" .= ("bc1qexampleaddress" :: Text),
+            "amount" .= ("0.00050000" :: Text),
+            "rate" .= ("108000.12" :: Text),
+            "paymentMethodPaid" .= ("0.00050000" :: Text),
+            "due" .= ("0.00000000" :: Text),
+            "networkFee" .= ("0.00000500" :: Text),
+            "payments" .= [J.object ["receivedDate" .= (1700000000 :: Int)]]
+          ]
+      broken = listEntry "MALFORMEDINVOICE" "Settled" (Just [noStatus])
+      r = listSignals readTime (J.encode [broken, oursSettled])
+  lpMoved <$> r `shouldBe` Right [oursSettledSignal]
+  (skippedRef, reason) <- skipped r
+  skippedRef `shouldBe` Just "MALFORMEDINVOICE"
+  reason `shouldSatisfy` T.isInfixOf "status"
+
+testListSkipsUnknownMethod :: IO ()
+testListSkipsUnknownMethod = do
+  let ltc =
+        J.object
+          [ "paymentMethodId" .= ("BTC-LN" :: Text),
+            "rate" .= ("108000.12" :: Text),
+            "paymentMethodPaid" .= ("0.00050000" :: Text),
+            "payments" .= ([] :: [J.Value])
+          ]
+      alien = listEntry "SOMEONEELSESINVOICE" "Settled" (Just [ltc])
+      r = listSignals readTime (J.encode [alien, oursSettled])
+  lpMoved <$> r `shouldBe` Right [oursSettledSignal]
+  skippedReason r >>= (`shouldSatisfy` T.isInfixOf "BTC-LN")
+
+testListFailsWithoutPaymentMethods :: IO ()
+testListFailsWithoutPaymentMethods = do
+  listSignals readTime (J.encode [listEntry ref "Settled" Nothing]) `shouldSatisfy` namesInError "paymentMethods"
+
+testListSkipsWithoutId :: IO ()
+testListSkipsWithoutId = do
+  let noId = J.object ["status" .= ("Settled" :: Text), "paymentMethods" .= [btcPaid "0.00050000" []]]
+      r = listSignals readTime (J.encode [oursSettled, noId])
+  lpMoved <$> r `shouldBe` Right [oursSettledSignal]
+  (skippedRef, reason) <- skipped r
+  skippedRef `shouldBe` Nothing
+  reason `shouldSatisfy` T.isInfixOf "id"
+
+testListFailsOnUnreadableBody :: IO ()
+testListFailsOnUnreadableBody =
+  listSignals readTime "<html>502 Bad Gateway</html>" `shouldSatisfy` namesInError "could not read the response"
+
+testReadsPaymentMethodPaid :: IO ()
+testReadsPaymentMethodPaid = do
+  signalOf "Settled" [btcPaid "0.00050000" [payment "Settled" 1700000000]]
+    `shouldBe` Right (Just (SigSettled halfMilliBtc (posixSecondsToUTCTime 1700000000)))
+  signalOf "New" [btcPaid "0.00000000" []] `shouldBe` Right Nothing
+
+testCryptoAmountVerbatim :: IO ()
+testCryptoAmountVerbatim =
+  case signalOf "Processing" [btcPaid "0.00050000" []] of
+    Right (Just (SigFunded r _)) -> rcvCrypto r `shouldBe` Just "0.00050000"
+    other -> expectationFailure ("expected SigFunded, got " <> show other)
+
+testExactDecimalMultiplication :: IO ()
+testExactDecimalMultiplication = do
+  let atRateOne paid =
+        J.object
+          [ "paymentMethodId" .= btcMethodId,
+            "rate" .= ("1" :: Text),
+            "paymentMethodPaid" .= (paid :: Text),
+            "payments" .= ([] :: [J.Value])
+          ]
+  case signalOf "Processing" [atRateOne "0.545"] of
+    Right (Just (SigFunded r _)) -> rcvAmount r `shouldBe` CurrencyAmount 54
+    other -> expectationFailure ("expected SigFunded, got " <> show other)
+
+-- The exponent gate bounds how long a figure may be, not how large, so a negative or eleven-digit
+-- value still reaches the conversion. Unclamped, both wrap Word32 into a positive amount that reads
+-- as money received, and the invoice then holds against every sweep and answers every cancel funded.
+testAbsurdAmountIsClamped :: IO ()
+testAbsurdAmountIsClamped = do
+  chargeFor "-1" `shouldBe` Just (CurrencyAmount 0)
+  chargeFor "99999999999" `shouldBe` Just (CurrencyAmount 4294967295)
+  where
+    chargeFor paid = case signalOf "Processing" [atRateOne paid] of
+      Right (Just (SigFunded r _)) -> Just (rcvAmount r)
+      _ -> Nothing
+    atRateOne paid =
+      J.object
+        [ "paymentMethodId" .= btcMethodId,
+          "rate" .= ("1" :: Text),
+          "paymentMethodPaid" .= (paid :: Text),
+          "payments" .= ([] :: [J.Value])
+        ]
+
+testNumberAsWellAsString :: IO ()
+testNumberAsWellAsString = do
+  let asNumbers =
+        "[{\"paymentMethodId\":\"BTC-CHAIN\",\"rate\":108000.12,\"paymentMethodPaid\":0.00050000,\
+        \\"payments\":[{\"status\":\"Settled\",\"receivedDate\":1700000000}]}]"
+  case paymentMethodsSignal readTime ref "Settled" asNumbers of
+    Right (Just (SigSettled r t)) -> do
+      rcvAmount r `shouldBe` CurrencyAmount 5400
+      rcvCrypto r `shouldBe` Just "0.00050000"
+      t `shouldBe` posixSecondsToUTCTime 1700000000
+    other -> expectationFailure ("expected SigSettled, got " <> show other)
+
+secret :: Text
+secret = "3d8f5c6a2b1e4f7089abcdef01234567"
+
+verifyEvent :: [Header] -> LB.ByteString -> Either WebhookError (Maybe Text)
+verifyEvent hdrs body = verifyBTCPaySig secret hdrs (LB.toStrict body)
+
+testWebhookAccepts :: IO ()
+testWebhookAccepts =
+  mapM_
+    (\t -> let b = webhookEvent t ref in verifyEvent (webhookSigHeader secret b) b `shouldBe` Right (Just ref))
+    ["InvoiceProcessing", "InvoiceSettled", "InvoiceExpired", "InvoiceInvalid"]
+
+testWebhookHeaderCase :: IO ()
+testWebhookHeaderCase = do
+  let b = webhookEvent "InvoiceSettled" ref
+  verifyEvent [("btcpay-sig", "sha256=" <> webhookHexSig secret b)] b `shouldBe` Right (Just ref)
+
+testWebhookUppercaseHex :: IO ()
+testWebhookUppercaseHex = do
+  let b = webhookEvent "InvoiceSettled" ref
+  verifyEvent [("BTCPay-Sig", "sha256=" <> B8.map toUpper (webhookHexSig secret b))] b `shouldBe` Right (Just ref)
+
+testWebhookIgnoresOtherType :: IO ()
+testWebhookIgnoresOtherType = do
+  let b = webhookEvent "InvoiceReceivedPayment" ref
+  verifyEvent (webhookSigHeader secret b) b `shouldBe` Right Nothing
+
+testWebhookIgnoresUnreadableBody :: IO ()
+testWebhookIgnoresUnreadableBody = do
+  let b = "{\n  \"type\": \"InvoiceSettled\"\n}\n"
+  verifyEvent (webhookSigHeader secret b) b `shouldBe` Right Nothing
+
+testWebhookWrongSecret :: IO ()
+testWebhookWrongSecret = do
+  let b = webhookEvent "InvoiceSettled" ref
+  verifyEvent (webhookSigHeader "3d8f5c6a2b1e4f7089abcdef01234568" b) b `shouldSatisfy` isRefused
+
+testWebhookReserialised :: IO ()
+testWebhookReserialised = do
+  let b = webhookEvent "InvoiceSettled" ref
+      reserialised = maybe "" J.encode (J.decode b :: Maybe J.Value)
+  reserialised `shouldNotBe` b
+  verifyEvent (webhookSigHeader secret b) reserialised `shouldSatisfy` isRefused
+
+testWebhookMalformed :: IO ()
+testWebhookMalformed = do
+  let b = webhookEvent "InvoiceSettled" ref
+  verifyEvent [] b `shouldSatisfy` isRefused
+  verifyEvent [("BTCPay-Sig", "")] b `shouldSatisfy` isRefused
+  verifyEvent [("BTCPay-Sig", webhookHexSig secret b)] b `shouldSatisfy` isRefused
+  verifyEvent [("BTCPay-Sig", "sha512=" <> webhookHexSig secret b)] b `shouldSatisfy` isRefused
+  verifyEvent [("BTCPay-Sig", "sha256=not hex at all")] b `shouldSatisfy` isRefused
+  verifyEvent [("BTCPay-Sig", "sha256=")] b `shouldSatisfy` isRefused
+
+isRefused :: Either WebhookError (Maybe Text) -> Bool
+isRefused = \case
+  Left (WebhookError _) -> True
+  _ -> False
+
+btcAddress, xmrAddress :: Text
+btcAddress = "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq"
+xmrAddress = "44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A"
+
+fixtureSettledAt :: UTCTime
+fixtureSettledAt = posixSecondsToUTCTime 1700003600
+
+listSettledRef, listProcessingRef :: Text
+listSettledRef = "SettledInvoiceRefAAAA"
+listProcessingRef = "ProcessingInvoiceRefB"
+
+xmrReceived :: Received
+xmrReceived = Received {rcvAmount = CurrencyAmount 5400, rcvCrypto = Just "0.32095000", rcvDue = Just "0.00000000"}
+
+fiftyFourDollars :: OrderDraft
+fiftyFourDollars =
+  OrderDraft
+    { odAmount = CurrencyAmount 5400,
+      odCurrency = "usd"
+    }
+
+exampleCeiling :: Int
+exampleCeiling = 20000000
+
+failWith :: HasCallStack => String -> IO a
+failWith msg = expectationFailure msg >> error msg
+
+withProvider :: HasCallStack => (FakeBTCPay -> Provider -> IO a) -> IO a
+withProvider = withProviderConfigured id
+
+withProviderConfigured :: HasCallStack => (BTCPayConfig -> BTCPayConfig) -> (FakeBTCPay -> Provider -> IO a) -> IO a
+withProviderConfigured configure action =
+  bounded $ withFakeBTCPay $ \fake -> btcpayProvider (configure (fbConfig fake)) >>= action fake
+  where
+    bounded act = timeout exampleCeiling act >>= maybe (failWith "the fake greenfield did not answer within 20s") pure
+
+createdInvoice :: HasCallStack => Provider -> ServicePaymentMethod -> IO ProviderInvoice
+createdInvoice p spm =
+  pCreateInvoice p spm fiftyFourDollars >>= \case
+    Right inv -> pure inv
+    Left e -> failWith ("expected an invoice, got " <> show e)
+
+testFakeCreatesBtc :: IO ()
+testFakeCreatesBtc = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef, piDestination} <- createdInvoice p (SPMCrypto CCBtc)
+  fakeInvoiceIds fake `shouldReturn` [piProviderRef]
+  piDestination `shouldBe` SPDCrypto CCBtc btcAddress "0.00050000"
+  ms <- apiRequests fake "GET" ["invoices", piProviderRef, "payment-methods"]
+  length ms `shouldBe` 1
+
+testFakeCreatesXmr :: IO ()
+testFakeCreatesXmr = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef, piDestination} <- createdInvoice p (SPMCrypto CCXmr)
+  piDestination `shouldBe` SPDCrypto CCXmr xmrAddress "0.32095000"
+  posts <- apiRequests fake "POST" ["invoices"]
+  case posts of
+    [created] -> chosenPaymentMethods (frBody created) `shouldBe` Just ["XMR-CHAIN"]
+    _ -> expectationFailure ("expected one create, got " <> show (length posts))
+  fakeInvoiceIds fake `shouldReturn` [piProviderRef]
+
+chosenPaymentMethods :: LB.ByteString -> Maybe [Text]
+chosenPaymentMethods body = case J.decode body of
+  Just (J.Object o) | Just (J.Object c) <- KM.lookup "checkout" o -> case KM.lookup "paymentMethods" c of
+    Just v -> case J.fromJSON v of
+      J.Success ms -> Just ms
+      J.Error _ -> Nothing
+    Nothing -> Nothing
+  _ -> Nothing
+
+testFakeSendsApiKey :: IO ()
+testFakeSendsApiKey = withProvider $ \fake p -> do
+  _ <- createdInvoice p (SPMCrypto CCBtc)
+  _ <- pListOpen p
+  rs <- fakeRequests fake
+  length rs `shouldBe` 4
+  map (lookup hAuthorization . frHeaders) rs
+    `shouldBe` replicate 4 (Just ("token " <> TE.encodeUtf8 fakeApiKey))
+
+testFakeWrongApiKey :: IO ()
+testFakeWrongApiKey = withProviderConfigured (\c -> c {bApiKey = "not-the-api-key"}) $ \fake p -> do
+  r <- pCreateInvoice p (SPMCrypto CCBtc) fiftyFourDollars
+  r `shouldSatisfy` namesInError "401"
+  rd <- pReadInvoice p "FakeInvoiceRef0001"
+  rd `shouldSatisfy` namesInError "401"
+  rs <- fakeRequests fake
+  length rs `shouldBe` 3
+  fakeInvoiceIds fake `shouldReturn` []
+
+testFakeCreateBody :: IO ()
+testFakeCreateBody = withProvider $ \fake p -> do
+  _ <- createdInvoice p (SPMCrypto CCBtc)
+  posts <- apiRequests fake "POST" ["invoices"]
+  case posts of
+    [created] ->
+      J.decode (frBody created)
+        `shouldBe` Just
+          ( J.object
+              [ "amount" .= ("54.00" :: Text),
+                "currency" .= ("USD" :: Text),
+                "checkout"
+                  .= J.object
+                    [ "expirationMinutes" .= fakeExpiryMinutes,
+                      "speedPolicy" .= ("MediumSpeed" :: Text),
+                      "paymentTolerance" .= (0.5 :: Double),
+                      "paymentMethods" .= ([btcMethodId] :: [Text])
+                    ]
+              ]
+          )
+    _ -> expectationFailure ("expected one create, got " <> show (length posts))
+
+testFakeLifecycle :: IO ()
+testFakeLifecycle = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = invRef} <- createdInvoice p (SPMCrypto CCBtc)
+  pReadInvoice p invRef `shouldReturn` Right Nothing
+  setInvoiceState fake invRef ["paymentMethodPaid" .= ("0.00025000" :: Text)]
+  pReadInvoice p invRef
+    `shouldReturn` Right (Just (SigFunded Received {rcvAmount = CurrencyAmount 2700, rcvCrypto = Just "0.00025000", rcvDue = Just "0.00000000"} PaidInPart))
+  setInvoiceState fake invRef ["status" .= ("Processing" :: Text), "additionalStatus" .= ("PaidPartial" :: Text)]
+  pReadInvoice p invRef
+    `shouldReturn` Right (Just (SigFunded Received {rcvAmount = CurrencyAmount 2700, rcvCrypto = Just "0.00025000", rcvDue = Just "0.00000000"} PaidInFull))
+  setInvoiceState fake invRef ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)]
+  pReadInvoice p invRef `shouldReturn` Right (Just (SigSettled halfMilliBtc fixtureSettledAt))
+  details <- apiRequests fake "GET" ["invoices", invRef]
+  methods <- apiRequests fake "GET" ["invoices", invRef, "payment-methods"]
+  (length details, length methods) `shouldBe` (4, 5)
+
+testFakeClosed :: IO ()
+testFakeClosed = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = invRef} <- createdInvoice p (SPMCrypto CCBtc)
+  setInvoiceState fake invRef ["status" .= ("Expired" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)]
+  pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed halfMilliBtc))
+  setInvoiceState fake invRef ["status" .= ("Invalid" :: Text), "paymentMethodPaid" .= ("0.00000000" :: Text)]
+  pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed (nothingReceived "0.00050000")))
+
+testFakeUnknownStatus :: IO ()
+testFakeUnknownStatus = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = invRef} <- createdInvoice p (SPMCrypto CCBtc)
+  setInvoiceState fake invRef ["status" .= ("Frobnicated" :: Text)]
+  r <- pReadInvoice p invRef
+  r `shouldSatisfy` namesInError "Frobnicated"
+
+testFakePaymentMethodPaid :: IO ()
+testFakePaymentMethodPaid = withProvider $ \fake p -> do
+  totalPaidStaysDistinguishable "payment-methods-btc"
+  ProviderInvoice {piProviderRef = invRef} <- createdInvoice p (SPMCrypto CCBtc)
+  setInvoiceState fake invRef ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)]
+  pReadInvoice p invRef `shouldReturn` Right (Just (SigSettled halfMilliBtc fixtureSettledAt))
+
+testFakeCreate500 :: IO ()
+testFakeCreate500 = withProvider $ \fake p -> do
+  failNextCalls fake 1 500
+  r <- pCreateInvoice p (SPMCrypto CCBtc) fiftyFourDollars
+  r `shouldSatisfy` namesInError "500"
+  fakeInvoiceIds fake `shouldReturn` []
+
+testFakeCreatePostFailure :: IO ()
+testFakeCreatePostFailure = withProvider $ \fake p -> do
+  failAfterCalls 1 fake 1 500
+  r <- pCreateInvoice p (SPMCrypto CCBtc) fiftyFourDollars
+  r `shouldSatisfy` namesInError "500"
+  ids <- fakeInvoiceIds fake
+  length ids `shouldBe` 1
+  r `shouldSatisfy` \case Right _ -> False; Left _ -> True
+
+testFakeCreateWrongMethod :: IO ()
+testFakeCreateWrongMethod = withProvider $ \fake p -> do
+  usePaymentMethodsFixture fake "payment-methods-xmr"
+  r <- pCreateInvoice p (SPMCrypto CCBtc) fiftyFourDollars
+  r `shouldSatisfy` namesInError "offers no BTC-CHAIN"
+  r `shouldSatisfy` namesInError "XMR-CHAIN"
+
+testFakeCreateNoDestination :: IO ()
+testFakeCreateNoDestination = withProvider $ \fake p -> do
+  usePaymentMethodsFixture fake "payment-methods-no-destination"
+  r <- pCreateInvoice p (SPMCrypto CCBtc) fiftyFourDollars
+  r `shouldSatisfy` namesInError "has no destination"
+
+testFakeCreateNoAmount :: IO ()
+testFakeCreateNoAmount = withProvider $ \fake p -> do
+  usePaymentMethodsFixture fake "payment-methods-no-amount"
+  r <- pCreateInvoice p (SPMCrypto CCBtc) fiftyFourDollars
+  r `shouldSatisfy` namesInError "has no amount"
+
+testFakeOversizeAnswer :: IO ()
+testFakeOversizeAnswer = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = invRef} <- createdInvoice p (SPMCrypto CCBtc)
+  answerOversize fake True
+  pReadInvoice p invRef >>= (`shouldSatisfy` namesInError "over 10485760 bytes")
+  answerOversize fake False
+  pReadInvoice p invRef >>= \case
+    Right _ -> pure ()
+    Left e -> expectationFailure ("the next read must recover, and got " <> show e)
+
+testFakeRead500 :: IO ()
+testFakeRead500 = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = invRef} <- createdInvoice p (SPMCrypto CCBtc)
+  setInvoiceState fake invRef ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)]
+  failNextCalls fake 1 500
+  r <- pReadInvoice p invRef
+  r `shouldSatisfy` namesInError "500"
+  pReadInvoice p invRef `shouldReturn` Right (Just (SigSettled halfMilliBtc fixtureSettledAt))
+
+testFakeWebhookSecretWiring :: IO ()
+testFakeWebhookSecretWiring = withProvider $ \fake p -> do
+  let configured = bWebhookSecret (fbConfig fake)
+      b = webhookEvent "InvoiceSettled" ref
+  pVerifyWebhook p readTime (webhookSigHeader configured b) (LB.toStrict b) `shouldBe` Right (Just ref)
+  pVerifyWebhook p readTime (webhookSigHeader (configured <> "0") b) (LB.toStrict b) `shouldSatisfy` isRefused
+
+-- | An amount assertion only proves the adapter reads paymentMethodPaid rather than totalPaid while
+-- the two differ in the fixture, so this checks that directly.
+totalPaidStaysDistinguishable :: HasCallStack => Text -> IO ()
+totalPaidStaysDistinguishable name = do
+  v <- fixtureResponse name
+  case paymentMethodsIn v of
+    [] -> expectationFailure (T.unpack name <> " carries no payment method")
+    ms -> mapM_ distinguishable ms
+  where
+    distinguishable m
+      | paidNothing m = pure ()
+      | otherwise = KM.lookup "totalPaid" m `shouldNotBe` KM.lookup "paymentMethodPaid" m
+    paidNothing m = case KM.lookup "paymentMethodPaid" m of
+      Just (J.String t) -> (J.decodeStrict (TE.encodeUtf8 t) :: Maybe Scientific) == Just 0
+      _ -> False
+
+paymentMethodsIn :: J.Value -> [J.Object]
+paymentMethodsIn = \case
+  J.Object o -> [o | KM.member "paymentMethodPaid" o] <> concatMap paymentMethodsIn (KM.elems o)
+  J.Array vs -> concatMap paymentMethodsIn (toList vs)
+  _ -> []
+
+testFixturesGuardTotalPaid :: IO ()
+testFixturesGuardTotalPaid =
+  mapM_
+    totalPaidStaysDistinguishable
+    ["payment-methods-btc", "payment-methods-xmr", "invoice-list", "invoice-list-alien-status", "invoice-list-alien-method"]
+
+-- | With due equal to networkFee a fixture cannot tell which field the adapter reads, and
+-- reading the fee would report a part-paid invoice as covered.
+dueStaysDistinguishable :: HasCallStack => Text -> IO ()
+dueStaysDistinguishable name = do
+  v <- fixtureResponse name
+  case paymentMethodsIn v of
+    [] -> expectationFailure (T.unpack name <> " carries no payment method")
+    ms -> mapM_ distinguishable ms
+  where
+    distinguishable m = case (KM.lookup "due" m, KM.lookup "networkFee" m) of
+      (Just d, Just f) -> d `shouldNotBe` f
+      _ -> pure ()
+
+testFixturesGuardDue :: IO ()
+testFixturesGuardDue =
+  mapM_
+    dueStaysDistinguishable
+    ["payment-methods-btc", "payment-methods-xmr", "invoice-list", "invoice-list-alien-status", "invoice-list-alien-method"]
+
+testFakeListMoved :: IO ()
+testFakeListMoved = withProvider $ \_ p ->
+  pListOpen p
+    `shouldReturn` movedOnly
+      [ (listSettledRef, SigSettled halfMilliBtc fixtureSettledAt),
+        (listProcessingRef, SigFunded xmrReceived PaidInFull)
+      ]
+
+testFakeListWindow :: IO ()
+testFakeListWindow = withProvider $ \fake p -> do
+  askedAt <- getCurrentTime
+  _ <- pListOpen p
+  answeredAt <- getCurrentTime
+  gets <- apiRequests fake "GET" ["invoices"]
+  case gets of
+    [listed] -> do
+      lookup "includePaymentMethods" (frQuery listed) `shouldBe` Just (Just "true")
+      case join (lookup "startDate" (frQuery listed)) >>= readMaybe . B8.unpack of
+        Nothing -> expectationFailure ("no readable startDate in " <> show (frQuery listed))
+        Just sent -> do
+          let window = truncate settleWindow + 60 * toInteger fakeExpiryMinutes
+              seconds t = floor (utcTimeToPOSIXSeconds t) :: Integer
+          sent `shouldSatisfy` \s -> s >= seconds askedAt - window && s <= seconds answeredAt - window
+    _ -> expectationFailure ("expected one list request, got " <> show (length gets))
+
+testFakeListAlienStatus :: IO ()
+testFakeListAlienStatus = withProvider $ \fake p -> do
+  useListFixture fake "invoice-list-alien-status"
+  r <- pListOpen p
+  lpMoved <$> r `shouldBe` Right [(listSettledRef, SigSettled halfMilliBtc fixtureSettledAt)]
+  skippedReason r >>= (`shouldSatisfy` T.isInfixOf "Frobnicated")
+
+testFakeListAlienMethod :: IO ()
+testFakeListAlienMethod = withProvider $ \fake p -> do
+  useListFixture fake "invoice-list-alien-method"
+  r <- pListOpen p
+  lpMoved <$> r `shouldBe` Right [(listSettledRef, SigSettled halfMilliBtc fixtureSettledAt)]
+  skippedReason r >>= (`shouldSatisfy` T.isInfixOf "BTC-LN")
+
+testFakeListNoPaymentMethods :: IO ()
+testFakeListNoPaymentMethods = withProvider $ \fake p -> do
+  useListFixture fake "invoice-list-no-payment-methods"
+  r <- pListOpen p
+  r `shouldSatisfy` namesInError "paymentMethods"
+
+testFakeListNoId :: IO ()
+testFakeListNoId = withProvider $ \fake p -> do
+  useListFixture fake "invoice-list-no-id"
+  r <- pListOpen p
+  (skippedRef, reason) <- skipped r
+  skippedRef `shouldBe` Nothing
+  reason `shouldSatisfy` T.isInfixOf "id"

tests/Bots/BadgeService/BotTests.hs

@@ -8,10 +8,15 @@
 {-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
-module Bots.BadgeServiceTests where
+module Bots.BadgeService.BotTests where
 
+import BadgeService.Config (BadgeIssuerKey (..), readServiceConfig)
+import Bots.BadgeService.ConfigTests (withIssuer)
 import BadgeService.Options
 import BadgeService.Service
+import BadgeService.Store.Invoices (markCodePaid)
+import Simplex.Messaging.Agent.Store.DB (Binary (..))
+import qualified Simplex.Messaging.Agent.Store.DB as DB
 import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
@@ -35,9 +40,10 @@ import qualified Data.Text as T
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDay)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType (..), generateMasterKey)
-import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeText, formatBadgeCode, parseBadgeCode, randomBadgeCode)
+import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, badgeCodeText, formatBadgeCode, parseBadgeCode, randomBadgeCode)
 import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, endOfMondayAfter)
 import Simplex.Chat.Badges.Service
+import Simplex.Chat.Bot.Store (withDB')
 import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (CRCustomChatResponse))
 import Simplex.Chat.Core (sendChatCmdStr)
 import Simplex.Chat.Options (CoreChatOpts (..))
@@ -45,13 +51,12 @@ import Simplex.Chat.Options.DB
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..))
 import Simplex.Messaging.Agent.Store.Common (withTransaction)
-import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
-import qualified Simplex.Messaging.Agent.Store.DB as DB
+import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
 import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (BBSSecretKey, bbsKeyGen)
 import Simplex.Messaging.Encoding.String (strDecode, strEncode, textEncode)
-import Simplex.Messaging.Util (safeDecodeUtf8)
+import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import System.FilePath ((</>))
 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple (Only (..))
@@ -68,9 +73,16 @@ badgeServiceTests = do
   it "should answer code_invalid to an unknown code, indistinguishably from a malformed one" testRedeemUnknownCode
   it "should tell a second profile redeeming the same code that it is used" testRedeemSameCodeOtherProfile
   it "should refuse a second code while a badge is held, leaving it unspent" testRedeemSecondCode
+  it "should refuse a code that has not been paid for" testRedeemUnpaidCode
+  it "should refuse a badge code past its redemption deadline" testExpiredCode
+  it "should keep answering a code redeemed before its deadline" testRedeemedBeforeTheDeadline
+  it "should refuse a revoked badge code, and refuse to revoke it twice" testRevokedCode
+  it "should refuse to revoke a code that was redeemed, and keep its badge" testRevokeRedeemedCode
+  it "should answer revoking an unknown code as no such code" testRevokeUnknownCode
   it "should refuse to issue a code with an unknown badge type or a nonsense month count" testIssueRejectsBadArguments
   it "should refuse a request whose purchaseKey is not the verified signer" testPurchaseKeyMismatch
   it "should refuse to start unless the issuer secret is the key trusted at its index" testIssuerKeyMustMatchConfig
+  it "should refuse to start when the [issuer] key is not one clients trust" testIssuerIniKeyMustBeTrusted
   it "should credit a code's months and issue one credential per month" testCodeMonthsRenew
   it "should return the stored credential for a repeat inside an issued period" testRepeatInsideIssuedPeriod
   it "should lapse only the months that elapsed while the client was away" testLapseWhileAway
@@ -121,12 +133,12 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} secretKey =
       clientService = True,
       noAddress = False,
       runCLI = False,
-      issuerKey = Just BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey},
+      serviceConfigFile = Nothing,
+      issuerKey = Right (Just BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey}),
       testing = True
     }
 
--- | A clock the service and the client both read: real time plus an offset the test moves. It
--- tracks real time rather than freezing it, so a sleeper still sleeps the right real duration.
+-- | The clock tracks real time plus a test-controlled offset rather than freezing it, so a sleeping worker still waits the correct real duration.
 newtype TestClock = TestClock (IORef NominalDiffTime)
 
 newTestClock :: IO TestClock
@@ -137,12 +149,9 @@ testClockTime (TestClock r) = do
   offset <- readIORef r
   addUTCTime offset <$> getCurrentTime
 
--- | Move the clock so that "now" becomes exactly the given time - months are calendar months, so
--- a test crosses a boundary by naming the date rather than adding a duration.
 setClockAt :: TestClock -> UTCTime -> IO ()
 setClockAt (TestClock r) t = getCurrentTime >>= \real -> writeIORef r (diffUTCTime t real)
 
--- | Everything a badge test may need from a running service.
 data BadgeServiceEnv = BadgeServiceEnv
   { bsIssuerKey :: BadgeIssuerKey,
     bsClock :: TestClock,
@@ -156,8 +165,6 @@ data BadgeServiceEnv = BadgeServiceEnv
 stopBadgeService :: ChatController -> IO ()
 stopBadgeService cc = void $ sendChatCmdStr cc "/_stop"
 
--- | Start the badge service on a fresh issuer key, and hand the test body what depends on it:
--- the client config trusting that key and addressing the service, the address, and the controller.
 withBadgeService :: HasCallStack => TestParams -> (ChatConfig -> String -> ChatController -> IO ()) -> IO ()
 withBadgeService ps test =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsAddress, bsController} -> test bsClientCfg bsAddress bsController
@@ -167,12 +174,9 @@ withBadgeServiceEnv ps test = do
   Right (pk, sk) <- bbsKeyGen
   clock <- newTestClock
   let opts = mkBadgeServiceOpts ps sk
-      -- the service refuses to start unless its secret is the key trusted at its index
       svcCfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk, badgeCurrentTime = testClockTime clock}
   withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure ()
-  -- First start: badge service takes the CreateMyAddress branch.
   runBadgeService svcCfg opts $ \_ -> pure ()
-  -- Reopen the DB to read the link the service created.
   bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do
     bs <## "subscribed 1 connections on server localhost"
     bs ##> "/sa"
@@ -181,23 +185,29 @@ withBadgeServiceEnv ps test = do
     pure sLink
   let clientCfg =
         svcCfg {badgeServiceAddress = Just $ either (error . ("bad badge service address: " <>)) id $ strDecode (B.pack bsLink)}
-  -- Second start: badge service takes the ShowMyAddress branch, then serves the test body.
   runBadgeService svcCfg opts $ \env -> do
     cc <- atomically $ readTMVar $ serviceCC env
     test BadgeServiceEnv {bsIssuerKey = BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey = sk}, bsClock = clock, bsClientCfg = clientCfg, bsAddress = bsLink, bsController = cc}
 
--- through the operator command the service actually exposes, not the function behind it
 issueCode :: HasCallStack => ChatController -> BadgeType -> Int -> IO BadgeCode
-issueCode cc badgeType months =
-  sendChatCmdStr cc ("//issue " <> T.unpack (textEncode badgeType) <> " " <> show months) >>= \case
+issueCode cc badgeType months = issueCodeAs cc badgeType months "free"
+
+revokeCodeAs :: HasCallStack => ChatController -> BadgeCode -> IO T.Text
+revokeCodeAs cc code =
+  sendChatCmdStr cc ("//revoke " <> T.unpack (formatBadgeCode code)) >>= \case
+    Right (CRCustomChatResponse _ response) -> pure response
+    Left e -> pure (T.pack (show e))
+    r -> error $ "revoke failed: " <> show (() <$ r)
+
+issueCodeAs :: HasCallStack => ChatController -> BadgeType -> Int -> String -> IO BadgeCode
+issueCodeAs cc badgeType months status =
+  sendChatCmdStr cc ("//issue " <> T.unpack (textEncode badgeType) <> " " <> show months <> " " <> status) >>= \case
     Right (CRCustomChatResponse _ response) -> case T.stripPrefix "code " response of
       Just c | Just code <- parseBadgeCode c -> pure code
       _ -> error $ "unexpected issue response: " <> T.unpack response
     r -> error $ "issue failed: " <> show (() <$ r)
 
--- | The post-start hook fills serviceCC once the address exists, so waiting on it is the service
--- being ready. A fixed delay here raced with startup and left the address output of one start
--- arriving during the next test.
+-- | The post-start hook fills serviceCC once the address exists, so the test waits on it rather than on a fixed delay that would race with startup and let one start's address output arrive during the next test.
 runBadgeService :: ChatConfig -> BadgeServiceOpts -> (ServiceState -> IO ()) -> IO ()
 runBadgeService cfg opts action = do
   env <- newServiceState
@@ -224,7 +234,6 @@ testRedeemBadgeCode ps =
       withNewTestChatCfg ps clientCfg "bob" bobProfile $ \bob -> do
         connectUsers alice bob
         code <- issueCode cc BTSupporter 1
-        -- the service has never seen this purchase key: a first redemption must still succeed
         alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
         alice <## "badge redeemed"
         alice <## "supporter badge - active"
@@ -254,16 +263,12 @@ testRedeemBadgeCodeTwice ps =
       alice <## "badge redeemed"
       alice <## "supporter badge - active"
       alice <##. "expires "
-      -- Retyped in another case and without separators, so it normalises to the same code and
-      -- finds the same stashed keys: a retry the service can recognise as the same signer.
       alice ##> ("/_redeem_badge_code 1 " <> map toLower (T.unpack $ badgeCodeText code))
       alice <## "badge already redeemed"
       alice ##> "/p"
       alice <## "user profile: alice (Alice, * supporter)"
       alice <## "use /p <name> [<bio>] to change it"
 
--- The service answers unknown and malformed alike; the client refuses malformed locally, which
--- is why the two reach the user differently.
 testRedeemUnknownCode :: HasCallStack => TestParams -> IO ()
 testRedeemUnknownCode ps =
   withBadgeService ps $ \clientCfg bsLink _ ->
@@ -282,7 +287,6 @@ testRedeemUnknownCode ps =
       redeemDirect alice bsLink redeemPriv "SB-00000-00000-00000-00001"
       alice <## "service response: {\"code\":\"code_invalid\",\"type\":\"error\"}"
 
--- a signed redeemBadgeCode sent as a raw service request, bypassing the client's own checks
 redeemDirect :: HasCallStack => TestCC -> String -> C.PrivateKeyEd25519 -> String -> IO ()
 redeemDirect cc bsLink signPriv code = do
   let purchaseKey = B.unpack $ strEncode $ C.publicKey signPriv
@@ -293,12 +297,10 @@ redeemDirect cc bsLink signPriv code = do
           <> "\",\"code\":\"" <> code <> "\"}}"
   cc ##> ("/_service_request 1 " <> bsLink <> " sign_key=" <> signKey <> " " <> req)
 
--- any 32 bytes: these requests never reach signing
+-- These requests never reach signing, so the master key can be any 32 bytes.
 testMasterKeyB64 :: String
 testMasterKeyB64 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA="
 
--- BadgeType decodes anything to BTUnknown, so without a check at this boundary an operator
--- typo would issue a code no app can show as a badge.
 testIssueRejectsBadArguments :: HasCallStack => TestParams -> IO ()
 testIssueRejectsBadArguments ps =
   withBadgeService ps $ \_ _ cc -> do
@@ -306,6 +308,7 @@ testIssueRejectsBadArguments ps =
     refuses "suporter"
     refuses "supporter 0"
     refuses "supporter 256"
+    refuses "supporter 18446744073709551617"
     refuses "supporter 1 gratis"
     refuses ""
     issueRaw cc "supporter 255 paid" >>= (`shouldSatisfy` isRight)
@@ -316,8 +319,6 @@ issueRaw cc args =
     Right CRCustomChatResponse {} -> pure $ Right ()
     _ -> pure $ Left ()
 
--- The guard is the badge on the profile, so it refuses whatever the code is and whichever type it
--- funds; nothing is sent, so the refused code is still redeemable.
 testRedeemSecondCode :: HasCallStack => TestParams -> IO ()
 testRedeemSecondCode ps =
   withBadgeService ps $ \clientCfg _ cc ->
@@ -339,8 +340,6 @@ testRedeemSecondCode ps =
       alice <## "legend badge - active"
       alice <##. "expires "
 
--- Each profile stashes its own keys, so the second reaches the service as a different signer -
--- rather than being handed the first profile's badge, or colliding in badge_code_redemptions.
 testRedeemSameCodeOtherProfile :: HasCallStack => TestParams -> IO ()
 testRedeemSameCodeOtherProfile ps =
   withBadgeService ps $ \clientCfg _ cc ->
@@ -359,10 +358,6 @@ testRedeemSameCodeOtherProfile ps =
       alice ##> "/user alice"
       showActiveUser alice "alice (Alice, * supporter)"
 
--- Ledger behaviour, driven against the real service - real signing, real rows - through the
--- handler rather than the transport, so the typed response can be asserted. The transport and its
--- purchaseKey guard are covered by the tests above.
-
 serviceCmd :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse
 serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} purchaseKey request =
   badgeServiceResponse bsIssuerKey bsController (Just purchaseKey) reqObject
@@ -371,7 +366,6 @@ serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} purchaseKey request =
       J.Object o -> o
       _ -> error "badge service request must encode as an object"
 
--- the fields a ledger assertion reads, without the ambiguity of the shared record names
 entryOf :: StatementEntry -> (Int, Int, UTCTime)
 entryOf StatementEntry {changeMonths, balanceMonths, balanceStartTs} = (changeMonths, balanceMonths, balanceStartTs)
 
@@ -393,7 +387,6 @@ credentialOf = \case
   BSPBadgeCredential {credential} -> credential
   r -> error $ "expected badgeCredential, got " <> show (J.toJSON r)
 
--- the next month falls due when the balance start reaches it, which is the last entry's start
 nextDue :: [StatementEntry] -> UTCTime
 nextDue entries = let (_, _, start) = entryOf (last entries) in start
 
@@ -413,8 +406,6 @@ expiryOf r = (\(BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) -> badgeExpiry) <
 masterKeyOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeMasterKey
 masterKeyOf r = (\(BadgeCredential _ mk _ _) -> mk) <$> credentialOf r
 
--- A three month code credits three months and issues the first; a month later the second is
--- issued, and only then. Asserted against the service's own rows.
 testCodeMonthsRenew :: HasCallStack => TestParams -> IO ()
 testCodeMonthsRenew ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
@@ -427,10 +418,8 @@ testCodeMonthsRenew ps =
     map (\e -> let (c, m, _) = entryOf e in (c, m)) entries `shouldBe` [(3, 3), (-1, 2)]
     credentialOf redeemed `shouldSatisfy` isJust
     let firstDue = nextDue entries
-    -- still inside the first month: nothing new is written
     r2 <- assertBalance env purchaseKey (last entries)
     map entryTag (fst $ statementOf r2) `shouldBe` []
-    -- the second month falls due
     setClockAt bsClock firstDue
     r3 <- assertBalance env purchaseKey (last entries)
     let (entries3, prev3) = statementOf r3
@@ -438,13 +427,10 @@ testCodeMonthsRenew ps =
     map entryTag entries3 `shouldBe` ["badge"]
     map (\e -> let (c, m, _) = entryOf e in (c, m)) entries3 `shouldBe` [(-1, 1)]
     credentialOf r3 `shouldSatisfy` isJust
-    -- a different credential for a different month, not the same signature returned twice
     credentialOf r3 `shouldNotBe` credentialOf redeemed
   where
     entryIdOf StatementEntry {entryId} = entryId
 
--- A repeat inside an issued month returns the credential already stored, and writes no row:
--- re-signing the same period would churn the client's credential for nothing.
 testRepeatInsideIssuedPeriod :: HasCallStack => TestParams -> IO ()
 testRepeatInsideIssuedPeriod ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do
@@ -456,7 +442,6 @@ testRepeatInsideIssuedPeriod ps =
     map entryTag (fst $ statementOf repeated) `shouldBe` []
     credentialOf repeated `shouldBe` credentialOf redeemed
 
--- Months that passed unissued are lapsed in one row, and the month now current is issued.
 testLapseWhileAway :: HasCallStack => TestParams -> IO ()
 testLapseWhileAway ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
@@ -464,8 +449,7 @@ testLapseWhileAway ps =
     (purchaseKey, masterKey) <- newPurchaseKeys
     redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
     let (entries, _) = statementOf redeemed
-    -- away past the fourth boundary of the run: three months lapse, the fourth is due. Counted
-    -- from the anchor - adding months to an already clipped due date would miss the boundary.
+    -- The clock is moved from the anchor because adding months to an already clipped due date would miss the boundary.
     setClockAt bsClock (addMonths 4 (anchorOf (last entries)))
     away <- assertBalance env purchaseKey (last entries)
     let (entries', _) = statementOf away
@@ -473,9 +457,6 @@ testLapseWhileAway ps =
     map (\e -> let (c, m, _) = entryOf e in (c, m)) entries' `shouldBe` [(-3, 2), (-1, 1)]
     credentialOf away `shouldSatisfy` isJust
 
--- Every badge issued in a week expires at the same moment, so the expiry says nothing about when
--- it was bought. On the last month of a balance paidThrough is the period end exactly, so a
--- client-proposed expiry capped the rounding away and put the expiry back on the anniversary.
 testLastMonthExpiryRounds :: HasCallStack => TestParams -> IO ()
 testLastMonthExpiryRounds ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
@@ -487,12 +468,9 @@ testLastMonthExpiryRounds ps =
     renewed <- assertBalance env purchaseKey (last entries)
     let (entries', _) = statementOf renewed
     map entryTag entries' `shouldBe` ["badge"]
-    -- the last month the balance funds: nothing is left to issue after it
     map (\e -> let (c, m, _) = entryOf e in (c, m)) entries' `shouldBe` [(-1, 0)]
     expiryOf renewed `shouldBe` Just (endOfMondayAfter (nextDue entries'))
 
--- A renewal states nothing, so the credential carries the master key stored with the purchase.
--- The service used to sign whatever key the request supplied, checking only the badge type.
 testRenewalSignsWithStoredMasterKey :: HasCallStack => TestParams -> IO ()
 testRenewalSignsWithStoredMasterKey ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
@@ -505,8 +483,7 @@ testRenewalSignsWithStoredMasterKey ps =
     renewed <- assertBalance env purchaseKey (last entries)
     masterKeyOf renewed `shouldBe` Just masterKey
 
--- The replicated columns of a ledger, in order. service_created_at and created_at are left out:
--- the client records when it stored a row, which is not when the service wrote it.
+-- This type omits service_created_at and created_at because the client records when it stored a row, not when the service wrote it, so those columns never match.
 type ReplicatedRow = (Text, Int, Int, UTCTime, Text, Maybe Text)
 
 ledgerRows :: ChatController -> String -> IO [ReplicatedRow]
@@ -532,8 +509,6 @@ balanceChecks ChatController {chatStore} =
     map (fmap unBI . fromOnly)
       <$> DB.query_ db "SELECT balance_checked FROM badge_ledger ORDER BY entry_id"
 
--- The client copies the statement verbatim and authors nothing, so after a redemption both sides
--- hold the same rows under the same entry ids.
 testClientReplicatesLedger :: HasCallStack => TestParams -> IO ()
 testClientReplicatesLedger ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->
@@ -545,18 +520,14 @@ testClientReplicatesLedger ps =
       alice <##. "expires "
       serviceLedger <- ledgerRows cc "sx_badge_service_badge_ledger"
       clientLedger <- ledgerRows (chatController alice) "badge_ledger"
-      -- the code credit and the first month, on both sides
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) serviceLedger `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge")]
       clientLedger `shouldBe` serviceLedger
-      -- and re-ran both operations against them: the credit from the seed, the issue from the credit
       checks <- balanceChecks (chatController alice)
       checks `shouldBe` [Just True, Just True]
-      -- redeeming again replays the statement, and must not duplicate a single row
       alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
       alice <## "badge already redeemed"
       clientLedger' <- ledgerRows (chatController alice) "badge_ledger"
       clientLedger' `shouldBe` serviceLedger
-      -- nor a second issuance for the one month issued: the replay names a month already stored
       expiries <- issuedExpiries (chatController alice)
       length expiries `shouldBe` 1
       -- the CLI lists the rows oldest first, with the dates they carry
@@ -572,25 +543,19 @@ testClientReplicatesLedger ps =
   where
     day = formatTime defaultTimeLocale "%Y-%m-%d"
 
--- the balance start of the last row, which is when the next month falls due
 dueAtOf :: [ReplicatedRow] -> UTCTime
 dueAtOf rows = let (_, _, _, start, _, _) = last rows in start
 
--- | The two clock positions a renewal needs: the request, a day before the shown credential
--- lapses, and the presentation, as it lapses.
 renewalMoments :: [ReplicatedRow] -> (UTCTime, UTCTime)
 renewalMoments rows =
   let expiry = endOfMondayAfter $ dueAtOf rows
    in (addUTCTime (-nominalDay) expiry, expiry)
 
--- | Real seconds between arming a wake and it firing. Long enough for the arming pass to finish
--- first, since one that overruns does the work itself and the test passes without a wake at all.
+-- | The margin must be long enough for the arming pass to finish first, because a pass that overruns does the work itself and the test then passes without arming any wake.
 badgeWakeMargin :: NominalDiffTime
 badgeWakeMargin = 3
 
--- | Stand the clock just short of t and signal once. A sleeping worker cannot see the clock move,
--- so the signal is what makes it re-derive - and, standing short, it arms the wake at t rather
--- than doing the work. Whatever follows is produced by that wake.
+-- | Standing the clock just short of t before signalling makes the worker arm the wake at t rather than do the work in this pass, so whatever follows is produced by that wake.
 armWakeAt :: HasCallStack => TestCC -> TestClock -> UTCTime -> IO ()
 armWakeAt cc clock t = do
   setClockAt clock $ addUTCTime (negate badgeWakeMargin) t
@@ -618,8 +583,6 @@ setBadgeExpiry ChatController {chatStore} whichBadge t =
   withTransaction chatStore $ \db ->
     DB.execute db (fromString $ "UPDATE contact_profiles SET badge_expiry = ? WHERE " <> whichBadge <> " IS NOT NULL") (Only t)
 
--- | Copy the newest ledger row as an entry of a type this version does not know: the service is
--- deployed ahead of app releases, so a new type first arrives at clients that predate it.
 insertUnknownLedgerEntry :: ChatController -> IO ()
 insertUnknownLedgerEntry ChatController {chatStore} =
   withTransaction chatStore $ \db ->
@@ -632,8 +595,6 @@ insertUnknownLedgerEntry ChatController {chatStore} =
         <> "  balance_badge_type, service_created_at, created_at, 'credit', 'grant', 1, '{\"type\":\"grant\"}'"
         <> " FROM badge_ledger ORDER BY entry_id DESC LIMIT 1"
 
--- | The month the profile is showing, and the month last issued. They must agree: a profile left
--- on an earlier month shows contacts a badge the ledger has already replaced.
 shownAndIssuedExpiry :: ChatController -> IO (Maybe UTCTime, Maybe UTCTime)
 shownAndIssuedExpiry ChatController {chatStore} = withTransaction chatStore $ \db -> do
   shown :: [(Maybe UTCTime, Int64)] <-
@@ -649,7 +610,7 @@ shownAndIssuedExpiry ChatController {chatStore} = withTransaction chatStore $ \d
 waitShownIssued :: HasCallStack => ChatController -> IO ()
 waitShownIssued cc = loop (100 :: Int)
   where
-    -- both absent would compare equal, so the presence of a badge is asserted separately
+    -- Both values being absent would compare equal, so the presence of a badge is asserted separately.
     loop 0 = shownAndIssuedExpiry cc >>= \(shown, issued) -> do
       shown `shouldSatisfy` isJust
       shown `shouldBe` issued
@@ -657,7 +618,6 @@ waitShownIssued cc = loop (100 :: Int)
       shownAndIssuedExpiry cc >>= \(shown, issued) ->
         if isJust shown && shown == issued then pure () else threadDelay 50000 >> loop (i - 1)
 
--- The worker acts on its own schedule, so the test waits for the rows rather than for a response.
 waitLedgerRows :: HasCallStack => ChatController -> Int -> IO [ReplicatedRow]
 waitLedgerRows cc n = loop (100 :: Int)
   where
@@ -666,19 +626,17 @@ waitLedgerRows cc n = loop (100 :: Int)
       rows <- ledgerRows cc "badge_ledger"
       if length rows >= n then pure rows else threadDelay 50000 >> loop (i - 1)
 
--- the badge the profile shows, which the worker clears when the balance has run out
 shownBadgeId :: HasCallStack => ChatController -> IO (Maybe Int64)
 shownBadgeId ChatController {chatStore} = do
-  -- two columns rather than one, so the row type needs no backend-specific Only
+  -- Selecting two columns rather than one lets the row type avoid a backend-specific Only wrapper.
   rows :: [(Maybe Int64, Int64)] <-
     withTransaction chatStore $ \db ->
       DB.query_ db "SELECT shown_badge_id, user_id FROM users WHERE user_id = 1"
-  -- not Nothing on an unexpected shape: waiting for Nothing would then pass without reading it
+  -- An unexpected row shape raises an error rather than returning Nothing, which would let a wait for Nothing pass without reading the row.
   pure $ case rows of
     [(i, _)] -> i
     _ -> error $ "expected one users row, got " <> show rows
 
--- the occurrence the user answered, which silences that alert and no other
 ackedEpisode :: HasCallStack => ChatController -> IO (Maybe Text, Maybe Text)
 ackedEpisode ChatController {chatStore} = do
   rows :: [(Maybe Text, Maybe Text)] <-
@@ -703,9 +661,6 @@ redeemFirstBadge alice code = do
   alice <## "supporter badge - active"
   alice <##. "expires "
 
--- A credential nears its expiry and the badge renews from the worker's own pass, with no command
--- sent by the app: chat activate only signals it, and the work is derived from stored state.
--- The request and the presentation are a day apart, so each renewal takes two passes.
 testWorkerRenews :: HasCallStack => TestParams -> IO ()
 testWorkerRenews ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -714,24 +669,19 @@ testWorkerRenews ps =
       redeemFirstBadge alice code
       redeemed <- ledgerRows (chatController alice) "badge_ledger"
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) redeemed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge")]
-      -- the credential the profile shows is a day from lapsing, while the app is running
       let (requestAt, presentAt) = renewalMoments redeemed
       setClockAt bsClock requestAt
       alice ##> "/_app activate"
       alice <## "ok"
       renewed <- waitLedgerRows (chatController alice) 3
-      -- the renewal reports itself, no command having asked for it
       alice <##. "1: supporter"
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
-      -- the month is issued but not yet worn: the profile still carries the one it had
       (shownEarly, issuedEarly) <- shownAndIssuedExpiry (chatController alice)
       shownEarly `shouldNotBe` issuedEarly
-      -- a day later the held credential lapses and the new month is presented
       setClockAt bsClock presentAt
       alice ##> "/_app activate"
       alice <## "ok"
       waitShownIssued (chatController alice)
-      -- the third month too: the state a renewal leaves must support the next one
       let (requestAt2, presentAt2) = renewalMoments renewed
       setClockAt bsClock requestAt2
       alice ##> "/_app activate"
@@ -740,16 +690,13 @@ testWorkerRenews ps =
       renewed2 <- waitLedgerRows (chatController alice) 4
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed2
         `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge"), (-1, 0, Just "badge")]
-      -- the client authored none of them: the service holds exactly the same rows
       serviceLedger <- ledgerRows cc "sx_badge_service_badge_ledger"
       renewed2 `shouldBe` serviceLedger
-      -- and the profile shows the month last issued, not an earlier one
       setClockAt bsClock presentAt2
       alice ##> "/_app activate"
       alice <## "ok"
       waitShownIssued (chatController alice)
 
--- The request is made by the wake the worker set for itself a day before the credential lapses.
 testRequestWakeFires :: HasCallStack => TestParams -> IO ()
 testRequestWakeFires ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -758,15 +705,12 @@ testRequestWakeFires ps =
       redeemFirstBadge alice code
       redeemed <- ledgerRows (chatController alice) "badge_ledger"
       armWakeAt alice bsClock $ fst $ renewalMoments redeemed
-      -- the arming pass asked for nothing, so what follows cannot be its doing
       ledgerRows (chatController alice) "badge_ledger" >>= (`shouldBe` redeemed)
       renewed <- waitLedgerRows (chatController alice) 3
       alice <##. "1: supporter"
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
         `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
 
--- The presentation is made by the wake at the expiry itself, a day after the request that issued
--- the month it presents.
 testPresentWakeFires :: HasCallStack => TestParams -> IO ()
 testPresentWakeFires ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -781,12 +725,9 @@ testPresentWakeFires ps =
       void $ waitLedgerRows (chatController alice) 3
       alice <##. "1: supporter"
       armWakeAt alice bsClock presentAt
-      -- the arming pass presented nothing: the profile still carries the credential it had
       shownAndIssuedExpiry (chatController alice) >>= \(shown, issued) -> shown `shouldNotBe` issued
       waitShownIssued (chatController alice)
 
--- The newest row being of an unknown type must not stop the renewal: it is stored verbatim and
--- read back to be asserted, rather than leaving the client with no entry to assert at all.
 testRenewsAfterUnknownEntry :: HasCallStack => TestParams -> IO ()
 testRenewsAfterUnknownEntry ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -800,17 +741,11 @@ testRenewsAfterUnknownEntry ps =
       alice <## "ok"
       renewed <- waitLedgerRows (chatController alice) 4
       alice <##. "1: supporter"
-      -- the unknown row is asserted, so the service answers with what it does not hold: the whole
-      -- ledger, which re-stores the two rows already held and adds the month it issued
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
         `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (0, 2, Just "grant"), (-1, 1, Just "badge")]
-      -- the issued row follows the badge row in the statement but the unknown one in the ledger,
-      -- and verifies all the same - the client cannot see that the service dropped a row
       checks <- balanceChecks (chatController alice)
       checks `shouldBe` [Just True, Just True, Nothing, Just True]
 
--- The worker driven by chat start rather than by activate, and the only test where the client is
--- given a lapse row to store: the months that passed while the app was stopped.
 testRenewsAfterRestart :: HasCallStack => TestParams -> IO ()
 testRenewsAfterRestart ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> do
@@ -818,26 +753,19 @@ testRenewsAfterRestart ps =
       code <- issueCode cc BTSupporter 6
       redeemFirstBadge alice code
       ledgerRows (chatController alice) "badge_ledger"
-    -- the credit row's start is the anchor: a grant on a run that has never lapsed moves neither
     let (_, _, _, anchor, _, _) = head rows
-    -- stopped until past the fourth boundary of the run: three months lapse, the fourth is issued
     setClockAt bsClock $ addMonths 4 anchor
     withTestChatCfg ps bsClientCfg "alice" $ \alice -> do
       renewed <- waitLedgerRows (chatController alice) 4
       alice <##. "1: supporter"
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
         `shouldBe` [(6, 6, Just "code"), (-1, 5, Just "badge"), (-3, 2, Just "lapse"), (-1, 1, Just "badge")]
-      -- the lapse row was replicated rather than authored here
       serviceLedger <- ledgerRows cc "sx_badge_service_badge_ledger"
       renewed `shouldBe` serviceLedger
-      -- and re-run: the renewal's two rows against the tip the client held, not against a seed
       checks <- balanceChecks (chatController alice)
       checks `shouldBe` replicate 4 (Just True)
-      -- a week missed costs only the day between the two steps: one pass does both
       waitShownIssued (chatController alice)
 
--- When the balance is spent and the last period ends, the badge stops being shown and the profile
--- update reaches contacts - the visible half of "the badge expired".
 testWorkerRetiresExpired :: HasCallStack => TestParams -> IO ()
 testWorkerRetiresExpired ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -848,7 +776,6 @@ testWorkerRetiresExpired ps =
         redeemFirstBadge alice code
         alice #> "@bob hi"
         bob <# "alice *> hi"
-        -- bob sees it before it expires
         bob ##> "/i alice"
         bob <## "contact ID: 2"
         bob <## "supporter badge - active"
@@ -860,25 +787,19 @@ testWorkerRetiresExpired ps =
         bob <## "quantum resistant end-to-end encryption"
         bob <## currentChatVRangeInfo
         rows <- ledgerRows (chatController alice) "badge_ledger"
-        -- the one month it bought has ended and nothing is left to issue
         setClockAt bsClock $ dueAtOf rows
         alice ##> "/_app activate"
         alice <## "ok"
-        -- support ended, and the state it changed by retiring the badge carries the same alert
         alice <##. "badge alert: support_ended "
         alice <##. "1: supporter"
         alice <##. "badge alert: support_ended "
-        -- the profile stops showing it locally
         waitShownBadge (chatController alice) Nothing
         alice ##> "/p"
         alice <## "user profile: alice (Alice)"
         alice <## "use /p <name> [<bio>] to change it"
-        -- The removal travels as a profile update, which prints nothing when only the badge
-        -- changed (viewContactUpdated compares names and links). The next message shows it
-        -- arrived: bob's prefix loses the badge marker it carried above.
+        -- A profile update prints nothing when only the badge changed, because viewContactUpdated compares names and links, so the next message is what confirms the removal reached bob.
         alice #> "@bob after"
         bob <# "alice> after"
-        -- and the badge is gone from the contact's stored profile, not merely from the prefix
         bob ##> "/i alice"
         bob <## "contact ID: 2"
         bob <## "receiving messages via: localhost"
@@ -888,9 +809,6 @@ testWorkerRetiresExpired ps =
         bob <## "quantum resistant end-to-end encryption"
         bob <## currentChatVRangeInfo
 
--- The credential outlives the balance by up to eight days, because its expiry covers renewal and
--- not entitlement. A worker scheduled only on that expiry would leave the badge worn, and the user
--- unasked to buy again, for the whole of that week - so paidThrough is a wake of its own.
 testRetiresWhenEntitlementEnds :: HasCallStack => TestParams -> IO ()
 testRetiresWhenEntitlementEnds ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -899,19 +817,14 @@ testRetiresWhenEntitlementEnds ps =
       redeemFirstBadge alice code
       rows <- ledgerRows (chatController alice) "badge_ledger"
       armWakeAt alice bsClock $ dueAtOf rows
-      -- that pass retired nothing and printed nothing: the badge is still worn and /p says so
       alice ##> "/p"
       alice <## "user profile: alice (Alice, * supporter)"
       alice <## "use /p <name> [<bio>] to change it"
-      -- nothing signals the worker from here, and the credential has days left, so the wake that
-      -- produces these is the one the worker set for itself at paidThrough
       alice <##. "badge alert: support_ended "
       alice <##. "1: supporter"
       alice <##. "badge alert: support_ended "
       waitShownBadge (chatController alice) Nothing
 
--- The alert is derived from stored state rather than kept pending, so it is still there after a
--- restart; acknowledging records the occurrence it answered, and the same one is not raised again.
 testEndedAlert :: HasCallStack => TestParams -> IO ()
 testEndedAlert ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> do
@@ -923,19 +836,15 @@ testEndedAlert ps =
       setClockAt bsClock endsAt
       alice ##> "/_app activate"
       alice <## "ok"
-      -- the pass raises the alert, and reports the state it changed by retiring the badge - which
-      -- carries the same alert, the alert being part of the state
       alice <##. "badge alert: support_ended "
       alice <##. "1: supporter"
       alice <##. "badge alert: support_ended "
       pure endsAt
-    -- nothing was stored as pending, and the alert is derived again on the next start
     withTestChatCfg ps bsClientCfg "alice" $ \alice -> do
       alice <##. "badge alert: support_ended "
       alice ##> ("/_badge ack 1 1 support_ended off " <> T.unpack (safeDecodeUtf8 $ strEncode endsAt))
       alice <##. "1: supporter"
       ackedEpisode (chatController alice) `shouldReturn` (Just "support_ended", Just (safeDecodeUtf8 $ strEncode endsAt))
-      -- acknowledged: the state no longer carries the alert, and no event raises it again
       alice ##> "/_badge state 1"
       alice <##. "1: supporter"
       alice ##> "/_app activate"
@@ -1174,8 +1083,6 @@ waitIssueErrorCleared cc = loop (100 :: Int)
       issueErrorRow cc >>= \r ->
         if r == (Nothing, Nothing) then pure () else threadDelay 50000 >> loop (i - 1)
 
--- A worker runs for every profile, not only the one in use, so presenting a renewed badge must not
--- make its profile active - the next message would then be sent from the wrong identity.
 testRenewalKeepsActiveProfile :: HasCallStack => TestParams -> IO ()
 testRenewalKeepsActiveProfile ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -1185,7 +1092,6 @@ testRenewalKeepsActiveProfile ps =
       rows <- ledgerRows (chatController alice) "badge_ledger"
       alice ##> "/create user alisa"
       showActiveUser alice "alisa"
-      -- alice's credential is a day from lapsing while alisa is the profile in use
       let (requestAt, presentAt) = renewalMoments rows
       setClockAt bsClock requestAt
       alice ##> "/_app activate"
@@ -1193,9 +1099,7 @@ testRenewalKeepsActiveProfile ps =
       renewed <- waitLedgerRows (chatController alice) 3
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
         `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
-      -- the renewal is reported for alice, and the prefix is there because alice is not active
       alice <##. "[user: alice] 1: supporter"
-      -- presenting is the pass that writes alice's profile, and it is the one that could switch
       setClockAt bsClock presentAt
       alice ##> "/_app activate"
       alice <## "ok"
@@ -1203,8 +1107,6 @@ testRenewalKeepsActiveProfile ps =
       alice ##> "/p"
       showActiveUser alice "alisa"
 
--- A snooze silences the alert until it lapses, and then it is raised once more, without a restart.
--- A snooze changes nothing else on the purchase, so the occurrence already raised has to count it.
 testSnoozedAlertReturns :: HasCallStack => TestParams -> IO ()
 testSnoozedAlertReturns ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -1221,18 +1123,14 @@ testSnoozedAlertReturns ps =
       alice <##. "badge alert: support_ended "
       alice ##> ("/_badge ack 1 1 support_ended on " <> T.unpack (safeDecodeUtf8 $ strEncode endsAt))
       alice <##. "1: supporter"
-      -- the ack signalled the worker, and the pass it ran was silent: /p prints only its own output
       alice ##> "/p"
       alice <## "user profile: alice (Alice)"
       alice <## "use /p <name> [<bio>] to change it"
-      -- the snooze lapses: nothing else about the badge changed, so only the alert is reported
       setClockAt bsClock $ addUTCTime (nominalDay + 60) endsAt
       alice ##> "/_app activate"
       alice <## "ok"
       alice <##. "badge alert: support_ended "
 
--- The worker re-reads the profile each pass. Presenting a renewed badge from a copy captured when
--- the worker started would revert any edit made since and broadcast the profile in its old form.
 testRenewalKeepsProfileEdits :: HasCallStack => TestParams -> IO ()
 testRenewalKeepsProfileEdits ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -1241,7 +1139,6 @@ testRenewalKeepsProfileEdits ps =
         connectUsers alice bob
         code <- issueCode cc BTSupporter 3
         redeemFirstBadge alice code
-        -- the profile is edited after the worker started
         alice ##> "/p alice Alice Jones"
         concurrentlyN_
           [ alice <## "user bio changed to Alice Jones (your 1 contacts are notified)",
@@ -1256,14 +1153,11 @@ testRenewalKeepsProfileEdits ps =
         renewed <- waitLedgerRows (chatController alice) 3
         map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
           `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
-        -- presenting a day later is the pass that broadcasts the profile
         setClockAt bsClock presentAt
         alice ##> "/_app activate"
         alice <## "ok"
         waitShownIssued (chatController alice)
-        -- The renewal's profile update carries the edited bio. Had it carried the profile the
-        -- worker started with, bob would print a bio change back to "Alice" here, before the
-        -- message - so the message arriving next is the assertion.
+        -- Had the renewal carried the profile the worker started with, bob would print a bio change back to "Alice" before the next message, so that message is what asserts the edited bio survived.
         alice #> "@bob after renewal"
         bob <# "alice *> after renewal"
         bob ##> "/i alice"
@@ -1277,8 +1171,6 @@ testRenewalKeepsProfileEdits ps =
         bob <## "quantum resistant end-to-end encryption"
         bob <## currentChatVRangeInfo
 
--- Forces the state a crash between the issuance write and the profile write leaves behind: the
--- month is issued, unpresented, and no later pass finds it due.
 testPresentationCatchesUp :: HasCallStack => TestParams -> IO ()
 testPresentationCatchesUp ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
@@ -1304,9 +1196,8 @@ testPresentationCatchesUp ps =
         length expiries `shouldBe` 2
         let firstMonth = head expiries
             latestMonth = last expiries
-        -- without this bob can receive the presentation after the updates below and never lose it
+        -- The test waits here first so that bob does not receive the presentation after the updates below and keep it.
         waitPeerBadgeExpiry (chatController bob) latestMonth
-        -- the renewal's rows are kept; only its presentation is undone, on both sides
         setBadgeExpiry (chatController alice) "badge_signature" firstMonth
         setBadgeExpiry (chatController bob) "badge_proof" firstMonth
         alice ##> "/_app activate"
@@ -1339,15 +1230,114 @@ testPurchaseKeyMismatch ps =
       alice ##> ("/_service_request 1 " <> bsLink <> " sign_key=" <> signKey <> " " <> req)
       alice <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}"
 
--- A secret that is not the key clients trust at its index makes every credential unverifiable,
--- and each code redeemed against it is spent for good - so the service must not start at all.
 testIssuerKeyMustMatchConfig :: HasCallStack => TestParams -> IO ()
 testIssuerKeyMustMatchConfig ps = do
   Right (pk, sk) <- bbsKeyGen
   Right (_, otherSk) <- bbsKeyGen
   let optsFor sk' = mkBadgeServiceOpts ps sk'
       cfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk}
-  checkIssuerKey (optsFor sk) cfg >>= (`shouldSatisfy` isRight)
-  checkIssuerKey (optsFor otherSk) cfg >>= (`shouldSatisfy` isLeft)
-  -- an index no client trusts is equally fatal
-  checkIssuerKey (optsFor sk) testCfg {badgePublicKeys = M.empty} >>= (`shouldSatisfy` isLeft)
+  checkIssuerKey (optsFor sk) Nothing cfg >>= (`shouldSatisfy` isRight)
+  checkIssuerKey (optsFor otherSk) Nothing cfg >>= (`shouldSatisfy` isLeft)
+  checkIssuerKey (optsFor sk) Nothing testCfg {badgePublicKeys = M.empty} >>= (`shouldSatisfy` isLeft)
+  let halfGiven = (optsFor sk) {issuerKey = Left "--issuer-key-idx and --issuer-secret are given together or not at all"}
+  checkIssuerKey halfGiven Nothing cfg >>= (`shouldSatisfy` isLeft)
+
+testIssuerIniKeyMustBeTrusted :: HasCallStack => TestParams -> IO ()
+testIssuerIniKeyMustBeTrusted ps = do
+  Right (pk, sk) <- bbsKeyGen
+  Right (_, untrusted) <- bbsKeyGen
+  let cfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk}
+      fromCli = mkBadgeServiceOpts ps sk
+      fromIni = fromCli {issuerKey = Right Nothing}
+      iniWith idx k = withIssuer ["index = " <> tshow idx, "private_key = " <> safeDecodeUtf8 (strEncode k)] readServiceConfig
+  Right trusted <- iniWith testIssuerKeyIdx sk
+  checkIssuerKey fromIni (Just trusted) cfg `shouldReturn` Right (BadgeIssuerKey testIssuerKeyIdx sk)
+
+  Right wrongSecret <- iniWith testIssuerKeyIdx untrusted
+  checkIssuerKey fromIni (Just wrongSecret) cfg >>= (`shouldSatisfy` isLeft)
+  checkIssuerKey fromCli (Just wrongSecret) cfg `shouldReturn` Right (BadgeIssuerKey testIssuerKeyIdx sk)
+
+  Right unknownIndex <- iniWith (testIssuerKeyIdx + 8) sk
+  checkIssuerKey fromIni (Just unknownIndex) cfg
+    `shouldReturn` Left ("no configured badge key at index " <> show (testIssuerKeyIdx + 8) <> ", clients could not verify what this service signs")
+
+testRedeemUnpaidCode :: HasCallStack => TestParams -> IO ()
+testRedeemUnpaidCode ps =
+  withBadgeService ps $ \clientCfg _ cc ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      unpaid <- issueCodeAs cc BTSupporter 1 "unpaid"
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg unpaid)
+      alice <## "cannot redeem badge code: badge service error: payment_pending"
+      paid <- issueCodeAs cc BTSupporter 1 "paid"
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg paid)
+      alice <## "badge redeemed"
+      alice <## "supporter badge - active"
+      alice <##. "expires "
+
+-- | A redemption deadline is a year out and cannot be waited for, so the code is issued unpaid and then marked paid with a deadline already in the past.
+testExpiredCode :: HasCallStack => TestParams -> IO ()
+testExpiredCode ps =
+  withBadgeService ps $ \clientCfg _ cc ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCodeAs cc BTSupporter 1 "unpaid"
+      now <- getCurrentTime
+      withDB' "markCodePaid" cc (\db -> markCodePaid db (badgeCodeHash code) (addUTCTime (-60) now))
+        `shouldReturn` Right ()
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "cannot redeem badge code: badge service error: code_expired"
+
+testRedeemedBeforeTheDeadline :: HasCallStack => TestParams -> IO ()
+testRedeemedBeforeTheDeadline ps =
+  withBadgeService ps $ \clientCfg _ cc ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCodeAs cc BTSupporter 1 "unpaid"
+      now <- getCurrentTime
+      withDB' "markCodePaid" cc (\db -> markCodePaid db (badgeCodeHash code) (addUTCTime 3600 now))
+        `shouldReturn` Right ()
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "badge redeemed"
+      alice <## "supporter badge - active"
+      alice <##. "expires "
+
+      -- The expiry is set with direct SQL because markCodePaid writes it only on the unpaid-to-paid transition, which this code has already made.
+      withDB' "expireCode" cc (\db ->
+        DB.execute
+          db
+          "UPDATE sx_badge_service_badge_codes SET expires_at = ? WHERE code_hash = ?"
+          (addUTCTime (-60) now, Binary (badgeCodeHash code)))
+        `shouldReturn` Right ()
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "badge already redeemed"
+
+testRevokeRedeemedCode :: HasCallStack => TestParams -> IO ()
+testRevokeRedeemedCode ps =
+  withBadgeService ps $ \clientCfg _ cc ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCodeAs cc BTSupporter 1 "paid"
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "badge redeemed"
+      alice <## "supporter badge - active"
+      alice <##. "expires "
+      refused <- revokeCodeAs cc code
+      refused `shouldSatisfy` T.isInfixOf "redeemed already, so it cannot be revoked"
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "badge already redeemed"
+
+testRevokeUnknownCode :: HasCallStack => TestParams -> IO ()
+testRevokeUnknownCode ps =
+  withBadgeService ps $ \_ _ cc -> do
+    g <- C.newRandom
+    code <- randomBadgeCode g
+    unknown <- revokeCodeAs cc code
+    unknown `shouldSatisfy` T.isInfixOf "no such code"
+
+testRevokedCode :: HasCallStack => TestParams -> IO ()
+testRevokedCode ps =
+  withBadgeService ps $ \clientCfg _ cc ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      paid <- issueCodeAs cc BTSupporter 1 "paid"
+      revokeCodeAs cc paid `shouldReturn` "revoked"
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg paid)
+      alice <## "cannot redeem badge code: badge service error: code_invalid"
+      second <- revokeCodeAs cc paid
+      second `shouldSatisfy` T.isInfixOf "revoked already"

tests/Bots/BadgeService/CatalogTests.hs

@@ -0,0 +1,308 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bots.BadgeService.CatalogTests where
+
+import BadgeService.Catalog
+import Control.Monad (when)
+import Data.List (find)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Text.Read (decimal)
+import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import Data.Word (Word32, Word8)
+import Simplex.Chat.Badges (BadgeType (..))
+import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..))
+import Simplex.Chat.Badges.Types (BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..))
+import Simplex.Chat.PaymentService.Types (CurrencyAmount (..))
+import Test.Hspec
+
+badgeCatalogTests :: Spec
+badgeCatalogTests = describe "badge catalog" $ do
+  it "prices the six sellable pairs at their literal totals" testLiteralTotals
+  it "delivers the free months it does not charge for" testFreeMonths
+  it "truncates a percentage discount in the buyer's favour" testDiscountTruncates
+  it "refuses a pair it cannot price" testRefusals
+  it "refuses a gross that would wrap, even where the charge is sellable" testGrossIsBounded
+  it "agrees with the catalog compiled into the page" testNoDriftFromWeb
+  it "refuses an unknown priceId" testPriceOfferUnknownPrice
+  it "refuses a badge type this service does not sell" testPriceOfferUnsoldBadgeType
+  it "refuses a disabled price" testPriceOfferDisabledPrice
+  it "refuses an unknown offerId" testPriceOfferUnknownOffer
+  it "refuses a disabled offer" testPriceOfferDisabledOffer
+  it "refuses an offer that names a different price" testPriceOfferMismatchedPrice
+  it "refuses a pair offerTotal itself cannot price" testPriceOfferUnpriced
+  it "refuses on the badge type before it checks whether the price is disabled" testPriceOfferOrderUnsoldBeforeDisabled
+  it "prices a deprecated price rather than refusing it" testPriceOfferDeprecatedPricePriced
+  it "prices a deprecated offer rather than refusing it" testPriceOfferDeprecatedOfferPriced
+  it "carries the term's gross, not the per-month rate, for a free-months offer" testPriceOfferGrossFreeMonths
+  it "carries the term's gross, not the per-month rate, for a percentage-discount offer" testPriceOfferGrossDiscount
+  it "applies an offer with no priceId to any price" testPriceOfferAnyPrice
+
+offer :: Word8 -> OfferDiscount -> BadgeOffer
+offer months discount =
+  BadgeOffer {offerId = BadgeOfferId "o", priceId = Nothing, months, discount, status = BISActive, createdAt = epoch}
+
+epoch :: UTCTime
+epoch = posixSecondsToUTCTime 0
+
+testLiteralTotals :: IO ()
+testLiteralTotals = do
+  amountOf 700 Nothing `shouldBe` Right 700
+  amountOf 700 (Just (offer 3 (ODFreeMonths 1))) `shouldBe` Right 1400
+  amountOf 700 (Just (offer 12 (ODDiscount 50))) `shouldBe` Right 4200
+  amountOf 7000 Nothing `shouldBe` Right 7000
+  amountOf 7000 (Just (offer 3 (ODFreeMonths 1))) `shouldBe` Right 14000
+  amountOf 7000 (Just (offer 12 (ODDiscount 50))) `shouldBe` Right 42000
+  where
+    amountOf p o = (\(_, _, CurrencyAmount a) -> a) <$> offerTotal (CurrencyAmount p) o
+
+testFreeMonths :: IO ()
+testFreeMonths =
+  offerTotal (CurrencyAmount 7000) (Just (offer 3 (ODFreeMonths 1)))
+    `shouldBe` Right (3, CurrencyAmount 21000, CurrencyAmount 14000)
+
+testDiscountTruncates :: IO ()
+testDiscountTruncates =
+  offerTotal (CurrencyAmount 333) (Just (offer 3 (ODDiscount 33)))
+    `shouldBe` Right (3, CurrencyAmount 999, CurrencyAmount 669)
+
+testRefusals :: IO ()
+testRefusals = do
+  offerTotal (CurrencyAmount 700) (Just (offer 0 (ODDiscount 10))) `shouldBe` Left OIZeroMonths
+  offerTotal (CurrencyAmount 700) (Just (offer 3 (ODFreeMonths 3))) `shouldBe` Left OIFreeMonthsExceedTerm
+  offerTotal (CurrencyAmount 700) (Just (offer 3 (ODDiscount 100))) `shouldBe` Left OIDiscountTooLarge
+  offerTotal (CurrencyAmount 0) Nothing `shouldBe` Left OIAmountUnsellable
+  offerTotal (CurrencyAmount 20000000) (Just (offer 12 (ODDiscount 50))) `shouldBe` Left OIAmountUnsellable
+
+testGrossIsBounded :: IO ()
+testGrossIsBounded = do
+  let chargedOf p o = (\(_, _, CurrencyAmount a) -> a) <$> offerTotal (CurrencyAmount p) o
+  chargedOf 100000000 (Just (offer 1 (ODDiscount 0))) `shouldBe` Right 100000000
+  offerTotal (CurrencyAmount 100000000) (Just (offer 43 (ODFreeMonths 42))) `shouldBe` Left OIAmountUnsellable
+  offerTotal (CurrencyAmount 100000000) (Just (offer 2 (ODDiscount 50))) `shouldBe` Left OIAmountUnsellable
+  offerTotal (CurrencyAmount 100000000) Nothing
+    `shouldBe` Right (1, CurrencyAmount 100000000, CurrencyAmount 100000000)
+
+mkPrice :: T.Text -> BadgeType -> Word32 -> BadgeItemStatus -> BadgePrice
+mkPrice priceIdText priceBadgeType monthPriceAmount priceStatus =
+  BadgePrice
+    { priceId = BadgePriceId priceIdText,
+      badgeType = priceBadgeType,
+      monthPrice = CurrencyAmount monthPriceAmount,
+      currency = "usd",
+      status = priceStatus,
+      createdAt = epoch
+    }
+
+mkOffer :: T.Text -> Maybe T.Text -> Word8 -> OfferDiscount -> BadgeItemStatus -> BadgeOffer
+mkOffer offerIdText offerPriceIdText offerMonths offerDiscount offerStatus =
+  BadgeOffer
+    { offerId = BadgeOfferId offerIdText,
+      priceId = BadgePriceId <$> offerPriceIdText,
+      months = offerMonths,
+      discount = offerDiscount,
+      status = offerStatus,
+      createdAt = epoch
+    }
+
+testPriceOfferUnknownPrice :: IO ()
+testPriceOfferUnknownPrice =
+  priceOffer [] [] (BadgePriceId "missing") Nothing `shouldBe` Left CRUnknownPrice
+
+testPriceOfferUnsoldBadgeType :: IO ()
+testPriceOfferUnsoldBadgeType =
+  priceOffer [mkPrice "p1" BTInvestor 1000 BISActive] [] (BadgePriceId "p1") Nothing
+    `shouldBe` Left (CRUnsoldBadgeType BTInvestor)
+
+testPriceOfferDisabledPrice :: IO ()
+testPriceOfferDisabledPrice =
+  priceOffer [mkPrice "p1" BTSupporter 700 BISDisabled] [] (BadgePriceId "p1") Nothing
+    `shouldBe` Left CRDisabledPrice
+
+testPriceOfferUnknownOffer :: IO ()
+testPriceOfferUnknownOffer =
+  priceOffer [mkPrice "p1" BTSupporter 700 BISActive] [] (BadgePriceId "p1") (Just (BadgeOfferId "missing"))
+    `shouldBe` Left CRUnknownOffer
+
+testPriceOfferDisabledOffer :: IO ()
+testPriceOfferDisabledOffer =
+  priceOffer
+    [mkPrice "p1" BTSupporter 700 BISActive]
+    [mkOffer "o1" (Just "p1") 3 (ODFreeMonths 1) BISDisabled]
+    (BadgePriceId "p1")
+    (Just (BadgeOfferId "o1"))
+    `shouldBe` Left CRDisabledOffer
+
+testPriceOfferMismatchedPrice :: IO ()
+testPriceOfferMismatchedPrice =
+  priceOffer
+    [mkPrice "p1" BTSupporter 700 BISActive, mkPrice "p2" BTSupporter 700 BISActive]
+    [mkOffer "o1" (Just "p2") 3 (ODFreeMonths 1) BISActive]
+    (BadgePriceId "p1")
+    (Just (BadgeOfferId "o1"))
+    `shouldBe` Left CROfferNotForPrice
+
+testPriceOfferUnpriced :: IO ()
+testPriceOfferUnpriced =
+  priceOffer
+    [mkPrice "p1" BTSupporter 700 BISActive]
+    [mkOffer "o1" (Just "p1") 0 (ODDiscount 10) BISActive]
+    (BadgePriceId "p1")
+    (Just (BadgeOfferId "o1"))
+    `shouldBe` Left (CRUnpriced OIZeroMonths)
+
+testPriceOfferOrderUnsoldBeforeDisabled :: IO ()
+testPriceOfferOrderUnsoldBeforeDisabled =
+  priceOffer [mkPrice "p1" BTInvestor 1000 BISDisabled] [] (BadgePriceId "p1") Nothing
+    `shouldBe` Left (CRUnsoldBadgeType BTInvestor)
+
+testPriceOfferDeprecatedPricePriced :: IO ()
+testPriceOfferDeprecatedPricePriced =
+  priceOffer [mkPrice "p1" BTSupporter 700 BISDeprecated] [] (BadgePriceId "p1") Nothing
+    `shouldBe` Right PricedOffer {poBadgeType = BTSupporter, poMonths = 1, poPrice = CurrencyAmount 700, poAmount = CurrencyAmount 700, poCurrency = "usd"}
+
+testPriceOfferDeprecatedOfferPriced :: IO ()
+testPriceOfferDeprecatedOfferPriced =
+  priceOffer
+    [mkPrice "p1" BTSupporter 700 BISActive]
+    [mkOffer "o1" (Just "p1") 3 (ODFreeMonths 1) BISDeprecated]
+    (BadgePriceId "p1")
+    (Just (BadgeOfferId "o1"))
+    `shouldBe` Right PricedOffer {poBadgeType = BTSupporter, poMonths = 3, poPrice = CurrencyAmount 2100, poAmount = CurrencyAmount 1400, poCurrency = "usd"}
+
+testPriceOfferGrossFreeMonths :: IO ()
+testPriceOfferGrossFreeMonths =
+  priceOffer
+    [mkPrice "p1" BTLegend 7000 BISActive]
+    [mkOffer "o1" (Just "p1") 3 (ODFreeMonths 1) BISActive]
+    (BadgePriceId "p1")
+    (Just (BadgeOfferId "o1"))
+    `shouldBe` Right PricedOffer {poBadgeType = BTLegend, poMonths = 3, poPrice = CurrencyAmount 21000, poAmount = CurrencyAmount 14000, poCurrency = "usd"}
+
+testPriceOfferGrossDiscount :: IO ()
+testPriceOfferGrossDiscount =
+  priceOffer
+    [mkPrice "p1" BTLegend 7000 BISActive]
+    [mkOffer "o1" (Just "p1") 12 (ODDiscount 50) BISActive]
+    (BadgePriceId "p1")
+    (Just (BadgeOfferId "o1"))
+    `shouldBe` Right PricedOffer {poBadgeType = BTLegend, poMonths = 12, poPrice = CurrencyAmount 84000, poAmount = CurrencyAmount 42000, poCurrency = "usd"}
+
+testPriceOfferAnyPrice :: IO ()
+testPriceOfferAnyPrice = do
+  let prices = [mkPrice "p1" BTSupporter 700 BISActive, mkPrice "p2" BTSupporter 700 BISActive]
+      offers = [mkOffer "o1" Nothing 3 (ODFreeMonths 1) BISActive]
+      expected = Right PricedOffer {poBadgeType = BTSupporter, poMonths = 3, poPrice = CurrencyAmount 2100, poAmount = CurrencyAmount 1400, poCurrency = "usd"}
+  priceOffer prices offers (BadgePriceId "p1") (Just (BadgeOfferId "o1")) `shouldBe` expected
+  priceOffer prices offers (BadgePriceId "p2") (Just (BadgeOfferId "o1")) `shouldBe` expected
+
+testNoDriftFromWeb :: IO ()
+testNoDriftFromWeb = do
+  src <- T.readFile "apps/simplex-badge-service/web/src/catalog.ts"
+  case parseCatalogSource src of
+    Nothing -> expectationFailure "could not parse CATALOG out of web/src/catalog.ts -- its shape has changed"
+    Just (webPrices, webOffers) -> do
+      when (null webPrices || null webOffers) $
+        expectationFailure "parsed zero prices or offers out of web/src/catalog.ts -- its shape has changed"
+      mapM_ checkPrice webPrices
+      mapM_ (checkOffer webPrices) webOffers
+  where
+    literalTotals :: Map.Map T.Text (Word32, Word32, Word32)
+    literalTotals = Map.fromList [("supporter", (700, 1400, 4200)), ("legend", (7000, 14000, 42000))]
+    checkPrice :: WebPrice -> IO ()
+    checkPrice WebPrice {wpPriceId, wpBadgeType, wpMonthPrice} =
+      case Map.lookup wpBadgeType literalTotals of
+        Nothing -> expectationFailure ("no literal total for badge type " <> T.unpack wpBadgeType <> " (price " <> T.unpack wpPriceId <> ")")
+        Just (base, _, _) ->
+          offerTotal (CurrencyAmount wpMonthPrice) Nothing
+            `shouldBe` Right (1, CurrencyAmount wpMonthPrice, CurrencyAmount base)
+    checkOffer :: [WebPrice] -> WebOffer -> IO ()
+    checkOffer webPrices WebOffer {woPriceId, woMonths, woDiscount} =
+      case find (\WebPrice {wpPriceId} -> wpPriceId == woPriceId) webPrices of
+        Nothing -> expectationFailure ("offer names price " <> T.unpack woPriceId <> ", which is not in the catalog")
+        Just WebPrice {wpBadgeType, wpMonthPrice} -> case Map.lookup wpBadgeType literalTotals of
+          Nothing -> expectationFailure ("no literal total for badge type " <> T.unpack wpBadgeType)
+          Just (_, threeMonths, twelveMonths) -> do
+            expectedAmount <- case woMonths of
+              3 -> pure threeMonths
+              12 -> pure twelveMonths
+              n -> expectationFailure ("no literal total for a " <> show n <> "-month offer") >> pure 0
+            offerTotal (CurrencyAmount wpMonthPrice) (Just (offer woMonths woDiscount))
+              `shouldBe` Right (woMonths, CurrencyAmount (wpMonthPrice * fromIntegral woMonths), CurrencyAmount expectedAmount)
+
+data WebPrice = WebPrice {wpPriceId :: T.Text, wpBadgeType :: T.Text, wpMonthPrice :: Word32, wpCurrency :: T.Text}
+  deriving (Eq, Ord, Show)
+
+data WebOffer = WebOffer {woOfferId :: T.Text, woPriceId :: T.Text, woMonths :: Word8, woDiscount :: OfferDiscount}
+  deriving (Eq, Show)
+
+parseCatalogSource :: T.Text -> Maybe ([WebPrice], [WebOffer])
+parseCatalogSource src = do
+  pricesBlock <- betweenMarkers "prices: [" "]" src
+  offersBlock <- betweenMarkers "offers: [" "]" src
+  prices <- mapM parseWebPrice (topLevelObjects pricesBlock)
+  offers <- mapM parseWebOffer (topLevelObjects offersBlock)
+  pure (prices, offers)
+
+parseWebPrice :: T.Text -> Maybe WebPrice
+parseWebPrice obj =
+  WebPrice
+    <$> fieldStr "priceId" obj
+    <*> fieldStr "badgeType" obj
+    <*> (fieldNum "monthPrice" obj :: Maybe Word32)
+    <*> fieldStr "currency" obj
+
+parseWebOffer :: T.Text -> Maybe WebOffer
+parseWebOffer obj = do
+  wOfferId <- fieldStr "offerId" obj
+  wPriceId <- fieldStr "priceId" obj
+  wMonths <- (fieldNum "months" obj :: Maybe Word8)
+  discObj <- betweenMarkers "discount: {" "}" obj
+  discType <- fieldStr "type" discObj
+  wDiscount <- case discType of
+    "freeMonths" -> ODFreeMonths <$> (fieldNum "freeMonths" discObj :: Maybe Word8)
+    "discount" -> ODDiscount <$> (fieldNum "discount" discObj :: Maybe Word8)
+    _ -> Nothing
+  pure WebOffer {woOfferId = wOfferId, woPriceId = wPriceId, woMonths = wMonths, woDiscount = wDiscount}
+
+topLevelObjects :: T.Text -> [T.Text]
+topLevelObjects = go (0 :: Int) "" . T.unpack
+  where
+    go :: Int -> String -> String -> [T.Text]
+    go _ _ [] = []
+    go 0 _ (c : cs)
+      | c == '{' = go 1 [c] cs
+      | otherwise = go 0 "" cs
+    go depth buf (c : cs)
+      | c == '{' = go (depth + 1) (c : buf) cs
+      | c == '}' && depth == 1 = T.pack (reverse (c : buf)) : go 0 "" cs
+      | c == '}' = go (depth - 1) (c : buf) cs
+      | otherwise = go depth (c : buf) cs
+
+betweenMarkers :: T.Text -> T.Text -> T.Text -> Maybe T.Text
+betweenMarkers start end t = do
+  let (_, afterStart0) = T.breakOn start t
+  afterStart <- if T.null afterStart0 then Nothing else Just (T.drop (T.length start) afterStart0)
+  let (block, endPart) = T.breakOn end afterStart
+  if T.null endPart then Nothing else Just block
+
+fieldStr :: T.Text -> T.Text -> Maybe T.Text
+fieldStr key obj = do
+  let marker = key <> ": \""
+      (_, afterMarker0) = T.breakOn marker obj
+  afterMarker <- if T.null afterMarker0 then Nothing else Just (T.drop (T.length marker) afterMarker0)
+  let (val, rest) = T.breakOn "\"" afterMarker
+  if T.null rest then Nothing else Just val
+
+fieldNum :: Integral a => T.Text -> T.Text -> Maybe a
+fieldNum key obj = do
+  let marker = key <> ": "
+      (_, afterMarker0) = T.breakOn marker obj
+  afterMarker <- if T.null afterMarker0 then Nothing else Just (T.drop (T.length marker) afterMarker0)
+  case decimal afterMarker of
+    Right (n, _) -> Just n
+    Left _ -> Nothing

tests/Bots/BadgeService/ConfigTests.hs

@@ -0,0 +1,369 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bots.BadgeService.ConfigTests where
+
+import BadgeService.Config
+import qualified Data.ByteString.Char8 as B
+import Data.Either (isLeft)
+import Data.Ini (readIniFile)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Simplex.Messaging.Encoding.String (strDecode)
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath ((</>))
+import Test.Hspec
+import UnliftIO.Temporary (withTempDirectory)
+
+badgeConfigTests :: Spec
+badgeConfigTests = describe "badge service config" $ do
+  it "applies every documented default" testDefaults
+  it "falls back to the default host when the value is blank" testBlankHost
+  it "disables a provider whose section is absent" testAbsentSection
+  it "refuses an incomplete provider section, naming the key" testIncompleteSection
+  it "refuses a missing static_dir" testAbsentStaticDir
+  it "reads serve_webapp off and a webapp_export_dir" testWebappSplitDeployment
+  it "applies every documented stripe default" testStripeDefaults
+  it "disables stripe when the section is absent" testStripeAbsent
+  it "refuses an incomplete stripe section, naming the key" testStripeIncomplete
+  it "bounds stripe session_minutes to 1-1440" testStripeSessionMinutesRange
+  it "accepts HighSpeed" (testSpeedPolicyAccepted "HighSpeed" HighSpeed)
+  it "accepts LowMediumSpeed" (testSpeedPolicyAccepted "LowMediumSpeed" LowMediumSpeed)
+  it "accepts LowSpeed" (testSpeedPolicyAccepted "LowSpeed" LowSpeed)
+  it "refuses a numeric speed policy" testSpeedPolicyName
+  it "accepts a poll cadence and refuses a zero or negative one" testPollCadence
+  it "accepts an expiry window and refuses a zero or negative one" testExpiryMinutes
+  it "accepts a payment tolerance and refuses one that settles for a satoshi" testPaymentTolerance
+  it "refuses a host that would send the api key in the clear" testHostMustBeHttps
+  it "names a setting nothing reads, in every section it parses" testUnknownKeysAreNamed
+  it "refuses a file one malformed line would silently truncate" testMalformedLineRefused
+  it "accepts a comment or blank line after the last setting" testTrailingCommentIsAccepted
+  it "reports a missing file rather than throwing" testMissingFileIsReported
+  it "has no issuer key when the section is absent" testIssuerAbsent
+  it "reads the index and the private key it signs with" testIssuerKey
+  it "refuses a section without an index" testIssuerIndexMissing
+  it "refuses a section without a private key" testIssuerSecretMissing
+  it "refuses an index that is not a positive whole number" testIssuerIndexInvalid
+  it "refuses a private key that is not a valid issuer secret" testIssuerBadSecret
+  it "names the old default and key_<n> settings, then refuses the boot" testIssuerOldFormat
+  it "leaves chat redemption off when the dev section is absent" testDevRedeemAbsent
+  it "reads chat_redeem = on" testDevRedeemOn
+  it "reads chat_redeem = off" testDevRedeemOff
+  it "refuses a chat_redeem that is not on or off" testDevRedeemNotBoolean
+
+fullIni :: T.Text
+fullIni =
+  T.unlines
+    [ "[listener]",
+      "static_dir = /srv/badges",
+      "[btcpay]",
+      "host = https://btcpay.example.org",
+      "api_key = token-value",
+      "store_id = store-value",
+      "webhook_secret = secret-value"
+    ]
+
+withIni :: T.Text -> (FilePath -> IO a) -> IO a
+withIni t f = do
+  createDirectoryIfMissing True "tests/tmp"
+  withTempDirectory "tests/tmp" "badge-ini" $ \d -> do
+    let p = d </> "badge_service.ini"
+    T.writeFile p t
+    f p
+
+testDefaults :: IO ()
+testDefaults = withIni fullIni $ \p -> do
+  Right cfg <- readServiceConfig p
+  let ListenerConfig {lHost, lPort, lStaticDir, lServeWebapp, lWebappExportDir, lTrustForwardedFor} = listener cfg
+  lHost `shouldBe` "127.0.0.1"
+  lPort `shouldBe` 8080
+  lStaticDir `shouldBe` "/srv/badges"
+  lServeWebapp `shouldBe` True
+  lWebappExportDir `shouldBe` Nothing
+  lTrustForwardedFor `shouldBe` False
+  let PollConfig {pWaitingSeconds, pIdleSeconds} = poll cfg
+  pWaitingSeconds `shouldBe` 3
+  pIdleSeconds `shouldBe` 60
+  case btcpay cfg of
+    Nothing -> expectationFailure "the btcpay section was present"
+    Just BTCPayConfig {bExpiryMinutes, bSpeedPolicy, bPaymentTolerance} -> do
+      bExpiryMinutes `shouldBe` 60
+      bSpeedPolicy `shouldBe` MediumSpeed
+      bPaymentTolerance `shouldBe` 0.5
+
+testBlankHost :: IO ()
+testBlankHost =
+  withIni (T.replace "[listener]\n" "[listener]\nhost = \n" fullIni) $ \p -> do
+    Right cfg <- readServiceConfig p
+    lHost (listener cfg) `shouldBe` "127.0.0.1"
+
+testAbsentSection :: IO ()
+testAbsentSection = withIni (T.unlines (takeWhile (/= "[btcpay]") (T.lines fullIni))) $ \p -> do
+  Right cfg <- readServiceConfig p
+  btcpay cfg `shouldBe` Nothing
+
+testIncompleteSection :: IO ()
+testIncompleteSection =
+  withIni (T.replace "webhook_secret = secret-value" "" fullIni) $ \p -> do
+    r <- readServiceConfig p
+    case r of
+      Left e -> e `shouldContain` "webhook_secret"
+      Right _ -> expectationFailure "an incomplete btcpay section must fail at boot"
+
+testAbsentStaticDir :: IO ()
+testAbsentStaticDir =
+  withIni (T.replace "static_dir = /srv/badges\n" "" fullIni) $ \p ->
+    readServiceConfig p >>= (`shouldSatisfy` isLeft)
+
+testWebappSplitDeployment :: IO ()
+testWebappSplitDeployment =
+  withIni (T.replace "static_dir = /srv/badges\n" "static_dir = /srv/badges\nserve_webapp = off\nwebapp_export_dir = /srv/web\n" fullIni) $ \p -> do
+    Right cfg <- readServiceConfig p
+    let ListenerConfig {lServeWebapp, lWebappExportDir} = listener cfg
+    lServeWebapp `shouldBe` False
+    lWebappExportDir `shouldBe` Just "/srv/web"
+
+fullStripeIni :: T.Text
+fullStripeIni =
+  fullIni
+    <> T.unlines
+      [ "[stripe]",
+        "secret_key = rk_test_x",
+        "publishable_key = pk_test_x",
+        "webhook_secret = whsec_x"
+      ]
+
+testStripeDefaults :: IO ()
+testStripeDefaults = withIni fullStripeIni $ \p -> do
+  Right cfg <- readServiceConfig p
+  case stripe cfg of
+    Nothing -> expectationFailure "the stripe section was present"
+    Just StripeConfig {sSessionMinutes, sHost} -> do
+      sSessionMinutes `shouldBe` 60
+      sHost `shouldBe` "https://api.stripe.com"
+
+testStripeAbsent :: IO ()
+testStripeAbsent = withIni fullIni $ \p -> do
+  Right cfg <- readServiceConfig p
+  stripe cfg `shouldBe` Nothing
+
+testStripeIncomplete :: IO ()
+testStripeIncomplete =
+  withIni (T.replace "webhook_secret = whsec_x" "" fullStripeIni) $ \p -> do
+    r <- readServiceConfig p
+    case r of
+      Left e -> e `shouldContain` "webhook_secret"
+      Right _ -> expectationFailure "an incomplete stripe section must fail at boot"
+
+testStripeSessionMinutesRange :: IO ()
+testStripeSessionMinutesRange = do
+  refuses "session_minutes = -5\n"
+  refuses "session_minutes = 0\n"
+  refuses "session_minutes = 1441\n"
+  refuses "session_minutes = 2000\n"
+  accepts "session_minutes = 1\n" 1
+  accepts "session_minutes = 1440\n" 1440
+  where
+    refuses value =
+      withIni (fullStripeIni <> value) $ \p -> do
+        r <- readServiceConfig p
+        case r of
+          Left e -> e `shouldContain` "session_minutes"
+          Right _ -> expectationFailure ("stripe." <> T.unpack (T.strip value) <> " is outside 1-1440 and must fail")
+    accepts value expected =
+      withIni (fullStripeIni <> value) $ \p -> do
+        r <- readServiceConfig p
+        case r of
+          Right cfg -> fmap sSessionMinutes (stripe cfg) `shouldBe` Just expected
+          Left e -> expectationFailure ("stripe." <> T.unpack (T.strip value) <> " is inside 1-1440 and must parse, but: " <> e)
+
+testSpeedPolicyAccepted :: T.Text -> SpeedPolicy -> IO ()
+testSpeedPolicyAccepted name expected =
+  withIni (fullIni <> "speed_policy = " <> name <> "\n") $ \p -> do
+    Right cfg <- readServiceConfig p
+    case btcpay cfg of
+      Nothing -> expectationFailure "the btcpay section was present"
+      Just BTCPayConfig {bSpeedPolicy} -> bSpeedPolicy `shouldBe` expected
+
+testSpeedPolicyName :: IO ()
+testSpeedPolicyName =
+  withIni (fullIni <> "speed_policy = 2\n") $ \p ->
+    readServiceConfig p >>= (`shouldSatisfy` isLeft)
+
+testPollCadence :: IO ()
+testPollCadence = do
+  withPoll "waiting_seconds = 1\nidle_seconds = 5\n" $ \r -> case r of
+    Right cfg -> poll cfg `shouldBe` PollConfig {pWaitingSeconds = 1, pIdleSeconds = 5}
+    Left e -> expectationFailure ("a one-second cadence is legal: " <> e)
+  mapM_
+    (\v -> withPoll v (`shouldSatisfy` isLeft))
+    [ "waiting_seconds = 0\n",
+      "idle_seconds = 0\n",
+      "waiting_seconds = -3\n",
+      "idle_seconds = -1\n",
+      -- 2^64 + 4 would wrap to a legal 4 seconds on a machine-width read.
+      "idle_seconds = 18446744073709551620\n"
+    ]
+  where
+    withPoll keys act = withIni (fullIni <> "[poll]\n" <> keys) $ \p -> readServiceConfig p >>= act
+
+testExpiryMinutes :: IO ()
+testExpiryMinutes = do
+  withExpiry "expiry_minutes = 1\n" $ \r -> case r of
+    Right cfg -> (bExpiryMinutes <$> btcpay cfg) `shouldBe` Just 1
+    Left e -> expectationFailure ("a one-minute window is legal: " <> e)
+  mapM_
+    ( \v ->
+        withExpiry v $ \r -> case r of
+          Left e -> e `shouldContain` "expiry_minutes"
+          Right _ -> expectationFailure ("btcpay." <> T.unpack (T.strip v) <> " must not boot")
+    )
+    ["expiry_minutes = 0\n", "expiry_minutes = -60\n"]
+  where
+    withExpiry key act = withIni (fullIni <> key) $ \p -> readServiceConfig p >>= act
+
+testUnknownKeysAreNamed :: IO ()
+testUnknownKeysAreNamed =
+  withIni (fullIni <> "speed_polcy = LowSpeed\ntrust_forwaded_for = on\n[poll]\nwaiting_secnds = 5\n[dev]\nchat_redem = on\n") $ \p -> do
+    Right ini <- readIniFile p
+    unknownKeys ini `shouldMatchList` ["btcpay.speed_polcy", "btcpay.trust_forwaded_for", "poll.waiting_secnds", "dev.chat_redem"]
+    withIni (T.replace "[btcpay]" "[btcpai]" fullIni) $ \wrongSection -> do
+      Right sectionIni <- readIniFile wrongSection
+      unknownKeys sectionIni `shouldContain` ["[btcpai]"]
+    withIni ("chat_redeem = on\n" <> fullIni) $ \stray -> do
+      Right strayIni <- readIniFile stray
+      unknownKeys strayIni `shouldContain` ["chat_redeem, written above the first section header"]
+    withIni fullIni $ \clean -> do
+      Right cleanIni <- readIniFile clean
+      unknownKeys cleanIni `shouldBe` []
+
+-- | The ini parser stops at the first line it cannot read and keeps what it has, so without this a
+-- missing `=` in [listener] would silently drop every section below it, and the provider with it.
+testMalformedLineRefused :: IO ()
+testMalformedLineRefused =
+  withIni (T.replace "static_dir = /srv/badges" "static_dir = /srv/badges\ntrust_forwarded_for on" fullIni) $ \p ->
+    readServiceConfig p >>= \r -> case r of
+      Left e -> e `shouldContain` "malformed"
+      Right cfg -> expectationFailure ("a truncated file must not boot, and this one kept " <> show (btcpay cfg))
+
+-- | The strictness that refuses a truncated file must not refuse a trailing comment or blank line,
+-- since `iniParser` stops before one and commenting out the last section is enough to produce it.
+testTrailingCommentIsAccepted :: IO ()
+testTrailingCommentIsAccepted = do
+  accepts (fullIni <> "; rotated the api key on 2026-09-01\n")
+  accepts (fullIni <> "\n\n")
+  accepts (fullIni <> "[dev]\n; chat_redeem = on\n")
+  accepts (fullIni <> "# a hash comment, with no newline after it")
+  where
+    accepts t =
+      withIni t $ \p ->
+        readServiceConfig p >>= \r -> case r of
+          Right _ -> pure ()
+          Left e -> expectationFailure ("a legal file was refused: " <> e)
+
+-- | The caller prints the reason under the path it was asked for, so naming the file here as well
+-- would put it in the line twice.
+testMissingFileIsReported :: IO ()
+testMissingFileIsReported =
+  readServiceConfig "tests/tmp/no-such-badge_service.ini" >>= \r -> case r of
+    Left e -> do
+      e `shouldContain` "does not exist"
+      e `shouldNotContain` "no-such-badge_service.ini"
+    Right _ -> expectationFailure "a file that is not there cannot be read"
+
+testPaymentTolerance :: IO ()
+testPaymentTolerance = do
+  withTolerance "payment_tolerance = 2.5\n" $ \r -> case r of
+    Right cfg -> (bPaymentTolerance <$> btcpay cfg) `shouldBe` Just 2.5
+    Left e -> expectationFailure ("two and a half percent is legal: " <> e)
+  mapM_
+    ( \v ->
+        withTolerance v $ \r -> case r of
+          Left e -> e `shouldContain` "payment_tolerance"
+          Right _ -> expectationFailure ("btcpay." <> T.unpack (T.strip v) <> " must not boot")
+    )
+    ["payment_tolerance = 100\n", "payment_tolerance = -1\n", "payment_tolerance = half\n"]
+  where
+    withTolerance key act = withIni (fullIni <> key) $ \p -> readServiceConfig p >>= act
+
+testHostMustBeHttps :: IO ()
+testHostMustBeHttps =
+  withIni (T.replace "https://" "http://" fullIni) $ \p ->
+    readServiceConfig p >>= \r -> case r of
+      Left e -> e `shouldContain` "https"
+      Right _ -> expectationFailure "an http host carries the api key in the clear"
+
+-- A real 32-byte base64url secret, as `simplex-chat badge keygen` prints it.
+issuerSecret :: T.Text
+issuerSecret = "Ea5wG-J2mQjPBu9YfSJRKPnGnzoIdEE-8VaMh_wY2Bg="
+
+withIssuer :: [T.Text] -> (FilePath -> IO a) -> IO a
+withIssuer ls = withIni (fullIni <> T.unlines ("[issuer]" : ls))
+
+issuerRefusal :: [T.Text] -> IO String
+issuerRefusal ls =
+  withIssuer ls readServiceConfig >>= \r -> case r of
+    Left e -> pure e
+    Right cfg -> expectationFailure ("[issuer] " <> show ls <> " must not boot, it read " <> show (issuer cfg)) >> pure ""
+
+testIssuerAbsent :: IO ()
+testIssuerAbsent = withIni fullIni $ \p -> do
+  Right cfg <- readServiceConfig p
+  issuer cfg `shouldBe` Nothing
+
+testIssuerKey :: IO ()
+testIssuerKey =
+  withIssuer ["index = 3", "private_key = " <> issuerSecret] $ \p -> do
+    Right cfg <- readServiceConfig p
+    Right sk <- pure (strDecode (B.pack (T.unpack issuerSecret)))
+    issuer cfg `shouldBe` Just BadgeIssuerKey {keyIdx = 3, secretKey = sk}
+
+testIssuerIndexMissing :: IO ()
+testIssuerIndexMissing =
+  issuerRefusal ["private_key = " <> issuerSecret] `shouldReturn` "issuer.index is required"
+
+testIssuerSecretMissing :: IO ()
+testIssuerSecretMissing =
+  issuerRefusal ["index = 1"] `shouldReturn` "issuer.private_key is required"
+
+testIssuerIndexInvalid :: IO ()
+testIssuerIndexInvalid =
+  mapM_
+    (\v -> issuerRefusal ["index = " <> v, "private_key = " <> issuerSecret] `shouldReturn` "issuer.index must be a positive whole number")
+    ["0", "-1", "one", "1.5", "key_1", "18446744073709551617"]
+
+testIssuerBadSecret :: IO ()
+testIssuerBadSecret =
+  issuerRefusal ["index = 1", "private_key = not-a-key"]
+    `shouldReturn` "issuer.private_key is not a valid issuer secret; use the value from `simplex-chat badge keygen`"
+
+testIssuerOldFormat :: IO ()
+testIssuerOldFormat = do
+  let old = ["default = key_1", "key_1 = " <> issuerSecret]
+  withIssuer old $ \p -> do
+    Right ini <- readIniFile p
+    unknownKeys ini `shouldMatchList` ["issuer.default", "issuer.key_1"]
+  issuerRefusal old `shouldReturn` "issuer.index is required"
+
+testDevRedeemAbsent :: IO ()
+testDevRedeemAbsent = withIni fullIni $ \p -> do
+  Right cfg <- readServiceConfig p
+  devChatRedeem cfg `shouldBe` False
+
+testDevRedeemOn :: IO ()
+testDevRedeemOn = withDev "chat_redeem = on\n" $ \r -> case r of
+  Right cfg -> devChatRedeem cfg `shouldBe` True
+  Left e -> expectationFailure ("[dev] chat_redeem = on is legal: " <> e)
+
+testDevRedeemOff :: IO ()
+testDevRedeemOff = withDev "chat_redeem = off\n" $ \r -> case r of
+  Right cfg -> devChatRedeem cfg `shouldBe` False
+  Left e -> expectationFailure ("[dev] chat_redeem = off is legal: " <> e)
+
+testDevRedeemNotBoolean :: IO ()
+testDevRedeemNotBoolean = withDev "chat_redeem = true\n" $ \r -> case r of
+  Left e -> e `shouldContain` "chat_redeem"
+  Right _ -> expectationFailure "only on and off are accepted, so a typo cannot silently disarm the gate"
+
+withDev :: T.Text -> (Either String ServiceConfig -> IO a) -> IO a
+withDev keys act = withIni (fullIni <> "[dev]\n" <> keys) $ \p -> readServiceConfig p >>= act

tests/Bots/BadgeService/FakeBTCPay.hs

@@ -0,0 +1,527 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Bots.BadgeService.FakeBTCPay
+  ( FakeBTCPay (..),
+    FakeRequest (..),
+    withFakeBTCPay,
+    fakeApiKey,
+    fakeExpiryMinutes,
+    setInvoiceState,
+    failNextCalls,
+    failAfterCalls,
+    useListFixture,
+    usePaymentMethodsFixture,
+    ignoreListPaging,
+    answerOversize,
+    fakeRequests,
+    apiRequests,
+    fakeInvoiceIds,
+    fixtureResponse,
+    webhookEvent,
+    webhookSigHeader,
+    webhookHexSig,
+  )
+where
+
+import BadgeService.Config (BTCPayConfig (..), SpeedPolicy (..))
+import Control.Applicative ((<|>))
+import Control.Concurrent.STM
+import Control.Monad (join)
+import Crypto.Hash (Digest, SHA256)
+import Crypto.MAC.HMAC (HMAC, hmac, hmacGetDigest)
+import qualified Data.Aeson as J
+import Data.Aeson.Key (Key)
+import qualified Data.Aeson.Key as K
+import qualified Data.Aeson.KeyMap as KM
+import Data.Aeson.Types (Pair)
+import Data.ByteArray.Encoding (Base (Base16), convertToBase)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy as LB
+import Data.List (isPrefixOf, nub)
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
+import Data.Scientific (Scientific)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+-- http-client is imported qualified because its Request has requestHeaders, requestBody and
+-- queryString just as WAI's does.
+import Network.HTTP.Client (Manager)
+import qualified Network.HTTP.Client as HTTP
+import Network.HTTP.Types
+  ( Query,
+    Status,
+    badRequest400,
+    hAuthorization,
+    hContentType,
+    methodGet,
+    methodPost,
+    mkStatus,
+    notFound404,
+    ok200,
+    statusCode,
+    statusMessage,
+    unauthorized401,
+  )
+import Network.HTTP.Types.Header (Header)
+import Network.Wai (Application, Response, pathInfo, queryString, requestHeaders, requestMethod, responseLBS, strictRequestBody)
+import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Messaging.Util (tshow)
+import System.FilePath ((</>))
+import Text.Read (readMaybe)
+
+fixtureDir :: FilePath
+fixtureDir = "apps" </> "simplex-badge-service" </> "test-fixtures" </> "btcpay"
+
+fakeApiKey :: Text
+fakeApiKey = "7f3c1d9a2e5b48c6905ad1e2f3b4c5d6e7f80912"
+
+fakeStoreId :: Text
+fakeStoreId = "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT"
+
+fakeWebhookSecret :: Text
+fakeWebhookSecret = "3d8f5c6a2b1e4f7089abcdef01234567"
+
+fakeExpiryMinutes :: Int
+fakeExpiryMinutes = 60
+
+data FakeRequest = FakeRequest
+  { frMethod :: ByteString,
+    frPath :: [Text],
+    frQuery :: Query,
+    frHeaders :: [Header],
+    frBody :: LB.ByteString
+  }
+  deriving (Eq, Show)
+
+data InvoiceState = InvoiceState
+  { isMethodId :: Text,
+    isStatus :: Text,
+    isAdditionalStatus :: Text,
+    isPaid :: Maybe Text,
+    isDue :: Maybe Text
+  }
+  deriving (Eq, Show)
+
+data FailPlan = FailPlan {fpSkip :: Int, fpCalls :: Int, fpStatus :: Int}
+  deriving (Eq, Show)
+
+data FakeState = FakeState
+  { fsInvoices :: M.Map Text InvoiceState,
+    fsNextId :: Int,
+    fsFail :: FailPlan,
+    fsList :: Text,
+    fsMethods :: Maybe Text,
+    fsIgnorePaging :: Bool,
+    fsOversize :: Bool,
+    fsRequests :: [FakeRequest]
+  }
+
+initialState :: FakeState
+initialState =
+  FakeState
+    { fsInvoices = M.empty,
+      fsNextId = 1,
+      fsFail = FailPlan {fpSkip = 0, fpCalls = 0, fpStatus = 0},
+      fsList = "invoice-list",
+      fsMethods = Nothing,
+      fsIgnorePaging = False,
+      fsOversize = False,
+      fsRequests = []
+    }
+
+data FakeBTCPay = FakeBTCPay
+  { fbConfig :: BTCPayConfig,
+    fbBaseUrl :: String,
+    fbManager :: Manager,
+    fbState :: TVar FakeState
+  }
+
+-- | Warp chooses the port, because a fixed one could collide with a server left over from an
+-- earlier run and the test would pass against that instead.
+withFakeBTCPay :: (FakeBTCPay -> IO a) -> IO a
+withFakeBTCPay action = do
+  fbState <- newTVarIO initialState
+  fbManager <- HTTP.newManager HTTP.defaultManagerSettings
+  Warp.testWithApplication (pure (fakeApp fbState)) $ \prt -> do
+    let fbBaseUrl = "http://127.0.0.1:" <> show prt
+    action FakeBTCPay {fbConfig = fakeConfig (T.pack fbBaseUrl), fbBaseUrl, fbManager, fbState}
+
+fakeConfig :: Text -> BTCPayConfig
+fakeConfig host =
+  BTCPayConfig
+    { bHost = host,
+      bApiKey = fakeApiKey,
+      bStoreId = fakeStoreId,
+      bWebhookSecret = fakeWebhookSecret,
+      bExpiryMinutes = fakeExpiryMinutes,
+      bSpeedPolicy = MediumSpeed,
+      bPaymentTolerance = 0.5
+    }
+
+-- | A BTCPay webhook delivery shaped as its documentation shows. Both suites sign this exact
+-- envelope, so what a valid signature covers cannot mean two different things.
+webhookEvent :: Text -> Text -> LB.ByteString
+webhookEvent eventType invoiceRef =
+  LB.fromStrict . TE.encodeUtf8 . T.unlines $
+    [ "{",
+      "  \"deliveryId\": \"vBYbSCVSMFXFqSuCZ2LEHt\",",
+      "  \"webhookId\": \"5GtRTUCYPbVAWJmYcgZ8wK\",",
+      "  \"originalDeliveryId\": \"vBYbSCVSMFXFqSuCZ2LEHt\",",
+      "  \"isRedelivery\": false,",
+      "  \"type\": \"" <> eventType <> "\",",
+      "  \"timestamp\": 1700000000,",
+      "  \"storeId\": \"" <> fakeStoreId <> "\",",
+      "  \"invoiceId\": \"" <> invoiceRef <> "\"",
+      "}"
+    ]
+
+-- | The header BTCPay sends is an HMAC-SHA256 over the bytes exactly as written above.
+webhookSigHeader :: Text -> LB.ByteString -> [Header]
+webhookSigHeader secret body = [("BTCPay-Sig", "sha256=" <> webhookHexSig secret body)]
+
+webhookHexSig :: Text -> LB.ByteString -> ByteString
+webhookHexSig secret body = convertToBase Base16 digest
+  where
+    digest :: Digest SHA256
+    digest = hmacGetDigest (hmac (TE.encodeUtf8 secret) (LB.toStrict body) :: HMAC SHA256)
+
+fixtureResponse :: Text -> IO J.Value
+fixtureResponse name = do
+  raw <- LB.readFile path
+  case J.eitherDecode raw of
+    Left e -> fail (path <> ": " <> e)
+    Right (J.Object o) -> case (KM.lookup "_fixture" o, KM.lookup "response" o) of
+      (Just (J.String _), Just v) -> pure v
+      _ -> fail (path <> ": a fixture is {\"_fixture\": <provenance>, \"response\": <body>}")
+    Right _ -> fail (path <> ": a fixture is a JSON object")
+  where
+    path = fixtureDir </> T.unpack name <> ".json"
+
+invoiceFixture :: Text -> Text
+invoiceFixture = \case
+  "Processing" -> "invoice-processing"
+  "Settled" -> "invoice-settled"
+  "Expired" -> "invoice-expired"
+  "Invalid" -> "invoice-invalid"
+  _ -> "invoice-new"
+
+methodsFixture :: Text -> Text
+methodsFixture methodId
+  | methodId == xmrMethod = "payment-methods-xmr"
+  | otherwise = "payment-methods-btc"
+
+-- The adapter's own ids are restated rather than imported, so a fake sharing the constant cannot
+-- agree with a wrong change to it.
+btcMethod, xmrMethod :: Text
+btcMethod = "BTC-CHAIN"
+xmrMethod = "XMR-CHAIN"
+
+patchInvoice :: Text -> InvoiceState -> J.Value -> J.Value
+patchInvoice invId InvoiceState {isStatus, isAdditionalStatus} =
+  setField "id" (J.String invId)
+    . setField "status" (J.String isStatus)
+    . setField "additionalStatus" (J.String isAdditionalStatus)
+
+patchMethods :: InvoiceState -> J.Value -> J.Value
+patchMethods InvoiceState {isPaid, isDue} = \case
+  J.Array vs -> J.Array (fmap one vs)
+  other -> other
+  where
+    one = \case
+      J.Object o ->
+        let paid = fromMaybe (fixturePaid o) isPaid
+            -- With nothing received the whole amount is owed. The fixtures were written for a
+            -- settled invoice, so without this a freshly created one would serve their `due` of
+            -- zero and the fake would report nothing left to send on an unpaid invoice.
+            due = if isZero paid then isDue <|> textField "amount" o else isDue
+            withPaid = KM.insert "paymentMethodPaid" (J.String paid) o
+            withDue = maybe withPaid (\d -> KM.insert "due" (J.String d) withPaid) due
+         in J.Object (if isZero paid then KM.insert "payments" (J.Array mempty) withDue else withDue)
+      v -> v
+    fixturePaid o = case KM.lookup "paymentMethodPaid" o of
+      Just (J.String t) -> t
+      _ -> "0"
+
+isZero :: Text -> Bool
+isZero t = (J.decodeStrict (TE.encodeUtf8 t) :: Maybe Scientific) == Just 0
+
+setField :: Key -> J.Value -> J.Value -> J.Value
+setField k v = \case
+  J.Object o -> J.Object (KM.insert k v o)
+  other -> other
+
+fakeApp :: TVar FakeState -> Application
+fakeApp stv req respond = do
+  body <- strictRequestBody req
+  case pathInfo req of
+    ["_state", invId] | isPost -> control body (setState invId)
+    ["_fail"] | isPost -> control body setFail
+    ["_fixtures"] | isPost -> control body setFixtures
+    ["_paging"] | isPost -> control body setPaging
+    ["_oversize"] | isPost -> control body setOversize
+    "api" : "v1" : "stores" : storeId : rest -> apiCall body storeId rest
+    _ -> refuse notFound404 "no such path on the fake btcpay"
+  where
+    verb = requestMethod req
+    isPost = verb == methodPost
+    isGet = verb == methodGet
+    refuse st message = respond (errorResponse st message)
+    ok = respond (jsonResponse ok200 (J.object ["ok" J..= True]))
+
+    control body act = case J.decode body of
+      Just (J.Object o) ->
+        act o >>= \case
+          Nothing -> ok
+          Just message -> refuse badRequest400 message
+      _ -> refuse badRequest400 "a control call takes a JSON object"
+
+    setState invId o = case unknownKeys stateKeys o of
+      Just message -> pure (Just message)
+      Nothing -> atomically $ do
+        st <- readTVar stv
+        case M.lookup invId (fsInvoices st) of
+          Nothing -> pure (Just ("no invoice " <> invId <> " was created here"))
+          Just inv -> do
+            let inv' =
+                  inv
+                    { isStatus = fromMaybe (isStatus inv) (textField "status" o),
+                      isAdditionalStatus = fromMaybe (isAdditionalStatus inv) (textField "additionalStatus" o),
+                      isPaid = maybe (isPaid inv) Just (textField "paymentMethodPaid" o),
+                      isDue = maybe (isDue inv) Just (textField "due" o)
+                    }
+            writeTVar stv st {fsInvoices = M.insert invId inv' (fsInvoices st)}
+            pure Nothing
+
+    setFail o = case unknownKeys ["calls", "status", "skip"] o of
+      Just message -> pure (Just message)
+      Nothing -> case (intField "calls" o, intField "status" o) of
+        (Just calls, Just code) -> do
+          let plan = FailPlan {fpSkip = fromMaybe 0 (intField "skip" o), fpCalls = calls, fpStatus = code}
+          atomically (modifyTVar' stv (\st -> st {fsFail = plan}))
+          pure Nothing
+        _ -> pure (Just "_fail takes {\"calls\": <n>, \"status\": <http status>, \"skip\": <n>}")
+
+    setFixtures o = case unknownKeys ["list", "paymentMethods"] o of
+      Just message -> pure (Just message)
+      Nothing -> case (named "list" "invoice-list" fsListOf, named "paymentMethods" "payment-methods" fsMethodsOf) of
+        (Left message, _) -> pure (Just message)
+        (_, Left message) -> pure (Just message)
+        (Right setL, Right setM)
+          | null (KM.keys o) -> pure (Just "_fixtures takes a `list` or a `paymentMethods` fixture name")
+          | otherwise -> do
+              atomically (modifyTVar' stv (setM . setL))
+              pure Nothing
+      where
+        named k prefix set = case textField k o of
+          Nothing -> Right id
+          Just name
+            | prefix `isPrefixOf` T.unpack name -> Right (set name)
+            | otherwise -> Left ("not a " <> K.toText k <> " fixture: " <> name)
+        fsListOf name st = st {fsList = name}
+        fsMethodsOf name st = st {fsMethods = Just name}
+
+    setOversize o = case unknownKeys ["on"] o of
+      Just message -> pure (Just message)
+      Nothing -> case KM.lookup "on" o of
+        Just (J.Bool on) -> do
+          atomically (modifyTVar' stv (\st -> st {fsOversize = on}))
+          pure Nothing
+        _ -> pure (Just "_oversize takes {\"on\": <bool>}")
+
+    setPaging o = case unknownKeys ["ignore"] o of
+      Just message -> pure (Just message)
+      Nothing -> case KM.lookup "ignore" o of
+        Just (J.Bool ignore) -> do
+          atomically (modifyTVar' stv (\st -> st {fsIgnorePaging = ignore}))
+          pure Nothing
+        _ -> pure (Just "_paging takes {\"ignore\": <bool>}")
+
+    apiCall body storeId rest = do
+      atomically $
+        modifyTVar' stv $ \st ->
+          st {fsRequests = FakeRequest verb (pathInfo req) (queryString req) (requestHeaders req) body : fsRequests st}
+      if storeId /= fakeStoreId
+        then refuse notFound404 ("no store " <> storeId <> " on the fake btcpay")
+        else case lookup hAuthorization (requestHeaders req) of
+          Just given | given == expectedAuth -> injectingFailure (greenfield body rest)
+          _ -> refuse unauthorized401 "Authorization must be `token <api-key>`"
+
+    expectedAuth = "token " <> TE.encodeUtf8 fakeApiKey
+
+    injectingFailure act = do
+      failing <- atomically $ do
+        st <- readTVar stv
+        case fsFail st of
+          plan@FailPlan {fpSkip} | fpSkip > 0 -> do
+            writeTVar stv st {fsFail = plan {fpSkip = fpSkip - 1}}
+            pure Nothing
+          plan@FailPlan {fpCalls, fpStatus} | fpCalls > 0 -> do
+            writeTVar stv st {fsFail = plan {fpCalls = fpCalls - 1}}
+            pure (Just fpStatus)
+          _ -> pure Nothing
+      case failing of
+        Just code -> refuse (mkStatus code "Injected Failure") "the fake was told to fail this call"
+        Nothing -> act
+
+    greenfield body = \case
+      ["payment-methods"] | isGet -> serve "store-payment-methods" id
+      ["invoices"] | isPost -> createInvoice body
+      ["invoices"] | isGet -> listInvoices
+      ["invoices", invId] | isGet ->
+        withInvoice invId $ \inv -> serve (invoiceFixture (isStatus inv)) (patchInvoice invId inv)
+      ["invoices", invId, "payment-methods"] | isGet ->
+        withInvoice invId $ \inv -> do
+          override <- fsMethods <$> readTVarIO stv
+          serve (fromMaybe (methodsFixture (isMethodId inv)) override) (patchMethods inv)
+      _ -> refuse notFound404 "no such greenfield path on the fake btcpay"
+
+    listInvoices = do
+      st <- readTVarIO stv
+      fixture <- fixtureResponse (fsList st)
+      case arrayEntries fixture of
+        Nothing -> respond (jsonResponse ok200 fixture)
+        Just fixed -> do
+          let invs = M.toAscList (fsInvoices st)
+          cache <- readFixtures (concatMap (fixtureNames (fsMethods st)) invs)
+          let entries = fixed <> map (listedInvoice cache (fsMethods st)) invs
+              page = if fsIgnorePaging st then entries else paged (queryString req) entries
+          respond (jsonResponse ok200 (J.toJSON page))
+
+    readFixtures names = M.fromList <$> mapM (\n -> (,) n <$> fixtureResponse n) (nub names)
+
+    fixtureNames override (_, inv) = [invoiceFixture (isStatus inv), methodsName override inv]
+
+    methodsName override inv = fromMaybe (methodsFixture (isMethodId inv)) override
+
+    listedInvoice cache override (invId, inv) =
+      setField "paymentMethods" (patchMethods inv (cached (methodsName override inv))) $
+        patchInvoice invId inv (cached (invoiceFixture (isStatus inv)))
+      where
+        cached name = fromMaybe J.Null (M.lookup name cache)
+
+    serve name patch = do
+      oversize <- fsOversize <$> readTVarIO stv
+      if oversize
+        then respond (jsonResponse ok200 (J.String (T.replicate (12 * 1024 * 1024) "x")))
+        else do
+          v <- fixtureResponse name
+          respond (jsonResponse ok200 (patch v))
+
+    withInvoice invId act = do
+      invoices <- fsInvoices <$> readTVarIO stv
+      case M.lookup invId invoices of
+        Just inv -> act inv
+        Nothing -> refuse notFound404 ("no invoice " <> invId <> " on the fake btcpay")
+
+    createInvoice body = case J.decode body >>= chosenMethod of
+      Nothing -> refuse badRequest400 "checkout.paymentMethods must name exactly one of BTC-CHAIN, XMR-CHAIN"
+      Just methodId -> do
+        (invId, inv) <- atomically $ do
+          st <- readTVar stv
+          let invId = "FakeInvoiceRef" <> T.justifyRight 4 '0' (tshow (fsNextId st))
+              inv =
+                InvoiceState
+                  { isMethodId = methodId,
+                    isStatus = "New",
+                    isAdditionalStatus = "None",
+                    isPaid = Just "0.00000000", isDue = Nothing
+                  }
+          writeTVar stv st {fsNextId = fsNextId st + 1, fsInvoices = M.insert invId inv (fsInvoices st)}
+          pure (invId, inv)
+        serve (invoiceFixture (isStatus inv)) (patchInvoice invId inv)
+
+arrayEntries :: J.Value -> Maybe [J.Value]
+arrayEntries = \case
+  J.Array vs -> Just (foldr (:) [] vs)
+  _ -> Nothing
+
+paged :: Query -> [J.Value] -> [J.Value]
+paged q entries = maybe id take (intQuery "take" q) (drop (fromMaybe 0 (intQuery "skip" q)) entries)
+
+intQuery :: ByteString -> Query -> Maybe Int
+intQuery k q = join (lookup k q) >>= readMaybe . B8.unpack
+
+stateKeys :: [Key]
+stateKeys = ["status", "additionalStatus", "paymentMethodPaid", "due"]
+
+unknownKeys :: [Key] -> J.Object -> Maybe Text
+unknownKeys known o = case filter (`notElem` known) (KM.keys o) of
+  k : _ -> Just ("this control call does not set " <> K.toText k)
+  [] -> Nothing
+
+chosenMethod :: J.Value -> Maybe Text
+chosenMethod v = case objectField "checkout" v >>= objectField "paymentMethods" of
+  Just (J.Array ms) -> case foldr (:) [] ms of
+    [J.String m] | m `elem` [btcMethod, xmrMethod] -> Just m
+    _ -> Nothing
+  _ -> Nothing
+
+objectField :: Key -> J.Value -> Maybe J.Value
+objectField k = \case
+  J.Object o -> KM.lookup k o
+  _ -> Nothing
+
+textField :: Key -> J.Object -> Maybe Text
+textField k o = case KM.lookup k o of
+  Just (J.String t) -> Just t
+  _ -> Nothing
+
+intField :: Key -> J.Object -> Maybe Int
+intField k o = case KM.lookup k o of
+  Just n -> case J.fromJSON n of
+    J.Success i -> Just i
+    J.Error _ -> Nothing
+  Nothing -> Nothing
+
+jsonResponse :: Status -> J.Value -> Response
+jsonResponse st v = responseLBS st [(hContentType, "application/json")] (J.encode v)
+
+errorResponse :: Status -> Text -> Response
+errorResponse st message = jsonResponse st (J.object ["code" J..= TE.decodeUtf8 (statusMessage st), "message" J..= message])
+
+controlPost :: FakeBTCPay -> String -> J.Value -> IO ()
+controlPost FakeBTCPay {fbBaseUrl, fbManager} path v = do
+  req <- HTTP.parseRequest (fbBaseUrl <> path)
+  r <- HTTP.httpLbs req {HTTP.method = methodPost, HTTP.requestBody = HTTP.RequestBodyLBS (J.encode v)} fbManager
+  case statusCode (HTTP.responseStatus r) of
+    200 -> pure ()
+    code -> fail ("fake btcpay " <> path <> " answered " <> show code <> ": " <> show (HTTP.responseBody r))
+
+setInvoiceState :: FakeBTCPay -> Text -> [Pair] -> IO ()
+setInvoiceState fake invId fields = controlPost fake ("/_state/" <> T.unpack invId) (J.object fields)
+
+failNextCalls :: FakeBTCPay -> Int -> Int -> IO ()
+failNextCalls = failAfterCalls 0
+
+failAfterCalls :: Int -> FakeBTCPay -> Int -> Int -> IO ()
+failAfterCalls skip fake calls code =
+  controlPost fake "/_fail" (J.object ["calls" J..= calls, "status" J..= code, "skip" J..= skip])
+
+answerOversize :: FakeBTCPay -> Bool -> IO ()
+answerOversize fake on = controlPost fake "/_oversize" (J.object ["on" J..= on])
+
+useListFixture :: FakeBTCPay -> Text -> IO ()
+useListFixture fake name = controlPost fake "/_fixtures" (J.object ["list" J..= name])
+
+usePaymentMethodsFixture :: FakeBTCPay -> Text -> IO ()
+usePaymentMethodsFixture fake name = controlPost fake "/_fixtures" (J.object ["paymentMethods" J..= name])
+
+ignoreListPaging :: FakeBTCPay -> IO ()
+ignoreListPaging fake = controlPost fake "/_paging" (J.object ["ignore" J..= True])
+
+fakeRequests :: FakeBTCPay -> IO [FakeRequest]
+fakeRequests FakeBTCPay {fbState} = reverse . fsRequests <$> readTVarIO fbState
+
+fakeInvoiceIds :: FakeBTCPay -> IO [Text]
+fakeInvoiceIds FakeBTCPay {fbState} = M.keys . fsInvoices <$> readTVarIO fbState
+
+apiRequests :: FakeBTCPay -> ByteString -> [Text] -> IO [FakeRequest]
+apiRequests fake verb segments = filter matching <$> fakeRequests fake
+  where
+    matching FakeRequest {frMethod, frPath} =
+      frMethod == verb && frPath == ["api", "v1", "stores", fakeStoreId] <> segments

tests/Bots/BadgeService/FakeStripe.hs

@@ -0,0 +1,427 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Bots.BadgeService.FakeStripe
+  ( FakeStripe (..),
+    FakeRequest (..),
+    withFakeStripe,
+    fakeSessionMinutes,
+    setIntentState,
+    failNextCalls,
+    useListPageSize,
+    useListFixture,
+    apiRequests,
+    fakeIntentIds,
+    fakeIntentStatus,
+    stripeSigHeader,
+    stripeHexSig,
+    stripeEvent,
+  )
+where
+
+import BadgeService.Config (StripeConfig (..))
+import Control.Concurrent.STM
+import Crypto.Hash (Digest, SHA256)
+import Crypto.MAC.HMAC (HMAC, hmac, hmacGetDigest)
+import qualified Data.Aeson as J
+import Data.Aeson.Key (Key)
+import qualified Data.Aeson.Key as K
+import qualified Data.Aeson.KeyMap as KM
+import Data.Aeson.Types (Pair)
+import Data.ByteArray.Encoding (Base (Base16, Base64), convertToBase)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+-- http-client is imported qualified because its Request has requestHeaders, requestBody and
+-- queryString just as WAI's does.
+import Network.HTTP.Client (Manager)
+import qualified Network.HTTP.Client as HTTP
+import Network.HTTP.Types
+  ( Query,
+    Status,
+    badRequest400,
+    hAuthorization,
+    hContentType,
+    methodGet,
+    methodPost,
+    mkStatus,
+    notFound404,
+    ok200,
+    parseSimpleQuery,
+    statusCode,
+    statusMessage,
+    unauthorized401,
+  )
+import Network.HTTP.Types.Header (Header)
+import Network.Wai (Application, Response, pathInfo, queryString, requestHeaders, requestMethod, responseLBS, strictRequestBody)
+import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Messaging.Util (tshow)
+import System.FilePath ((</>))
+import Text.Read (readMaybe)
+
+fixtureDir :: FilePath
+fixtureDir = "apps" </> "simplex-badge-service" </> "test-fixtures" </> "stripe"
+
+-- | A restricted `rk_` key shaped like Stripe's, the kind the service is configured with and never a live one.
+fakeSecretKey :: Text
+fakeSecretKey = "rk_test_51QfakeKEY0000000000000000"
+
+fakeWebhookSecret :: Text
+fakeWebhookSecret = "whsec_3d8f5c6a2b1e4f7089abcdef01234567"
+
+fakeSessionMinutes :: Int
+fakeSessionMinutes = 60
+
+data FakeRequest = FakeRequest
+  { frMethod :: ByteString,
+    frPath :: [Text],
+    frQuery :: Query,
+    frHeaders :: [Header],
+    frBody :: LB.ByteString
+  }
+  deriving (Eq, Show)
+
+data IntentState = IntentState
+  { isStatus :: Text,
+    isAmount :: Int,
+    isCurrency :: Text
+  }
+  deriving (Eq, Show)
+
+data FailPlan = FailPlan {fpCalls :: Int, fpStatus :: Int}
+  deriving (Eq, Show)
+
+data FakeState = FakeState
+  { fsIntents :: M.Map Text IntentState,
+    fsNextId :: Int,
+    fsFail :: FailPlan,
+    fsList :: Text,
+    fsPageSize :: Maybe Int,
+    fsRequests :: [FakeRequest]
+  }
+
+initialState :: FakeState
+initialState =
+  FakeState
+    { fsIntents = M.empty,
+      fsNextId = 1,
+      fsFail = FailPlan {fpCalls = 0, fpStatus = 0},
+      fsList = "intent-list",
+      fsPageSize = Nothing,
+      fsRequests = []
+    }
+
+data FakeStripe = FakeStripe
+  { fsConfig :: StripeConfig,
+    fsBaseUrl :: String,
+    fsManager :: Manager,
+    fsState :: TVar FakeState
+  }
+
+-- | Warp chooses the port, because a fixed one could collide with a server left over from an
+-- earlier run and the test would pass against that instead.
+withFakeStripe :: (FakeStripe -> IO a) -> IO a
+withFakeStripe action = do
+  fsState <- newTVarIO initialState
+  fsManager <- HTTP.newManager HTTP.defaultManagerSettings
+  Warp.testWithApplication (pure (fakeApp fsState)) $ \prt -> do
+    let fsBaseUrl = "http://127.0.0.1:" <> show prt
+    action FakeStripe {fsConfig = fakeConfig (T.pack fsBaseUrl), fsBaseUrl, fsManager, fsState}
+
+fakeConfig :: Text -> StripeConfig
+fakeConfig host =
+  StripeConfig
+    { sSecretKey = fakeSecretKey,
+      sPublishableKey = "pk_test_x",
+      sWebhookSecret = fakeWebhookSecret,
+      sSessionMinutes = fakeSessionMinutes,
+      sHost = host
+    }
+
+-- | Stripe-Signature: t=<unix>,v1=<hex HMAC-SHA256 of "t.body">.
+stripeSigHeader :: Text -> Int -> LB.ByteString -> [Header]
+stripeSigHeader secret t body =
+  [("Stripe-Signature", "t=" <> B8.pack (show t) <> ",v1=" <> stripeHexSig secret t body)]
+
+stripeHexSig :: Text -> Int -> LB.ByteString -> ByteString
+stripeHexSig secret t body = convertToBase Base16 digest
+  where
+    signed = TE.encodeUtf8 (T.pack (show t) <> ".") <> LB.toStrict body
+    digest :: Digest SHA256
+    digest = hmacGetDigest (hmac (TE.encodeUtf8 secret) signed :: HMAC SHA256)
+
+-- | A minimal event of the shape @{type, data:{object:{id}}}@. The verify signs these exact bytes,
+-- so a valid signature cannot mean two different things.
+stripeEvent :: Text -> Text -> LB.ByteString
+stripeEvent eventType pid =
+  J.encode (J.object ["type" J..= eventType, "data" J..= J.object ["object" J..= J.object ["id" J..= pid]]])
+
+fixtureResponse :: Text -> IO J.Value
+fixtureResponse name = do
+  raw <- LB.readFile path
+  case J.eitherDecode raw of
+    Left e -> fail (path <> ": " <> e)
+    Right (J.Object o) -> case (KM.lookup "_fixture" o, KM.lookup "response" o) of
+      (Just (J.String _), Just v) -> pure v
+      _ -> fail (path <> ": a fixture is {\"_fixture\": <provenance>, \"response\": <body>}")
+    Right _ -> fail (path <> ": a fixture is a JSON object")
+  where
+    path = fixtureDir </> T.unpack name <> ".json"
+
+-- | An unknown status falls back to the open body but is patched to the status that was set, so a
+-- status this build has never seen still reaches the adapter verbatim.
+intentFixture :: IntentState -> Text
+intentFixture IntentState {isStatus} = case isStatus of
+  "succeeded" -> "intent-succeeded"
+  "canceled" -> "intent-canceled"
+  _ -> "intent-open"
+
+patchIntent :: Text -> IntentState -> J.Value -> J.Value
+patchIntent pid IntentState {isStatus, isAmount, isCurrency} =
+  setField "id" (J.String pid)
+    . setField "client_secret" (J.String (pid <> "_secret_test"))
+    . setField "status" (J.String isStatus)
+    . setField "amount_received" (J.toJSON (if isStatus == "succeeded" then isAmount else (0 :: Int)))
+    . setField "currency" (J.String isCurrency)
+
+setField :: Key -> J.Value -> J.Value -> J.Value
+setField k v = \case
+  J.Object o -> J.Object (KM.insert k v o)
+  other -> other
+
+fakeApp :: TVar FakeState -> Application
+fakeApp stv req respond = do
+  body <- strictRequestBody req
+  case pathInfo req of
+    ["_state", pid] | isPost -> control body (setState pid)
+    ["_fail"] | isPost -> control body setFail
+    ["_paging"] | isPost -> control body setPaging
+    ["_fixtures"] | isPost -> control body setFixtures
+    "v1" : "payment_intents" : rest -> apiCall body rest
+    _ -> refuse notFound404 "no such path on the fake stripe"
+  where
+    verb = requestMethod req
+    isPost = verb == methodPost
+    isGet = verb == methodGet
+    refuse st message = respond (errorResponse st message)
+    ok = respond (jsonResponse ok200 (J.object ["ok" J..= True]))
+
+    control b act = case J.decode b of
+      Just (J.Object o) ->
+        act o >>= \case
+          Nothing -> ok
+          Just message -> refuse badRequest400 message
+      _ -> refuse badRequest400 "a control call takes a JSON object"
+
+    setState pid o = case unknownKeys stateKeys o of
+      Just message -> pure (Just message)
+      Nothing -> atomically $ do
+        st <- readTVar stv
+        case M.lookup pid (fsIntents st) of
+          Nothing -> pure (Just ("no intent " <> pid <> " was created here"))
+          Just s -> do
+            let s' = s {isStatus = fromMaybe (isStatus s) (textField "status" o)}
+            writeTVar stv st {fsIntents = M.insert pid s' (fsIntents st)}
+            pure Nothing
+
+    setFail o = case unknownKeys ["calls", "status"] o of
+      Just message -> pure (Just message)
+      Nothing -> case (intField "calls" o, intField "status" o) of
+        (Just calls, Just code) -> do
+          atomically (modifyTVar' stv (\st -> st {fsFail = FailPlan {fpCalls = calls, fpStatus = code}}))
+          pure Nothing
+        _ -> pure (Just "_fail takes {\"calls\": <n>, \"status\": <http status>}")
+
+    setPaging o = case unknownKeys ["size"] o of
+      Just message -> pure (Just message)
+      Nothing -> case intField "size" o of
+        Just size -> do
+          atomically (modifyTVar' stv (\st -> st {fsPageSize = Just size}))
+          pure Nothing
+        Nothing -> pure (Just "_paging takes {\"size\": <n>}")
+
+    setFixtures o = case unknownKeys ["list"] o of
+      Just message -> pure (Just message)
+      Nothing -> case textField "list" o of
+        Just name -> do
+          atomically (modifyTVar' stv (\st -> st {fsList = name}))
+          pure Nothing
+        Nothing -> pure (Just "_fixtures takes {\"list\": <fixture name>}")
+
+    apiCall b rest = do
+      atomically $
+        modifyTVar' stv $ \st ->
+          st {fsRequests = FakeRequest verb (pathInfo req) (queryString req) (requestHeaders req) b : fsRequests st}
+      case lookup hAuthorization (requestHeaders req) of
+        Just given | given == expectedAuth -> injectingFailure (route b rest)
+        _ -> refuse unauthorized401 "Authorization must be HTTP Basic with the secret key as username"
+
+    -- Stripe authenticates the secret key as the Basic username with an empty password, which is
+    -- how http-client's applyBasicAuth builds the header.
+    expectedAuth = "Basic " <> convertToBase Base64 (TE.encodeUtf8 (fakeSecretKey <> ":"))
+
+    injectingFailure act = do
+      failing <- atomically $ do
+        st <- readTVar stv
+        case fsFail st of
+          plan@FailPlan {fpCalls, fpStatus} | fpCalls > 0 -> do
+            writeTVar stv st {fsFail = plan {fpCalls = fpCalls - 1}}
+            pure (Just fpStatus)
+          _ -> pure Nothing
+      case failing of
+        Just code -> refuse (mkStatus code "Injected Failure") "the fake was told to fail this call"
+        Nothing -> act
+
+    route b = \case
+      [] | isPost -> createIntent b
+      [] | isGet -> listIntents
+      [pid] | isGet -> withIntent pid $ \s -> serve (intentFixture s) (patchIntent pid s)
+      [pid, "cancel"] | isPost -> cancelIntent pid
+      _ -> refuse notFound404 "no such payment_intents path on the fake stripe"
+
+    createIntent b = do
+      let form = parseSimpleQuery (LB.toStrict b)
+          amount = fromMaybe 0 (lookup "amount" form >>= readMaybe . B8.unpack)
+          currency = maybe "usd" TE.decodeUtf8 (lookup "currency" form)
+      (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)
+      serve (intentFixture s) (patchIntent pid s)
+
+    -- Real Stripe can't cancel a card payment that is processing, paid or already cancelled.
+    cancelIntent pid = do
+      cancelled <- atomically $ do
+        st <- readTVar stv
+        case M.lookup pid (fsIntents st) of
+          Nothing -> pure Nothing
+          Just s
+            | isStatus s `elem` ["processing", "succeeded", "canceled"] -> pure (Just (Left s))
+            | otherwise -> do
+                let s' = s {isStatus = "canceled"}
+                writeTVar stv st {fsIntents = M.insert pid s' (fsIntents st)}
+                pure (Just (Right s'))
+      case cancelled of
+        Nothing -> refuse notFound404 ("no intent " <> pid <> " on the fake stripe")
+        Just (Left s) ->
+          respond . stripeError badRequest400 "payment_intent_unexpected_state" $
+            "You cannot cancel this PaymentIntent because it has a status of " <> isStatus s <> "."
+        Just (Right s') -> serve (intentFixture s') (patchIntent pid s')
+
+    listIntents = do
+      st <- readTVarIO stv
+      full <- fixtureResponse (fsList st)
+      let (page, more) = pageItems (fsPageSize st) (queryText "starting_after" (queryString req)) (listItems full)
+      respond (jsonResponse ok200 (J.object ["object" J..= ("list" :: Text), "data" J..= page, "has_more" J..= more]))
+
+    serve name patch = do
+      v <- fixtureResponse name
+      respond (jsonResponse ok200 (patch v))
+
+    withIntent pid act = do
+      intents <- fsIntents <$> readTVarIO stv
+      case M.lookup pid intents of
+        Just s -> act s
+        Nothing -> refuse notFound404 ("no intent " <> pid <> " on the fake stripe")
+
+listItems :: J.Value -> [J.Value]
+listItems = \case
+  J.Object o -> case KM.lookup "data" o of
+    Just (J.Array vs) -> foldr (:) [] vs
+    _ -> []
+  _ -> []
+
+-- | No page size serves the whole array. With one, `starting_after` names the id after which
+-- the page begins, and `has_more` says whether anything is left.
+pageItems :: Maybe Int -> Maybe Text -> [J.Value] -> ([J.Value], Bool)
+pageItems Nothing _ items = (items, False)
+pageItems (Just size) after items = (take size rest, length rest > size)
+  where
+    rest = case after of
+      Nothing -> items
+      Just a -> drop 1 (dropWhile ((/= Just a) . intentId) items)
+
+intentId :: J.Value -> Maybe Text
+intentId = \case
+  J.Object o -> case KM.lookup "id" o of
+    Just (J.String i) -> Just i
+    _ -> Nothing
+  _ -> Nothing
+
+queryText :: ByteString -> Query -> Maybe Text
+queryText k q = case lookup k q of
+  Just (Just v) -> Just (TE.decodeUtf8 v)
+  _ -> Nothing
+
+jsonResponse :: Status -> J.Value -> Response
+jsonResponse st v = responseLBS st [(hContentType, "application/json")] (J.encode v)
+
+errorResponse :: Status -> Text -> Response
+errorResponse st = stripeError st (TE.decodeUtf8 (statusMessage st))
+
+stripeError :: Status -> Text -> Text -> Response
+stripeError st code message = jsonResponse st (J.object ["error" J..= J.object ["message" J..= message, "code" J..= code]])
+
+stateKeys :: [Key]
+stateKeys = ["status"]
+
+unknownKeys :: [Key] -> J.Object -> Maybe Text
+unknownKeys known o = case filter (`notElem` known) (KM.keys o) of
+  k : _ -> Just ("this control call does not set " <> K.toText k)
+  [] -> Nothing
+
+textField :: Key -> J.Object -> Maybe Text
+textField k o = case KM.lookup k o of
+  Just (J.String t) -> Just t
+  _ -> Nothing
+
+intField :: Key -> J.Object -> Maybe Int
+intField k o = case KM.lookup k o of
+  Just n -> case J.fromJSON n of
+    J.Success i -> Just i
+    J.Error _ -> Nothing
+  Nothing -> Nothing
+
+controlPost :: FakeStripe -> String -> J.Value -> IO ()
+controlPost FakeStripe {fsBaseUrl, fsManager} path v = do
+  req <- HTTP.parseRequest (fsBaseUrl <> path)
+  r <- HTTP.httpLbs req {HTTP.method = methodPost, HTTP.requestBody = HTTP.RequestBodyLBS (J.encode v)} fsManager
+  case statusCode (HTTP.responseStatus r) of
+    200 -> pure ()
+    code -> fail ("fake stripe " <> path <> " answered " <> show code <> ": " <> show (HTTP.responseBody r))
+
+setIntentState :: FakeStripe -> Text -> [Pair] -> IO ()
+setIntentState fake pid fields = controlPost fake ("/_state/" <> T.unpack pid) (J.object fields)
+
+failNextCalls :: FakeStripe -> Int -> Int -> IO ()
+failNextCalls fake calls code = controlPost fake "/_fail" (J.object ["calls" J..= calls, "status" J..= code])
+
+useListPageSize :: FakeStripe -> Int -> IO ()
+useListPageSize fake size = controlPost fake "/_paging" (J.object ["size" J..= size])
+
+useListFixture :: FakeStripe -> Text -> IO ()
+useListFixture fake name = controlPost fake "/_fixtures" (J.object ["list" J..= name])
+
+fakeRequests :: FakeStripe -> IO [FakeRequest]
+fakeRequests FakeStripe {fsState} = reverse . fsRequests <$> readTVarIO fsState
+
+fakeIntentIds :: FakeStripe -> IO [Text]
+fakeIntentIds FakeStripe {fsState} = M.keys . fsIntents <$> readTVarIO fsState
+
+fakeIntentStatus :: FakeStripe -> Text -> IO (Maybe Text)
+fakeIntentStatus FakeStripe {fsState} pid = fmap isStatus . M.lookup pid . fsIntents <$> readTVarIO fsState
+
+apiRequests :: FakeStripe -> ByteString -> [Text] -> IO [FakeRequest]
+apiRequests fake verb segments = filter matching <$> fakeRequests fake
+  where
+    matching FakeRequest {frMethod, frPath} =
+      frMethod == verb && frPath == ["v1", "payment_intents"] <> segments

tests/Bots/BadgeService/StripeTests.hs

@@ -0,0 +1,353 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bots.BadgeService.StripeTests (badgeStripeTests) where
+
+import BadgeService.Config (StripeConfig (..))
+import BadgeService.Providers
+  ( ListPass (..),
+    OrderDraft (..),
+    PaymentSignal (..),
+    Provider (..),
+    ProviderError (..),
+    ProviderInvoice (..),
+    Received (..),
+    settleWindow,
+    WebhookError (..),
+  )
+import BadgeService.Providers.Stripe (IntentRead (..), signalOf, stripeProvider)
+import Bots.BadgeService.FakeStripe
+import Control.Monad (join)
+import Data.Aeson ((.=))
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy as LB
+import Data.Either (isLeft)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import Network.HTTP.Types (hAuthorization, parseSimpleQuery)
+import Text.Read (readMaybe)
+import Simplex.Chat.PaymentService.Types
+  ( CardProvider (..),
+    CryptoCurrency (..),
+    CurrencyAmount (..),
+    ServicePaymentDestination (..),
+    ServicePaymentMethod (..),
+  )
+import System.Timeout (timeout)
+import Test.Hspec
+
+badgeStripeTests :: Spec
+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 "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
+    it "refuses to cancel an intent while it is processing" testFakeCancelRefusedWhileProcessing
+    it "reads the expand query on every read" testFakeReadExpands
+    it "closes on a canceled intent" testFakeCanceled
+    it "makes a 500 at checkout a ProviderError, creating nothing" testFakeCreate500
+    it "makes a 500 on a read a ProviderError the next read recovers from" testFakeRead500
+    it "refuses a crypto method, since Stripe offers none" testRefusesCrypto
+    it "makes an unknown intent status a ProviderError, not a silent no-signal" testFakeReadUnknownStatus
+    it "settles a succeeded intent with no charge at read time" testSettledNoChargeReadTime
+  describe "listing intents to settle" $ do
+    it "lists by a created window, never status=open" testFakeListWindow
+    it "moves the settled and canceled intents, at read time, leaving the open one" testFakeListsOpen
+    it "skips a listed intent that carries no id" testFakeListSkipsIdless
+    it "walks starting_after across pages, gathering every intent" testFakeListPages
+    it "records an anomaly when a page ends with no cursor id" testFakeListCursorGap
+    it "aborts the whole pass on a 429" testFakeList429
+  describe "verifying the webhook signature" $ do
+    it "accepts a signed succeeded event and names its intent" testWebhookVerifies
+    it "answers a valid but unhandled event with no intent" testWebhookUnhandled
+    it "accepts any v1 during a rotation, refusing only when none matches" testWebhookRotatedSignature
+    it "refuses a missing, malformed, or tampered signature" testWebhookMalformed
+    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"}
+
+fiftyFourDollarsReceived :: Received
+fiftyFourDollarsReceived = Received {rcvAmount = CurrencyAmount 5400, rcvCrypto = Nothing, rcvDue = Nothing}
+
+nothingReceived :: Received
+nothingReceived = Received {rcvAmount = CurrencyAmount 0, rcvCrypto = Nothing, rcvDue = Nothing}
+
+fixtureChargeAt :: UTCTime
+fixtureChargeAt = posixSecondsToUTCTime 1700000000
+
+exampleCeiling :: Int
+exampleCeiling = 20000000
+
+failWith :: HasCallStack => String -> IO a
+failWith msg = expectationFailure msg >> error msg
+
+withProvider :: HasCallStack => (FakeStripe -> Provider -> IO a) -> IO a
+withProvider action = bounded $ withFakeStripe $ \fake -> stripeProvider (fsConfig fake) >>= action fake
+  where
+    bounded act = timeout exampleCeiling act >>= maybe (failWith "the fake stripe did not answer within 20s") pure
+
+createdInvoice :: HasCallStack => Provider -> ServicePaymentMethod -> IO ProviderInvoice
+createdInvoice p spm =
+  pCreateInvoice p spm fiftyFourDollars >>= \case
+    Right inv -> pure inv
+    Left e -> failWith ("expected an invoice, got " <> show e)
+
+isCardSecret :: ServicePaymentDestination -> Bool
+isCardSecret = \case
+  SPDCard CPStripe secret -> secret /= ""
+  _ -> False
+
+testFakeCreatesCard :: IO ()
+testFakeCreatesCard = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef, piDestination} <- createdInvoice p (SPMCard CPStripe)
+  piDestination `shouldSatisfy` isCardSecret
+  fakeIntentIds fake `shouldReturn` [piProviderRef]
+  posts <- apiRequests fake "POST" []
+  length posts `shouldBe` 1
+
+testFakeCreateBody :: IO ()
+testFakeCreateBody = withProvider $ \fake p -> do
+  _ <- createdInvoice p (SPMCard CPStripe)
+  posts <- apiRequests fake "POST" []
+  case posts of
+    [created] -> do
+      let form = parseSimpleQuery (LB.toStrict (frBody created))
+      lookup "amount" form `shouldBe` Just "5400"
+      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 hAuthorization (frHeaders created) `shouldSatisfy` maybe False ("Basic " `B8.isPrefixOf`)
+    _ -> expectationFailure ("expected one create, got " <> show (length posts))
+
+testFakeWrongSecretKey :: IO ()
+testFakeWrongSecretKey = bounded $ withFakeStripe $ \fake -> do
+  p <- stripeProvider (fsConfig fake) {sSecretKey = "sk_test_wrong"}
+  r <- pCreateInvoice p (SPMCard CPStripe) fiftyFourDollars
+  r `shouldSatisfy` namesInError "401"
+  fakeIntentIds fake `shouldReturn` []
+  where
+    bounded act = timeout exampleCeiling act >>= maybe (failWith "the fake stripe did not answer within 20s") pure
+
+testFakeLifecycle :: IO ()
+testFakeLifecycle = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe)
+  pReadInvoice p pid `shouldReturn` Right Nothing
+  setIntentState fake pid ["status" .= ("processing" :: Text)]
+  pReadInvoice p pid `shouldReturn` Right Nothing
+  setIntentState fake pid ["status" .= ("succeeded" :: Text)]
+  pReadInvoice p pid `shouldReturn` Right (Just (SigSettled fiftyFourDollarsReceived fixtureChargeAt))
+  pCancelInvoice p pid >>= (`shouldSatisfy` namesInError "payment_intent_unexpected_state")
+  fakeIntentStatus fake pid `shouldReturn` Just "succeeded"
+  cancels <- apiRequests fake "POST" [pid, "cancel"]
+  length cancels `shouldBe` 1
+
+testFakeCancelRefusedWhileProcessing :: IO ()
+testFakeCancelRefusedWhileProcessing = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe)
+  setIntentState fake pid ["status" .= ("processing" :: Text)]
+  pCancelInvoice p pid >>= (`shouldSatisfy` namesInError "payment_intent_unexpected_state")
+  fakeIntentStatus fake pid `shouldReturn` Just "processing"
+
+testFakeCancel :: IO ()
+testFakeCancel = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe)
+  pCancelInvoice p pid `shouldReturn` Right ()
+  fakeIntentStatus fake pid `shouldReturn` Just "canceled"
+  pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived))
+  pCancelInvoice p pid >>= (`shouldSatisfy` namesInError "payment_intent_unexpected_state")
+
+testFakeReadExpands :: IO ()
+testFakeReadExpands = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe)
+  _ <- pReadInvoice p pid
+  gets <- apiRequests fake "GET" [pid]
+  case gets of
+    [g] -> lookup "expand[]" (frQuery g) `shouldBe` Just (Just "latest_charge")
+    _ -> expectationFailure ("expected one read, got " <> show (length gets))
+
+testFakeCanceled :: IO ()
+testFakeCanceled = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe)
+  setIntentState fake pid ["status" .= ("canceled" :: Text)]
+  -- A nonzero received amount here would write a phantom payment for money the buyer never sent.
+  pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived))
+
+testFakeCreate500 :: IO ()
+testFakeCreate500 = withProvider $ \fake p -> do
+  failNextCalls fake 1 500
+  r <- pCreateInvoice p (SPMCard CPStripe) fiftyFourDollars
+  r `shouldSatisfy` namesInError "500"
+  fakeIntentIds fake `shouldReturn` []
+
+testFakeRead500 :: IO ()
+testFakeRead500 = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe)
+  setIntentState fake pid ["status" .= ("succeeded" :: Text)]
+  failNextCalls fake 1 500
+  r <- pReadInvoice p pid
+  r `shouldSatisfy` namesInError "500"
+  pReadInvoice p pid `shouldReturn` Right (Just (SigSettled fiftyFourDollarsReceived fixtureChargeAt))
+
+testRefusesCrypto :: IO ()
+testRefusesCrypto = withProvider $ \_ p ->
+  pCreateInvoice p (SPMCrypto CCBtc) fiftyFourDollars >>= (`shouldSatisfy` isLeft)
+
+-- | An unknown status must be an error rather than Right Nothing, which would tell the poller the
+-- intent had not changed and leave the order to expire.
+testFakeReadUnknownStatus :: IO ()
+testFakeReadUnknownStatus = withProvider $ \fake p -> do
+  ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe)
+  setIntentState fake pid ["status" .= ("frozen" :: Text)]
+  pReadInvoice p pid >>= (`shouldSatisfy` namesInError "unknown status")
+
+-- | Stripe can report an intent succeeded before its charge is expanded. With no charge to date it,
+-- the settlement instant falls back to the read time rather than an epoch.
+testSettledNoChargeReadTime :: IO ()
+testSettledNoChargeReadTime = do
+  now <- getCurrentTime
+  let ir = IntentRead {irId = "pi_test_x", irStatus = "succeeded", irAmountReceived = 5400, irChargeCreated = Nothing}
+  signalOf now ir `shouldBe` Right (Just (SigSettled fiftyFourDollarsReceived now))
+
+-- | A status=open query returns only open intents, which carry no signal, so the poll lists by
+-- creation time instead to catch a settlement the webhook missed. The window reaches back the
+-- settle window plus an intent's own lifetime.
+testFakeListWindow :: IO ()
+testFakeListWindow = withProvider $ \fake p -> do
+  askedAt <- getCurrentTime
+  _ <- pListOpen p
+  answeredAt <- getCurrentTime
+  gets <- apiRequests fake "GET" []
+  case gets of
+    (listed : _) -> do
+      lookup "status" (frQuery listed) `shouldBe` Nothing
+      case join (lookup "created[gte]" (frQuery listed)) >>= readMaybe . B8.unpack of
+        Nothing -> expectationFailure ("no readable created[gte] in " <> show (frQuery listed))
+        Just sent -> do
+          let window = truncate settleWindow + 60 * toInteger fakeSessionMinutes
+              seconds t = floor (utcTimeToPOSIXSeconds t) :: Integer
+          sent `shouldSatisfy` \s -> s >= seconds askedAt - window && s <= seconds answeredAt - window
+    [] -> expectationFailure "expected at least one list request"
+
+testFakeListsOpen :: IO ()
+testFakeListsOpen = withProvider $ \_ p -> do
+  askedAt <- getCurrentTime
+  r <- pListOpen p
+  answeredAt <- getCurrentTime
+  case r of
+    Right ListPass {lpMoved} -> do
+      map fst lpMoved `shouldSatisfy` elem "pi_test_a"
+      map fst lpMoved `shouldSatisfy` elem "pi_test_b"
+      map fst lpMoved `shouldSatisfy` notElem "pi_test_open"
+      case lookup "pi_test_a" lpMoved of
+        Just (SigSettled rcv settledAt) -> do
+          rcv `shouldBe` fiftyFourDollarsReceived
+          settledAt `shouldSatisfy` \t -> t >= askedAt && t <= answeredAt
+        other -> failWith ("pi_test_a should settle at read time, got " <> show other)
+      lookup "pi_test_b" lpMoved `shouldBe` Just (SigClosed nothingReceived)
+    Left e -> failWith ("expected a list pass, got " <> show e)
+
+testFakeListSkipsIdless :: IO ()
+testFakeListSkipsIdless = withProvider $ \_ p ->
+  pListOpen p >>= \case
+    Right ListPass {lpSkipped} -> map fst lpSkipped `shouldBe` [Nothing]
+    Left e -> failWith ("expected a list pass, got " <> show e)
+
+testFakeListPages :: IO ()
+testFakeListPages = withProvider $ \fake p -> do
+  useListPageSize fake 1
+  pListOpen p >>= \case
+    Right ListPass {lpMoved} -> do
+      map fst lpMoved `shouldSatisfy` elem "pi_test_a"
+      map fst lpMoved `shouldSatisfy` elem "pi_test_b"
+    Left e -> failWith ("expected a list pass, got " <> show e)
+
+-- | Stripe pages by the last row's id. A page whose last row has no id leaves no cursor, so the
+-- rest cannot be walked; that must surface as an anomaly, not a clean pass that silently drops
+-- the intents beyond it.
+testFakeListCursorGap :: IO ()
+testFakeListCursorGap = withProvider $ \fake p -> do
+  useListFixture fake "intent-list-cursor-gap"
+  useListPageSize fake 2
+  pListOpen p >>= \case
+    Right ListPass {lpMoved, lpSkipped} -> do
+      map fst lpMoved `shouldSatisfy` elem "pi_test_a"
+      map fst lpMoved `shouldSatisfy` notElem "pi_test_c"
+      map snd lpSkipped `shouldSatisfy` any ("no id to page from" `T.isInfixOf`)
+    Left e -> failWith ("expected a list pass, got " <> show e)
+
+testFakeList429 :: IO ()
+testFakeList429 = withProvider $ \fake p -> do
+  failNextCalls fake 1 429
+  pListOpen p >>= (`shouldSatisfy` namesInError "429")
+
+testWebhookVerifies :: IO ()
+testWebhookVerifies = withProvider $ \fake p -> do
+  let secret = sWebhookSecret (fsConfig fake)
+      body = stripeEvent "payment_intent.succeeded" "pi_test_a"
+  pVerifyWebhook p signedAt (stripeSigHeader secret 1700000000 body) (LB.toStrict body) `shouldBe` Right (Just "pi_test_a")
+  pVerifyWebhook p signedAt (stripeSigHeader (secret <> "0") 1700000000 body) (LB.toStrict body) `shouldSatisfy` isRefused
+
+testWebhookUnhandled :: IO ()
+testWebhookUnhandled = withProvider $ \fake p -> do
+  let secret = sWebhookSecret (fsConfig fake)
+      body = stripeEvent "charge.refunded" "pi_test_a"
+  pVerifyWebhook p signedAt (stripeSigHeader secret 1700000000 body) (LB.toStrict body) `shouldBe` Right Nothing
+
+-- | Stripe sends one v1 per active secret while a signing secret is being rotated, so a valid
+-- signature can be any of them, not only the first.
+testWebhookRotatedSignature :: IO ()
+testWebhookRotatedSignature = withProvider $ \fake p -> do
+  let secret = sWebhookSecret (fsConfig fake)
+      t = 1700000000 :: Int
+      body = stripeEvent "payment_intent.succeeded" "pi_test_a"
+      good = stripeHexSig secret t body
+      wrong = stripeHexSig (secret <> "0") t body
+      header sigs = [("Stripe-Signature", "t=" <> B8.pack (show t) <> B8.concat [",v1=" <> s | s <- sigs])]
+  pVerifyWebhook p signedAt (header [wrong, good]) (LB.toStrict body) `shouldBe` Right (Just "pi_test_a")
+  pVerifyWebhook p signedAt (header [wrong, wrong]) (LB.toStrict body) `shouldSatisfy` isRefused
+
+testWebhookMalformed :: IO ()
+testWebhookMalformed = withProvider $ \fake p -> do
+  let secret = sWebhookSecret (fsConfig fake)
+      body = stripeEvent "payment_intent.succeeded" "pi_test_a"
+      raw = LB.toStrict body
+  pVerifyWebhook p signedAt [] raw `shouldSatisfy` isRefused
+  pVerifyWebhook p signedAt [("Stripe-Signature", "t=1700000000")] raw `shouldSatisfy` isRefused
+  pVerifyWebhook p signedAt [("Stripe-Signature", "t=1700000000,v1=not hex")] raw `shouldSatisfy` isRefused
+  pVerifyWebhook p signedAt (stripeSigHeader secret 1700000000 body) (raw <> "x") `shouldSatisfy` isRefused
+
+testWebhookTimestampWindow :: IO ()
+testWebhookTimestampWindow = withProvider $ \fake p -> do
+  let secret = sWebhookSecret (fsConfig fake)
+      body = stripeEvent "payment_intent.succeeded" "pi_test_a"
+      signedOffBy offset = pVerifyWebhook p signedAt (stripeSigHeader secret (1700000000 + offset) body) (LB.toStrict body)
+      window = 15 * 60
+  signedOffBy (negate window) `shouldBe` Right (Just "pi_test_a")
+  signedOffBy window `shouldBe` Right (Just "pi_test_a")
+  signedOffBy (negate window - 1) `shouldSatisfy` isStale
+  signedOffBy (window + 1) `shouldSatisfy` isStale
+
+-- | The test signatures are made at this time, so they pass the 15-minute check.
+signedAt :: UTCTime
+signedAt = posixSecondsToUTCTime 1700000000
+
+namesInError :: Text -> Either ProviderError a -> Bool
+namesInError what = \case
+  Left (ProviderError e) -> what `T.isInfixOf` e
+  Right _ -> False
+
+isRefused :: Either WebhookError (Maybe Text) -> Bool
+isRefused = \case
+  Left (WebhookError _) -> True
+  _ -> False
+
+isStale :: Either WebhookError (Maybe Text) -> Bool
+isStale = \case
+  Left (WebhookStale _) -> True
+  _ -> False

tests/Bots/BadgeService/WaitersTests.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Bots.BadgeService.WaitersTests (badgeWaitersTests) where
+
+import BadgeService.Waiters
+import Control.Concurrent.Async (wait, withAsync)
+import Control.Concurrent.STM
+import Control.Exception (Exception, SomeException, throwIO, try)
+import Data.IORef (newIORef, readIORef)
+import Data.Text (Text)
+import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus (..))
+import System.Timeout (timeout)
+import Test.Hspec
+
+badgeWaitersTests :: Spec
+badgeWaitersTests = describe "badge service waiters" $ do
+  it "wakes on a status published between subscribe and the database read" testSubscribeBeforeRead
+  it "answers a payment whose publish landed before this request subscribed" testPaymentPublishedBeforeSubscribe
+  it "is not woken by a publish for a different invoice" testDifferentInvoiceNoWake
+  it "returns the current status, not an error, when the wait times out" testTimeoutReturnsCurrentStatus
+  it "empties the map when the waiting action throws" testMapEmptiesOnException
+  it "empties the map after a normal return" testMapEmptiesOnNormalReturn
+  it "keeps one map entry for two waiters on the same invoice" testRefcountSharedInvoice
+  it "counts one entry per invoice, not per waiter" testWaitingCountPerInvoice
+
+iid, iid2 :: InvoiceId
+iid = InvoiceId "inv-1"
+iid2 = InvoiceId "inv-2"
+
+-- | An invoice nobody has paid into carries no figure and no verdict from the provider.
+unpaid :: (Text, Bool)
+unpaid = ("", False)
+
+openUnpaid :: Seen
+openUnpaid = (ISOpen, unpaid)
+
+data Boom = Boom deriving (Show)
+
+instance Exception Boom
+
+-- | This suite has hung rather than failed before. `us` must exceed every awaitStatus
+-- timeout the test uses.
+bounded :: String -> Int -> IO a -> IO a
+bounded what us act =
+  timeout us act >>= \case
+    Just a -> pure a
+    Nothing -> do
+      expectationFailure (what <> " did not finish within " <> show us <> "us")
+      error "unreachable: expectationFailure always throws"
+
+testSubscribeBeforeRead :: IO ()
+testSubscribeBeforeRead = bounded "the ordering wait" 2_000_000 $ do
+  w <- newWaiters
+  ref <- newIORef ISOpen
+  let readStatus = do
+        atomically $ publish w iid ISPaid
+        (\s -> (s, unpaid)) <$> readIORef ref
+  s <- awaitStatus w iid readStatus openUnpaid 200_000
+  s `shouldBe` ISPaid
+
+testDifferentInvoiceNoWake :: IO ()
+testDifferentInvoiceNoWake = bounded "the isolation wait" 2_000_000 $ do
+  w <- newWaiters
+  otherSubscribed <- newEmptyTMVarIO
+  let otherRead = atomically (putTMVar otherSubscribed ()) >> pure openUnpaid
+  withAsync (awaitStatus w iid2 otherRead openUnpaid 200_000) $ \other ->
+    withAsync (awaitStatus w iid (pure openUnpaid) openUnpaid 200_000) $ \watched -> do
+      atomically $ takeTMVar otherSubscribed
+      atomically $ publish w iid2 ISPaid
+      otherResult <- wait other
+      otherResult `shouldBe` ISPaid
+      watchedResult <- wait watched
+      watchedResult `shouldBe` ISOpen
+
+testTimeoutReturnsCurrentStatus :: IO ()
+testTimeoutReturnsCurrentStatus = bounded "the timeout wait" 1_000_000 $ do
+  w <- newWaiters
+  s <- awaitStatus w iid (pure openUnpaid) openUnpaid 50_000
+  s `shouldBe` ISOpen
+
+testMapEmptiesOnException :: IO ()
+testMapEmptiesOnException = bounded "the exception-cleanup wait" 1_000_000 $ do
+  w <- newWaiters
+  _ <- try @SomeException $ awaitStatus w iid (throwIO Boom) openUnpaid 1_000_000
+  waitingCount w >>= (`shouldBe` 0)
+
+testMapEmptiesOnNormalReturn :: IO ()
+testMapEmptiesOnNormalReturn = bounded "the normal-return cleanup wait" 1_000_000 $ do
+  w <- newWaiters
+  _ <- awaitStatus w iid (pure openUnpaid) openUnpaid 50_000
+  waitingCount w >>= (`shouldBe` 0)
+
+testRefcountSharedInvoice :: IO ()
+testRefcountSharedInvoice = bounded "the shared-invoice refcount wait" 2_000_000 $ do
+  w <- newWaiters
+  entered <- newTVarIO (0 :: Int)
+  go <- newTVarIO False
+  let readStatus = do
+        atomically $ modifyTVar' entered (+ 1)
+        atomically $ readTVar go >>= check
+        pure openUnpaid
+  withAsync (awaitStatus w iid readStatus openUnpaid 500_000) $ \a1 ->
+    withAsync (awaitStatus w iid readStatus openUnpaid 500_000) $ \a2 -> do
+      atomically $ readTVar entered >>= check . (== 2)
+      waitingCount w >>= (`shouldBe` 1)
+      atomically $ writeTVar go True
+      atomically $ publish w iid ISPaid
+      r1 <- wait a1
+      r2 <- wait a2
+      r1 `shouldBe` ISPaid
+      r2 `shouldBe` ISPaid
+      waitingCount w >>= (`shouldBe` 0)
+
+testWaitingCountPerInvoice :: IO ()
+testWaitingCountPerInvoice = bounded "the per-invoice waiting-count wait" 2_000_000 $ do
+  w <- newWaiters
+  entered <- newTVarIO (0 :: Int)
+  go <- newTVarIO False
+  let readStatus = do
+        atomically $ modifyTVar' entered (+ 1)
+        atomically $ readTVar go >>= check
+        pure openUnpaid
+  withAsync (awaitStatus w iid readStatus openUnpaid 500_000) $ \a1 ->
+    withAsync (awaitStatus w iid2 readStatus openUnpaid 500_000) $ \a2 -> do
+      atomically $ readTVar entered >>= check . (== 2)
+      waitingCount w >>= (`shouldBe` 2)
+      atomically $ writeTVar go True
+      atomically $ publish w iid ISPaid
+      atomically $ publish w iid2 ISPaid
+      r1 <- wait a1
+      r2 <- wait a2
+      r1 `shouldBe` ISPaid
+      r2 `shouldBe` ISPaid
+      waitingCount w >>= (`shouldBe` 0)
+
+-- | The payment committed before this request subscribed, so its publish found no watch and
+-- the counter cannot report it. The read after subscribing is the only thing that can, and a
+-- request that waits for the counter alone parks for its whole timeout with the money already in.
+testPaymentPublishedBeforeSubscribe :: IO ()
+testPaymentPublishedBeforeSubscribe = do
+  w <- newWaiters
+  s <- bounded "the lost-publish wait" 1_000_000 $ awaitStatus w iid (pure (ISOpen, ("0.005", True))) openUnpaid 30_000_000
+  s `shouldBe` ISOpen

tests/Test.hs

@@ -3,7 +3,13 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TupleSections #-}
 
-import Bots.BadgeServiceTests
+import Bots.BadgeService.BTCPayTests
+import Bots.BadgeService.BotTests
+import Bots.BadgeService.CatalogTests
+import Bots.BadgeService.ConfigTests
+import Bots.BadgeService.StripeTests
+import Bots.BadgeService.WaitersTests
+import Bots.BadgeService.WebTests
 import Bots.BroadcastTests
 import Bots.DirectoryTests
 import ChatClient
@@ -64,6 +70,13 @@ main = do
       around tmpBracket $ describe "WebRTC encryption" webRTCTests
 #endif
       describe "Supporter badges" badgeTests
+      describe "SimpleX badge service" $ do
+        badgeConfigTests
+        badgeWebTests
+        badgeCatalogTests
+        badgeWaitersTests
+        badgeBTCPayTests
+        badgeStripeTests
       describe "SimpleX chat markdown" markdownTests
       describe "JSON Tests" jsonTests
       describe "Member relations" memberRelationsTests
@@ -89,7 +102,7 @@ main = do
           describe "SimpleX chat client" chatTests
           xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
           xdescribe'' "SimpleX Directory service bot" directoryServiceTests
-          xdescribe'' "SimpleX Badge service bot" badgeServiceTests
+          xdescribe'' "SimpleX badge service e2e" badgeServiceTests
           describe "Remote session" remoteTests
 #if !defined(dbPostgres)
           xdescribe'' "Save query plans" saveQueryPlans