simplex-chat/tests/Bots/StoreService/StripeTests.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Bots.StoreService.StripeTests (badgeStripeTests) where

import StoreService.Config (StripeConfig (..))
import StoreService.Providers
  ( ListPass (..),
    OrderDraft (..),
    PaymentSignal (..),
    Provider (..),
    ProviderError (..),
    ProviderInvoice (..),
    Received (..),
    settleWindow,
    WebhookError (..),
  )
import StoreService.Providers.Stripe (IntentRead (..), signalOf, stripeProvider)
import Bots.StoreService.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