simplex-chat/tests/Bots/BadgeService/WebTests.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Bots.BadgeService.WebTests (badgeWebTests) where

import BadgeService.Catalog (catalogCurrency, defaultCatalog)
import BadgeService.Config (BTCPayConfig (..), ListenerConfig (..), PollConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..))
import BadgeService.Orders (codeLifetime, settleOrder)
import BadgeService.Poller
import BadgeService.Providers
import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages)
import BadgeService.Providers.Stripe (stripeProvider)
import BadgeService.Store (CodeRedemption (..), IssuedCode (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getBadgeCode, insertBadgeCode, revokeCode)
import BadgeService.Store.Invoices
import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount)
import BadgeService.Web.Server
import Bots.BadgeService.BotTests (newPurchaseKeys)
import Bots.BadgeService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource)
import Bots.BadgeService.FakeBTCPay
import Bots.BadgeService.FakeStripe (FakeStripe (..), fakeIntentStatus, setIntentState, stripeEvent, stripeSigHeader, withFakeStripe)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.Async (async, wait)
import qualified Control.Concurrent.Async as Async
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Concurrent.STM (atomically, modifyTVar', readTVarIO)
import qualified Control.Exception as E
import Control.Monad (join, replicateM, replicateM_, void, when)
import Data.Aeson ((.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64.URL as B64U
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (toLower)
import Data.Either (isLeft)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Data.List (sort, sortOn)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing, fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.IO as T
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, picosecondsToDiffTime, secondsToDiffTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Data.Word (Word32, Word8)
import GHC.IO.Handle (hDuplicate, hDuplicateTo)
import Network.HTTP.Client (Manager, Request (..), RequestBody (..), Response, defaultManagerSettings, httpLbs, newManager, parseRequest, responseBody, responseHeaders, responseStatus, responseTimeoutMicro)
import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType)
import Network.HTTP.Types.Status (statusCode)
import qualified Network.Wai.Handler.Warp as Warp
import Simplex.Chat.Badges (BadgeType (..))
import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..))
import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..))
import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..), ServicePaymentMethod (..))
import Simplex.Messaging.Agent.Store.Common (DBStore (..), withConnection, withTransaction)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Agent.Store.Interface
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String (textDecode, textEncode)
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
import System.Directory (createDirectoryIfMissing, createFileLink, doesFileExist, listDirectory)
import System.FilePath ((</>))
import System.IO (IOMode (..), hClose, hGetBuffering, hSetBuffering, stderr, withFile)
import System.IO.Unsafe (unsafePerformIO)
import System.Timeout (timeout)
import Test.Hspec
import Text.Read (readMaybe)
import UnliftIO.Temporary (withTempDirectory)

#if defined(dbPostgres)
import BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations)
import ChatClient (testDBConnectInfo, testDBConnstr)
import Database.PostgreSQL.Simple (Only (..))
import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser)
#else
import BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations)
import Data.String (fromString)
import Database.SQLite.Simple (Only (..))
import qualified Database.SQLite.Simple as SQL
import Simplex.Messaging.Agent.Store.DB (TrackQueries (..))
#endif

#if defined(dbPostgres)
withServiceStore :: (DBStore -> IO a) -> IO a
withServiceStore action =
  E.bracket_
    (dropDatabaseAndUser testDBConnectInfo >> createDBAndUserIfNotExists testDBConnectInfo)
    (dropDatabaseAndUser testDBConnectInfo)
    $ do
      Right st <- createDBStore serviceDBOpts badgeServiceSchemaMigrations (MigrationConfig MCError Nothing)
      action st `E.finally` closeDBStore st
  where
    serviceDBOpts =
      DBOpts
        { connstr = BC.pack testDBConnstr,
          schema = "sx_badge_service_web_test",
          poolSize = 4,
          createSchema = True
        }
#else
withServiceStore :: (DBStore -> IO a) -> IO a
withServiceStore action = do
  createDirectoryIfMissing True "tests/tmp"
  withTempDirectory "tests/tmp" "badge-web" $ \dir -> do
    Right st <- createDBStore (DBOpts (dir </> "badge_service_test.db") [] "" False True TQOff) badgeServiceSchemaMigrations (MigrationConfig MCError Nothing)
    action st `E.finally` closeDBStore st
#endif

columnsOf :: DBStore -> Text -> IO [Text]
columnsOf st table = withConnection st $ \db ->
#if defined(dbPostgres)
  map fromOnly
    <$> DB.query
      db
      "SELECT column_name FROM information_schema.columns WHERE table_schema = current_schema() AND table_name = ?"
      (Only table)
#else
  map fromOnly
    <$> DB.query_ db (fromString ("SELECT name FROM pragma_table_info('" ++ T.unpack table ++ "')"))
#endif

badgeWebTests :: Spec
badgeWebTests = do
  describe "badge service schema" $ do
    it "carries the five service-only columns" testServiceColumns
    it "refuses a duplicate provider_ref" testProviderRefUnique
  describe "badge service store" $ do
    it "writes the invoice, its code and their link atomically" testCreationIsAtomic
    it "newInvoiceId is 128 CSPRNG bits, base64url, and two calls differ" testNewInvoiceIdRandom
    it "codeHashExists is true for a hash already written" testCodeHashExists
    it "expireOverdue moves only open, past-expiry rows, and names them" testExpireOverdueMovesOnlyQualifying
    it "expireOverdue moves only the overdue invoices it is given" testExpireOverdueMovesOnlyTheNamed
    it "expireOverdue never sweeps an invoice that has been paid into" testExpireOverdueSparesAFundedInvoice
    it "expireOverdue spares an invoice funded by dust, or by the verdict alone" testExpireOverdueSparesAZeroAmount
    it "readCatalogRows drops every disabled row" testReadCatalogRowsDropsDisabled
    it "a revoked code cannot be redeemed, and a redeemed code cannot be revoked" testRevokeAndRedeemExcludeEachOther
    it "every timestamp round-trips to the second" testTimestampRoundTrip
  describe "badge service catalog seed" $ do
    it "writes the compiled-in catalog into an empty database" testSeedWritesTheCatalog
    it "leaves exactly one row per id when the service starts twice" testSeedIsIdempotent
    it "leaves a price and an offer an operator withdrew withdrawn" testSeedNeverResurrectsAWithdrawnRow
    it "seeds exactly what web/src/catalog.ts compiles into the page" testSeedMatchesWebCatalog
    it "prices a btc checkout, and answers card provider_unavailable" testSeededCatalogSellsSomething
  describe "BadgeService.Providers stub" $ do
    it "constructs a Provider record and records every call, in order" testStubProviderRecordsCalls
    it "makes pCreateInvoice fail on demand, so provider_unavailable is exercisable" testStubProviderCreateFailsOnDemand
    it "records nothing when the caller never reaches the provider" testStubProviderNotCalledWhenSkipped
  describe "badge service web" $ do
    it "serves the shell at / and a hashed asset under /assets" testServesTheBuild
    it "fills the shell's publishable key from the ini at boot" testShellCarriesPublishableKey
    it "caches by where the file is, not by how the request spelled it" testCachingFollowsTheResolvedPath
    it "serves the built web app, exactly as it is shipped" testServesBuiltWebApp
    it "serves no static routes when serve_webapp is off, and still answers the API" testServeWebappOff
    it "exports the injected webapp to a folder for a proxy to serve" testExportWebapp
    it "refuses every traversal spelling, by canonicalisation" testTraversalRefused
    it "answers the read fields, with cryptoCurrency lowercase" testInvoiceView
    it "names the confirmations settlement needs, from the speed policy" testViewNamesTheConfirmationsSettlementNeeds
    it "omits the confirmations where no provider is configured" testViewOmitsConfirmationsWithoutBTCPay
    it "carries the provider's paid-in-full verdict, which the amounts cannot give" testViewCarriesTheProvidersPaidVerdict
    it "never withdraws a paid-in-full verdict on a later read" testPaidVerdictIsNotWithdrawnByALaterRead
    it "answers an unknown id with 404 not_found and nothing else" testUnknownInvoiceIsOpaque
    it "releases a held wait when a payment lands without settling" testHeldWaitWakesOnAPaymentThatDoesNotSettle
    it "leaves a held wait alone when a pass writes nothing" testHeldWaitIsNotWokenByAPassThatWroteNothing
    it "is not woken by the same figures arriving again" testARepeatedSignalDoesNotWakeAHold
    it "carries Cache-Control: no-store on every API response" testApiIsNeverCached
    it "answers a known path reached with the wrong method with 405" testWrongMethodIs405
    it "answers a path this task does not implement with 404" testUnroutedPathIs404
    it "answers ?wait= at once when it is terminal, stale or unparseable" testWaitAnswersAtOnce
    it "answers at once when it holds a payment the page has not seen" testHoldAnswersAPaymentThePageHasNotSeen
    it "answers a verdict that arrived with no figure to go with it" testHoldAnswersAVerdictWithNoFigure
    it "holds ?wait=open, and is woken by publish rather than polled" testHoldIsWokenNotPolled
    it "refuses over sixty reads a minute from one IP" testReadRateLimit
    it "takes the client from X-Forwarded-For only when it is trusted" testForwardedForOnlyWhenTrusted
    it "uses a forwarded client only when it parses as an IP address" testForwardedForMustBeAnAddress
    it "holds the bucket map under its cap through a flood of distinct clients" testBucketsStayBounded
    it "answers a hold from the row it read, not from the status it woke on" testHoldReportsTheRowNotTheWake
    it "answers a hold that timed out with a change nothing published" testHoldTimeoutReportsAnUnpublishedChange
    it "answers a handler exception with 500 internal, and keeps serving" testHandlerExceptionIsContained
  describe "badge service settlement" $ do
    it "settles an open invoice: paid, a settled payment row, and the code" testSettlesAnOpenInvoice
    it "settles an expired invoice, because late settlement is routine" testLateSettlementIsLegal
    it "records what arrived without moving an unsettled invoice" testFundedRecordsWithoutMoving
    it "expires an open invoice whose window closed, recording what arrived" testClosedExpiresAnOpenInvoice
    it "writes no payment for a window that closed on nothing" testClosedWithNothingWritesNoPayment
    it "rewrites the same values when a closed window is redelivered" testClosedReplayIsIdempotent
    it "changes nothing for any signal against a paid invoice" testPaidRefusesEverySignal
    it "takes the larger of the stored and the reported amount" testAmountIsMonotonic
    it "measures the code deadline from the first settlement" testDeadlineIsFromTheFirstSettlement
    it "leaves an invoice another transaction moved first alone" testStatusGuardRefusesAStaleObservation
    it "publishes what it found when it loses the status guard" testLosingTheStatusGuardStillWakesTheHold
    it "never downgrades a settled payment row" testSettledPaymentIsNotDowngraded
    it "fills in a crypto amount that only arrived later" testCryptoAmountFillsInFromNull
    it "answers Left for an invoice this service does not hold" testUnknownInvoiceSettlesNothing
    it "publishes after the commit, so a woken reader finds the row" testPublishIsAfterCommit
    it "wakes a request the listener is holding, from settleOrder itself" testSettlementWakesAHeldRequest
    it "reports settledAt from the payment row, not from the invoice" testSettledAtIsThePaymentRow
    it "refuses a settlement instant the provider cannot have meant" testAbsurdSettledInstantIsRefused
    it "refuses a settlement instant in the future, as a millisecond clock gives" testFutureSettledInstantIsRefused
  describe "badge service poller" $ do
    it "settles a payment with no webhook delivered anywhere" testSettlesWithNoWebhookAtAll
    it "reads only the invoices it is waiting on, and lists on the stray cadence" testPassReadsWhatItAwaits
    it "asks the provider nothing when it is waiting on nothing" testIdlePassAsksNothing
    it "lists instead of reading once too many invoices are open" testManyOpenInvoicesList
    it "sweeps nothing when no provider can account for the rows" testNoProviderAccountsForNothing
    it "holds the sweep for one row a configured provider does not own" testMixedProvidersHoldTheSweep
    it "sends one list for a bulk pass, and none for the next one that reads" testBulkListIsTheOnlyList
    it "hands every signal the pass returned to settleOrder, unless the row answers it" testEverySignalSettles
    it "passes over a listed invoice this service does not hold" testForeignRefIsPassedOver
    it "changes nothing when the provider fails, and settles on the next pass" testProviderFailureLosesNothing
    it "reads the cadence fresh from the waiters each pass" testCadenceFollowsTheWaiters
    it "cuts an idle sleep short when a browser arrives during it" testWaiterCutsTheIdleSleepShort
    it "serves a hint batch without postponing a pass that falls due" testHintsDoNotPostponeThePass
    it "floors the cadence, so a zero in the ini is not a busy loop" testCadenceHasAFloor
    it "wakes a request the listener is holding, from a poller pass" testPollerWakesAHeldRequest
    it "expires an open invoice past the ten-minute grace, and reads before it does" testSweepExpiresPastTheGrace
    it "writes status alone, so a later SigClosed still records what arrived" testSweepWritesStatusAlone
    it "wakes a request held on an invoice it expires" testSweepWakesAHeldRequest
    it "cancels at a provider that keeps its invoice payable, then expires it" testSweepCancelsBeforeExpiring
    it "keeps an invoice open while its provider refuses the cancel" testSweepKeepsOpenWhenCancelFails
    it "settles an invoice past the settle window whose cancel is refused" testSweepSettlesWhatItCannotCancel
    it "expires an invoice whose cancel answer was lost, from the read that follows" testSweepExpiresWhatAReadShowsCancelled
    it "expires an invoice past the settle window once its cancel has failed for an hour, and reports it" testSweepGivesUpPastTheWindow
    it "cancels overdue invoices oldest first, keeping the failures of those left for later" testSweepKeepsFailuresBeyondTheCap
    it "expires an old invoice whose provider is gone, without a call" testSweepExpiresWithoutItsProvider
    it "warns once per order while a cancel keeps failing" testSweepWarnsOncePerOrder
    it "cancels at most a pass-sized batch, leaving the rest for the next pass" testSweepCapsCancelsPerPass
    it "reports a skipped invoice once, and again only after the interval" testSkipWarningsAreRateLimited
    it "warns once for a provider that stays down, not once a pass" testOutageWarnsOnceNotEveryPass
    it "holds the skip log under its cap when every reason is fresh" testSkipReasonsStayBounded
    it "raises a skip naming an invoice this service sold" testSkipNamingOurInvoiceIsRaised
    it "holds the sweep back until a pass has accounted for every invoice" testSweepWaitsForAPassThatSawEverything
    it "settles the rest of the pass around an invoice that throws" testOneBadInvoiceDoesNotStopThePass
    it "pages past a hundred open invoices, a request per hundred" testListPaginates
    it "stops paging at its ceiling rather than looping on a server that ignores take" testPagingStopsAtTheCeiling
  describe "badge service webhook" $ do
    it "verifies a real BTCPay signature over the bytes as received, and queues" testWebhookVerifiesARealSignature
    it "hands the adapter the raw body, byte for byte" testWebhookPassesTheRawBytes
    it "queues a read and answers 200 empty, reaching no provider" testWebhookQueuesARead
    it "settles by the poller's own path, so there is one settlement lane" testWebhookSettlesByThePollerPath
    it "answers at once even when a read at the provider takes a second" testWebhookDoesNotWaitOnTheProvider
    it "answers 400 empty, with no detail, for a signature that does not verify" testWebhookRefusesASignature
    it "answers 200 for an unhandled type, an unknown ref and the other lane's ref" testWebhookIgnoresWhatItCannotActOn
    it "refuses a body over the 64 KB cap before parsing or verifying it" testWebhookRefusesAnOversizedBody
    it "queues a read of an order once, however often it is hinted before being served" testReadHintQueuedOnce
    it "drops a hint rather than blocking when the queue is full" testWebhookDropsAHintWhenFull
    it "answers 200 rather than any 5xx when the adapter or the store throws" testWebhookNeverAnswers5xx
  describe "badge service checkout" $ do
    it "answers the checkout fields and writes the three rows" testCreateInvoice
    it "carries no code and no code hash, over the raw bytes" testCreateCarriesNoCode
    it "tells the provider xmr rather than the chain another request used" testXmrReachesTheProviderAsXmr
    it "derives badgeType, months and amount from the catalog, never from the body" testCreateDerivesFromCatalog
    it "refuses every catalog_changed condition before the provider" testCatalogRefusalCostsNothing
    it "refuses a code_hash already sold before the provider" testCodeConflictCostsNothing
    it "maps a code_hash unique violation that raced the check to 409, not 500" testRacingCodeHashIsConflict
    it "answers 500 and names the abandoned invoice when the store is lost" testStoreLostAfterTheProviderCreated
    it "refuses a malformed body, an unknown method and a malformed codeHash" testBadRequestCostsNothing
    it "refuses a body over the size cap before reading it all" testOversizedBodyCostsNothing
    it "answers method card with provider_unavailable when no Stripe provider is configured" testCardUnconfigured503
    it "answers a provider that failed to create with provider_unavailable, writing nothing" testProviderFailureWritesNothing
    it "refuses the sixth create in a minute, without reaching the provider" testCreateRateLimit
  describe "badge service card" $ do
    it "creates a Stripe PaymentIntent, carrying its clientSecret and a stripe invoice row" testCardCreatesSession
    it "cancels an overdue card order's intent at Stripe before expiring it" testCardSweepCancelsTheIntent
    it "derives the shown expiry from stripe.session_minutes, not the btcpay window" testCardExpiryFollowsSessionMinutes
    it "settles a card invoice from a signed payment_intent.succeeded and a pass" testCardWebhookSettles
  describe "badge service cancel" $ do
    it "expires the invoice here and invalidates it at the provider" testCancelClosesTheInvoiceAtBothEnds
    it "wakes a hold another tab is sitting on" testCancelWakesAHeldRequest
    it "refuses to cancel an invoice that is no longer open" testCancelIsRefusedOnceItIsNotOpen
    it "refuses to cancel an invoice awaiting confirmation" testCancelIsRefusedOnceItIsFunded
    it "leaves the invoice open when the provider refuses" testCancelLeavesTheInvoiceOpenWhenTheProviderFails
    it "expires an invoice a payment landed on while the provider was being told" testCancelExpiresAFundedInvoice
    it "answers an unknown id with the same 404 the read does" testCancelIsOpaqueForAnUnknownInvoice
    it "answers GET with 405 and Allow: POST" testCancelRefusesOtherMethods
  describe "badge service scenarios" $ do
    it "buys a code: create, pay at BTCPay, one pass, paid" scenarioPaidPurchase
    it "wakes a wait held from before the settlement, within a second of it" scenarioHeldWaitWakes
    it "reports a partial payment and leaves the invoice open" scenarioPartPaymentIsReported
    it "reports what an expiry received, and sells no code for it" scenarioExpiryReportsWhatArrived
    it "settles an expired invoice late, because confirmation after expiry is routine" scenarioLateSettlement
    it "changes nothing when the same settlement is seen a second time" scenarioReplayChangesNothing
    it "closes an invalid invoice as expired, on the same screen" scenarioInvalidClosesAsExpired
    it "refuses a second invoice for one code hash, creating none at BTCPay" scenarioCodeConflictCreatesNothing
    it "settles with no webhook delivered, by reading the invoice it is waiting on" scenarioNoWebhookAnywhere

testServiceColumns :: IO ()
testServiceColumns = withServiceStore $ \st -> do
  columnsOf st "sx_badge_service_badge_code_invoices"
    >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["badge_code_id", "provider_ref"])
  columnsOf st "sx_badge_service_payments" >>= (`shouldSatisfy` elem "crypto_paid")
  columnsOf st "sx_badge_service_badge_codes"
    >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["expires_at", "revoked_at"])

testProviderRefUnique :: IO ()
testProviderRefUnique = withServiceStore $ \st -> do
  seedBadgePrice st "price1"
  seedInvoice st "inv1"
  seedInvoice st "inv2"
  insertBadgeCodeInvoice st "inv1" "price1" "same-provider-ref"
  insertBadgeCodeInvoice st "inv2" "price1" "same-provider-ref"
    `shouldThrow` anyException

seedInvoice :: DBStore -> Text -> IO ()
seedInvoice st invoiceId = withConnection st $ \db ->
  DB.execute
    db
    "INSERT INTO sx_badge_service_invoices (invoice_id, provider, price, amount, currency, expires_at, status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
    (invoiceId, "btcpay" :: Text, 500 :: Int, 500 :: Int, "usd" :: Text, "2030-01-01T00:00:00Z" :: Text, "open" :: Text, "2026-08-31T00:00:00Z" :: Text, "2026-08-31T00:00:00Z" :: Text)

seedBadgePrice :: DBStore -> Text -> IO ()
seedBadgePrice st priceId = withConnection st $ \db ->
  DB.execute
    db
    "INSERT INTO sx_badge_service_badge_prices (price_id, badge_type, month_price, currency, status, created_at) VALUES (?,?,?,?,?,?)"
    (priceId, "supporter" :: Text, 500 :: Int, "usd" :: Text, "active" :: Text, "2026-08-31T00:00:00Z" :: Text)

insertBadgeCodeInvoice :: DBStore -> Text -> Text -> Text -> IO ()
insertBadgeCodeInvoice st invoiceId priceId providerRef = withConnection st $ \db -> do
  let codeHash = DB.Binary (digestFixture (fromIntegral (sum (map fromEnum (T.unpack invoiceId)))))
  DB.execute
    db
    "INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)"
    (codeHash, "supporter" :: Text, 1 :: Int, "unpaid" :: Text, "2026-08-31T00:00:00Z" :: Text)
  DB.execute
    db
    "INSERT INTO sx_badge_service_badge_code_invoices (invoice_id, badge_code_id, price_id, created_at, provider_ref) SELECT ?, badge_code_id, ?, ?, ? FROM sx_badge_service_badge_codes WHERE code_hash = ?"
    (invoiceId, priceId, "2026-08-31T00:00:00Z" :: Text, providerRef, codeHash)

someExpiry :: UTCTime
someExpiry = UTCTime (fromGregorian 2030 1 1) 0

someCreated :: UTCTime
someCreated = UTCTime (fromGregorian 2026 8 31) 0

-- | These 32 bytes are all above 0x7f, so the value is not valid UTF-8 and catches the
-- postgresql-simple bug where a plain ByteString is written as escaped text.
digestFixture :: Word8 -> ByteString
digestFixture n = BS.pack [0x80 + ((n * 7 + i) `mod` 0x80) | i <- [0 .. 31]]

sampleInvoice :: NewInvoice
sampleInvoice =
  NewInvoice
    { niInvoiceId = InvoiceId "inv1",
      niProviderRef = "provider-ref-1",
      niCodeHash = digestFixture 1,
      niPriceId = BadgePriceId "price1",
      niOfferId = Nothing,
      niBadgeType = BTSupporter,
      niMonths = 1,
      niPrice = CurrencyAmount 500,
      niAmount = CurrencyAmount 500,
      niCurrency = "usd",
      niProvider = PPCrypto,
      niDestination = SPDCrypto CCBtc "bc1qexampleaddress" "0.00050000",
      niExpiresAt = someExpiry,
      niCreatedAt = someCreated
    }

codeInvoiceRow :: DBStore -> InvoiceId -> IO (Maybe Text)
codeInvoiceRow st (InvoiceId invId) = withConnection st $ \db -> do
  rows <- DB.query db "SELECT invoice_id FROM sx_badge_service_badge_code_invoices WHERE invoice_id = ?" (Only invId) :: IO [Only Text]
  pure $ case rows of
    [] -> Nothing
    (Only r : _) -> Just r

markPaid :: DBStore -> InvoiceId -> IO ()
markPaid st (InvoiceId invId) = withConnection st $ \db ->
  DB.execute db "UPDATE sx_badge_service_invoices SET status = 'paid' WHERE invoice_id = ?" (Only invId)

insertPrice :: DBStore -> Text -> Text -> Int -> Text -> IO ()
insertPrice st priceId badgeType monthPrice status = withConnection st $ \db ->
  DB.execute
    db
    "INSERT INTO sx_badge_service_badge_prices (price_id, badge_type, month_price, currency, status, created_at) VALUES (?,?,?,?,?,?)"
    (priceId, badgeType, monthPrice, "usd" :: Text, status, "2026-08-31T00:00:00Z" :: Text)

insertOffer :: DBStore -> Text -> Maybe Text -> Int -> Int -> Text -> IO ()
insertOffer st offerId priceId months discount status = withConnection st $ \db ->
  DB.execute
    db
    "INSERT INTO sx_badge_service_badge_offers (offer_id, price_id, months, discount, status, created_at) VALUES (?,?,?,?,?,?)"
    (offerId, priceId, months, discount, status, "2026-08-31T00:00:00Z" :: Text)

testCreationIsAtomic :: IO ()
testCreationIsAtomic = withServiceStore $ \st -> do
  seedBadgePrice st "price1"
  let duplicateHash = digestFixture 9
      planted = sampleInvoice {niInvoiceId = InvoiceId "other", niProviderRef = "p-other", niCodeHash = duplicateHash}
      ni = sampleInvoice {niCodeHash = duplicateHash}
  planted' <- createInvoiceRows st planted
  planted' `shouldBe` Right ()
  r <- createInvoiceRows st ni
  r `shouldSatisfy` isLeft
  r `shouldBe` Left CECodeConflict
  getInvoice st (niInvoiceId ni) `shouldReturn` Nothing
  codeInvoiceRow st (niInvoiceId ni) `shouldReturn` Nothing

testNewInvoiceIdRandom :: IO ()
testNewInvoiceIdRandom = do
  InvoiceId a <- newInvoiceId
  InvoiceId b <- newInvoiceId
  a `shouldNotBe` b
  T.length a `shouldBe` 22
  T.any (== '=') a `shouldBe` False

testCodeHashExists :: IO ()
testCodeHashExists = withServiceStore $ \st -> do
  seedBadgePrice st "price1"
  createInvoiceRows st sampleInvoice `shouldReturn` Right ()
  codeHashExists st (niCodeHash sampleInvoice) `shouldReturn` True
  codeHashExists st "no-such-hash" `shouldReturn` False

testExpireOverdueMovesOnlyQualifying :: IO ()
testExpireOverdueMovesOnlyQualifying = withServiceStore $ \st -> do
  seedBadgePrice st "price1"
  now <- getCurrentTime
  let pastExpiry = addUTCTime (-3600) now
      futureExpiry = addUTCTime 3600 now
      overdue = sampleInvoice {niExpiresAt = pastExpiry}
      notYet = sampleInvoice {niInvoiceId = InvoiceId "inv-notyet", niProviderRef = "p-notyet", niCodeHash = digestFixture 13, niExpiresAt = futureExpiry}
      alreadyPaid = sampleInvoice {niInvoiceId = InvoiceId "inv-paid", niProviderRef = "p-paid", niCodeHash = digestFixture 14, niExpiresAt = pastExpiry}
  createInvoiceRows st overdue `shouldReturn` Right ()
  createInvoiceRows st notYet `shouldReturn` Right ()
  createInvoiceRows st alreadyPaid `shouldReturn` Right ()
  markPaid st (niInvoiceId alreadyPaid)
  map (\OverdueInvoice {oiInvoiceId, oiProviderRef} -> (oiInvoiceId, oiProviderRef)) <$> overdueInvoices st now `shouldReturn` [(niInvoiceId overdue, niProviderRef overdue)]
  moved <- expireAllOverdue st now
  moved `shouldBe` [niInvoiceId overdue]
  Just overdueRow <- getInvoice st (niInvoiceId overdue)
  irStatus overdueRow `shouldBe` ISExpired
  Just notYetRow <- getInvoice st (niInvoiceId notYet)
  irStatus notYetRow `shouldBe` ISOpen
  Just paidRow <- getInvoice st (niInvoiceId alreadyPaid)
  irStatus paidRow `shouldBe` ISPaid

testExpireOverdueMovesOnlyTheNamed :: IO ()
testExpireOverdueMovesOnlyTheNamed = withServiceStore $ \st -> do
  seedBadgePrice st "price1"
  now <- getCurrentTime
  let pastExpiry = addUTCTime (-3600) now
      named = sampleInvoice {niExpiresAt = pastExpiry}
      unnamed = sampleInvoice {niInvoiceId = InvoiceId "inv-unnamed", niProviderRef = "p-unnamed", niCodeHash = digestFixture 13, niExpiresAt = pastExpiry}
  createInvoiceRows st named `shouldReturn` Right ()
  createInvoiceRows st unnamed `shouldReturn` Right ()
  expireOverdue st now [niInvoiceId named] `shouldReturn` [niInvoiceId named]
  invoiceStatus st (niInvoiceId named) `shouldReturn` ISExpired
  invoiceStatus st (niInvoiceId unnamed) `shouldReturn` ISOpen
  expireOverdue st now [niInvoiceId named] `shouldReturn` []

expireAllOverdue :: DBStore -> UTCTime -> IO [InvoiceId]
expireAllOverdue st now = overdueInvoices st now >>= expireOverdue st now . map oiInvoiceId

testRevokeAndRedeemExcludeEachOther :: IO ()
testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  (purchaseKey, masterKey) <- newPurchaseKeys
  let newCode codeHash = withTransaction st $ \db -> do
        insertBadgeCode db codeHash BTSupporter 1 CPSPaid now
        maybe (error "the code was not written") (\IssuedCode {badgeCodeId} -> badgeCodeId) <$> getBadgeCode db codeHash
      redeem badgeCodeId = withTransaction st $ \db -> createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now
      revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
      unredeemed codeHash =
        withTransaction st (`getBadgeCode` codeHash) >>= \case
          Just IssuedCode {redemption = CodeUnredeemed} -> pure True
          _ -> pure False
  revokedFirst <- newCode "revoked-first"
  revoke "revoked-first" `shouldReturn` Revoked
  redeem revokedFirst `shouldReturn` Nothing
  unredeemed "revoked-first" `shouldReturn` True
  redeemedFirst <- newCode "redeemed-first"
  isJust <$> redeem redeemedFirst `shouldReturn` True
  revoke "redeemed-first" `shouldReturn` AlreadyRedeemed
  redeem redeemedFirst `shouldReturn` Nothing

testReadCatalogRowsDropsDisabled :: IO ()
testReadCatalogRowsDropsDisabled = withServiceStore $ \st -> do
  insertPrice st "price-active" "supporter" 500 "active"
  insertPrice st "price-disabled" "supporter" 500 "disabled"
  insertOffer st "offer-active" (Just "price-active") 3 10 "active"
  insertOffer st "offer-disabled" (Just "price-active") 3 10 "disabled"
  (prices, offers) <- readCatalogRows st
  map (\BadgePrice {priceId} -> priceId) prices `shouldBe` [BadgePriceId "price-active"]
  map (\BadgeOffer {offerId} -> offerId) offers `shouldBe` [BadgeOfferId "offer-active"]

seedDefaultCatalog :: DBStore -> UTCTime -> IO (Int, Int)
seedDefaultCatalog st at = uncurry (seedCatalog st) (defaultCatalog at)

priceFacts :: BadgePrice -> (Text, Text, Word32, Text, BadgeItemStatus)
priceFacts BadgePrice {priceId = BadgePriceId pId, badgeType = bType, monthPrice = CurrencyAmount mPrice, currency = cur, status = pStatus} =
  (pId, textEncode bType, mPrice, cur, pStatus)

offerFacts :: BadgeOffer -> (Text, Maybe Text, Word8, OfferDiscount, BadgeItemStatus)
offerFacts BadgeOffer {offerId = BadgeOfferId oId, priceId = oPriceId, months = oMonths, discount = oDiscount, status = oStatus} =
  (oId, (\(BadgePriceId p) -> p) <$> oPriceId, oMonths, oDiscount, oStatus)

allPriceRows :: DBStore -> IO [(Text, Text, Word32, Text, Text, UTCTime)]
allPriceRows st = withConnection st $ \db ->
  DB.query_ db "SELECT price_id, badge_type, month_price, currency, status, created_at FROM sx_badge_service_badge_prices ORDER BY price_id"

allOfferRows :: DBStore -> IO [(Text, Maybe Text, Word32, Maybe Word32, Maybe Word32, Text, UTCTime)]
allOfferRows st = withConnection st $ \db ->
  DB.query_ db "SELECT offer_id, price_id, months, free_months, discount, status, created_at FROM sx_badge_service_badge_offers ORDER BY offer_id"

testSeedWritesTheCatalog :: IO ()
testSeedWritesTheCatalog = withServiceStore $ \st -> do
  readCatalogRows st `shouldReturn'` (0, 0)
  seedDefaultCatalog st someCreated `shouldReturn` (2, 4)
  (prices, offers) <- readCatalogRows st
  sortOn (\(i, _, _, _, _) -> i) (map priceFacts prices)
    `shouldBe` [ ("price_legend", "legend", 7000, "usd", BISActive),
                 ("price_supporter", "supporter", 700, "usd", BISActive)
               ]
  sortOn (\(i, _, _, _, _) -> i) (map offerFacts offers)
    `shouldBe` [ ("offer_12m", Just "price_legend", 12, ODDiscount 50, BISActive),
                 ("offer_12m_s", Just "price_supporter", 12, ODDiscount 50, BISActive),
                 ("offer_3m", Just "price_legend", 3, ODFreeMonths 1, BISActive),
                 ("offer_3m_s", Just "price_supporter", 3, ODFreeMonths 1, BISActive)
               ]
  where
    shouldReturn' action expected = do
      (ps, os) <- action
      (length ps, length os) `shouldBe` expected

testSeedIsIdempotent :: IO ()
testSeedIsIdempotent = withServiceStore $ \st -> do
  seedDefaultCatalog st someCreated `shouldReturn` (2, 4)
  let restartedAt = addUTCTime 86400 someCreated
  seedDefaultCatalog st restartedAt `shouldReturn` (0, 0)
  priceRows <- allPriceRows st
  offerRows <- allOfferRows st
  map (\(i, _, _, _, _, _) -> i) priceRows `shouldBe` ["price_legend", "price_supporter"]
  map (\(i, _, _, _, _, _, _) -> i) offerRows `shouldBe` ["offer_12m", "offer_12m_s", "offer_3m", "offer_3m_s"]
  map (\(_, _, _, _, _, at) -> at) priceRows `shouldBe` replicate 2 someCreated
  map (\(_, _, _, _, _, _, at) -> at) offerRows `shouldBe` replicate 4 someCreated

testSeedNeverResurrectsAWithdrawnRow :: IO ()
testSeedNeverResurrectsAWithdrawnRow = withServiceStore $ \st -> do
  insertPrice st "price_supporter" "supporter" 900 "deprecated"
  insertPrice st "price_legend" "legend" 9000 "disabled"
  insertOffer st "offer_12m" (Just "price_legend") 12 25 "disabled"
  seedDefaultCatalog st someCreated `shouldReturn` (0, 3)
  priceRows <- allPriceRows st
  map (\(i, _, mp, _, s, _) -> (i, mp, s)) priceRows
    `shouldBe` [("price_legend", 9000, "disabled"), ("price_supporter", 900, "deprecated")]
  offerRows <- allOfferRows st
  map (\(i, _, m, _, d, s, _) -> (i, m, d, s)) offerRows
    `shouldBe` [ ("offer_12m", 12, Just 25, "disabled"),
                 ("offer_12m_s", 12, Just 50, "active"),
                 ("offer_3m", 3, Nothing, "active"),
                 ("offer_3m_s", 3, Nothing, "active")
               ]
  (prices, offers) <- readCatalogRows st
  sortOn (\(i, _, _, _, _) -> i) (map priceFacts prices)
    `shouldBe` [("price_supporter", "supporter", 900, "usd", BISDeprecated)]
  map (\(i, _, _, _, _) -> i) (sortOn (\(i, _, _, _, _) -> i) (map offerFacts offers))
    `shouldBe` ["offer_12m_s", "offer_3m", "offer_3m_s"]

testSeedMatchesWebCatalog :: IO ()
testSeedMatchesWebCatalog = withServiceStore $ \st -> do
  src <- T.readFile "apps/simplex-badge-service/web/src/catalog.ts"
  (webPrices, webOffers) <- case parseCatalogSource src of
    Nothing -> failWith "could not parse CATALOG out of web/src/catalog.ts -- its shape has changed"
    Just parsed -> pure parsed
  webPrices `shouldNotBe` []
  webOffers `shouldNotBe` []
  seedDefaultCatalog st someCreated `shouldReturn` (length webPrices, length webOffers)
  (prices, offers) <- readCatalogRows st
  sortOn (\(i, _, _, _) -> i) (map (\(i, t, mp, cur, _) -> (i, t, mp, cur)) (map priceFacts prices))
    `shouldBe` sortOn (\(i, _, _, _) -> i) (map (\WebPrice {wpPriceId, wpBadgeType, wpMonthPrice, wpCurrency} -> (wpPriceId, wpBadgeType, wpMonthPrice, wpCurrency)) webPrices)
  sortOn (\(i, _, _, _) -> i) (map (\(i, p, m, d, _) -> (i, p, m, d)) (map offerFacts offers))
    `shouldBe` sortOn (\(i, _, _, _) -> i) (map (\WebOffer {woOfferId, woPriceId, woMonths, woDiscount} -> (woOfferId, Just woPriceId, woMonths, woDiscount)) webOffers)

testSeededCatalogSellsSomething :: IO ()
testSeededCatalogSellsSomething = bounded "seeded catalog sells" $ withSeededCheckout $ \client -> do
  card <- postCreateAs client 1 (createBody "price_legend" (Just "offer_12m") "card" (codeHashText sampleCode))
  statusOf card `shouldBe` 503
  responseBody card `shouldBe` errorBody "provider_unavailable"
  priced <- postCreateAs client 2 (createBody "price_legend" (Just "offer_12m") "btc" (codeHashText sampleCode))
  statusOf priced `shouldBe` 200
  o <- jsonObject priced
  fieldOf o "badgeType" `shouldBe` Just (J.String "legend")
  fieldOf o "months" `shouldBe` Just (J.Number 12)
  fieldOf o "amount" `shouldBe` Just (J.Number 42000)
  fieldOf o "currency" `shouldBe` Just (J.String catalogCurrency)

withSeededCheckout :: (WebClient -> IO a) -> IO a
withSeededCheckout action =
  withServiceStore $ \st -> do
    createDirectoryIfMissing True "tests/tmp"
    withTempDirectory "tests/tmp" "badge-seeded" $ \root -> do
      staticDir <- prepareStaticDir root
      _ <- seedDefaultCatalog st someCreated
      ref <- newIORef (newStubState (Right sampleProviderInvoice))
      let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig}
      withListener [stubProvider ref] True holdMicros st cfg (const action)

testTimestampRoundTrip :: IO ()
testTimestampRoundTrip = withServiceStore $ \st -> do
  seedBadgePrice st "price1"
  let subSecond = UTCTime (fromGregorian 2026 8 31) (picosecondsToDiffTime 12500000000000)
      truncated = UTCTime (fromGregorian 2026 8 31) (picosecondsToDiffTime 12000000000000)
      ni = sampleInvoice {niExpiresAt = subSecond, niCreatedAt = subSecond}
  createInvoiceRows st ni `shouldReturn` Right ()
  Just row <- getInvoice st (niInvoiceId ni)
  irExpiresAt row `shouldBe` truncated
  irCreatedAt row `shouldBe` truncated

data StubCall
  = StubCreate ServicePaymentMethod OrderDraft
  | StubRead Text
  | StubCancel Text
  | StubListOpen
  deriving (Eq, Show)

data StubState = StubState
  { ssCalls :: [StubCall],
    ssCreateResult :: Either ProviderError ProviderInvoice,
    ssInvoices :: Map.Map Text PaymentSignal,
    ssCancelError :: Maybe ProviderError,
    -- The cancel reaches the provider, but its answer is lost.
    ssCancelLost :: Bool,
    ssListError :: Maybe ProviderError,
    ssReadError :: Maybe ProviderError,
    ssSkipped :: [(Maybe Text, Text)],
    ssVerifyResult :: Either WebhookError (Maybe Text),
    ssVerifyThrows :: Bool,
    ssWebhooks :: [([Header], ByteString)],
    ssReadDelay :: Int
  }

newStubState :: Either ProviderError ProviderInvoice -> StubState
newStubState ssCreateResult =
  StubState
    { ssCalls = [],
      ssCreateResult,
      ssInvoices = Map.empty,
      ssCancelError = Nothing,
      ssCancelLost = False,
      ssListError = Nothing,
      ssReadError = Nothing,
      ssSkipped = [],
      ssVerifyResult = Right Nothing,
      ssVerifyThrows = False,
      ssWebhooks = [],
      ssReadDelay = 0
    }

record :: IORef StubState -> StubCall -> IO ()
record ref call = atomicModifyIORef' ref $ \s -> (s {ssCalls = ssCalls s ++ [call]}, ())

stubProvider :: IORef StubState -> Provider
stubProvider ref =
  Provider
    { pProvider = PPCrypto,
      pCreateInvoice = \method draft -> do
        record ref (StubCreate method draft)
        ssCreateResult <$> readIORef ref,
      pReadInvoice = \providerRef -> do
        record ref (StubRead providerRef)
        stub <- readIORef ref
        threadDelay (ssReadDelay stub)
        pure $ maybe (Right (Map.lookup providerRef (ssInvoices stub))) Left (ssReadError stub),
      pCancelInvoice = \providerRef -> do
        record ref (StubCancel providerRef)
        lost <- ssCancelLost <$> readIORef ref
        if lost
          then do
            atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert providerRef (SigClosed (rcv 0 Nothing)) (ssInvoices s)}, ())
            pure (Left (ProviderError "the response was lost"))
          else maybe (Right ()) Left . ssCancelError <$> readIORef ref,
      pListOpen = do
        record ref StubListOpen
        stub <- readIORef ref
        pure $ case ssListError stub of
          Just e -> Left e
          Nothing -> Right ListPass {lpMoved = Map.toList (ssInvoices stub), lpSkipped = ssSkipped stub},
      pVerifyWebhook = const (verifyRecording ref)
    }

-- | 'pVerifyWebhook' is pure by design, so recording its arguments needs 'unsafePerformIO',
-- and the NOINLINE effect is safe because every assertion checks an exact list of calls, so a
-- lost or repeated recording fails the test rather than passing it.
verifyRecording :: IORef StubState -> [Header] -> ByteString -> Either WebhookError (Maybe Text)
verifyRecording ref hdrs body = unsafePerformIO $ do
  atomicModifyIORef' ref $ \s -> (s {ssWebhooks = ssWebhooks s ++ [(hdrs, body)]}, ())
  stub <- readIORef ref
  if ssVerifyThrows stub
    then E.throwIO (userError "the adapter threw while verifying")
    else pure (ssVerifyResult stub)
{-# NOINLINE verifyRecording #-}

stubCalls :: IORef StubState -> IO [StubCall]
stubCalls ref = ssCalls <$> readIORef ref

stubWebhooks :: IORef StubState -> IO [([Header], ByteString)]
stubWebhooks ref = ssWebhooks <$> readIORef ref

setVerifyResult :: IORef StubState -> Either WebhookError (Maybe Text) -> IO ()
setVerifyResult ref r = atomicModifyIORef' ref $ \s -> (s {ssVerifyResult = r}, ())

setReadDelay :: IORef StubState -> Int -> IO ()
setReadDelay ref micros = atomicModifyIORef' ref $ \s -> (s {ssReadDelay = micros}, ())

setVerifyThrows :: IORef StubState -> Bool -> IO ()
setVerifyThrows ref throws = atomicModifyIORef' ref $ \s -> (s {ssVerifyThrows = throws}, ())

sampleDraft :: OrderDraft
sampleDraft = OrderDraft {odAmount = CurrencyAmount 500, odCurrency = "usd"}

sampleProviderInvoice :: ProviderInvoice
sampleProviderInvoice = ProviderInvoice {piProviderRef = "pref-1", piDestination = SPDCrypto CCBtc "bc1qexampleaddress" "0.00050000"}

testStubProviderRecordsCalls :: IO ()
testStubProviderRecordsCalls = do
  ref <- newIORef (newStubState (Right sampleProviderInvoice))
  let provider = stubProvider ref
  created <- pCreateInvoice provider (SPMCrypto CCBtc) sampleDraft
  created `shouldBe` Right sampleProviderInvoice
  let pref = piProviderRef sampleProviderInvoice
  pReadInvoice provider pref `shouldReturn` Right Nothing
  let signal = SigFunded (rcv 500 (Just "0.00050000")) PaidInPart
  atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert pref signal (ssInvoices s)}, ())
  pReadInvoice provider pref `shouldReturn` Right (Just signal)
  pListOpen provider `shouldReturn` Right ListPass {lpMoved = [(pref, signal)], lpSkipped = []}
  calls <- stubCalls ref
  calls `shouldBe` [StubCreate (SPMCrypto CCBtc) sampleDraft, StubRead pref, StubRead pref, StubListOpen]

testStubProviderCreateFailsOnDemand :: IO ()
testStubProviderCreateFailsOnDemand = do
  let err = ProviderError "connection refused"
  ref <- newIORef (newStubState (Left err))
  let provider = stubProvider ref
  pCreateInvoice provider (SPMCrypto CCBtc) sampleDraft `shouldReturn` Left err
  stubCalls ref `shouldReturn` [StubCreate (SPMCrypto CCBtc) sampleDraft]

testStubProviderNotCalledWhenSkipped :: IO ()
testStubProviderNotCalledWhenSkipped = do
  ref <- newIORef (newStubState (Right sampleProviderInvoice))
  stubCalls ref `shouldReturn` []

-- | This ceiling is shorter than the 30s hold, so a test that waits when it should not fails
-- here instead of hanging.
exampleCeiling :: Int
exampleCeiling = 20 * 1000000

bounded :: HasCallStack => String -> IO a -> IO a
bounded label action =
  timeout exampleCeiling action >>= maybe (failWith (label <> ": did not finish within 20s")) pure

clientTimeout :: Int
clientTimeout = 60 * 1000000

failWith :: HasCallStack => String -> IO a
failWith msg = expectationFailure msg >> error msg

outsideMarker :: LB.ByteString
outsideMarker = "SECRET-OUTSIDE-STATIC-DIR"

shellHtml :: LB.ByteString
shellHtml = "<!doctype html><title>SimpleX badges</title><meta id=\"stripe-publishable-key\" name=\"stripe-publishable-key\" content=\"\">"

assetJs :: LB.ByteString
assetJs = "export const build = \"d95503da54ee228f\";"

workerJs :: LB.ByteString
workerJs = "self.addEventListener(\"install\", () => {});"

buildHash :: FilePath
buildHash = "d95503da54ee228f"

notFoundBody :: LB.ByteString
notFoundBody = "{\"error\":\"not_found\"}"

prepareStaticDir :: FilePath -> IO FilePath
prepareStaticDir root = do
  let staticDir = root </> "dist"
      assetDir = staticDir </> "assets" </> buildHash
  createDirectoryIfMissing True assetDir
  LB.writeFile (root </> "secret.txt") outsideMarker
  LB.writeFile (staticDir </> "index.html") shellHtml
  LB.writeFile (staticDir </> "sw.js") workerJs
  LB.writeFile (assetDir </> "main.js") assetJs
  createFileLink (".." </> ".." </> "secret.txt") (staticDir </> "assets" </> "escape.txt")
  pure staticDir

testServiceConfig :: FilePath -> Bool -> ServiceConfig
testServiceConfig staticDir trustForwarded =
  ServiceConfig
    { listener = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = True, lWebappExportDir = Nothing, lTrustForwardedFor = trustForwarded},
      btcpay = Nothing,
      stripe = Nothing,
      poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60},
      issuer = Nothing,
      devChatRedeem = False
    }

testServeWebappOff :: IO ()
testServeWebappOff =
  withServiceStore $ \st -> do
    createDirectoryIfMissing True "tests/tmp"
    withTempDirectory "tests/tmp" "badge-static" $ \root -> do
      staticDir <- prepareStaticDir root
      let base = testServiceConfig staticDir False
          cfg = base {listener = (listener base) {lServeWebapp = False}}
      withListener [] True holdMicros st cfg $ \_env client -> do
        (statusOf <$> webGet client "/") >>= (`shouldBe` 404)
        (statusOf <$> webGet client "/sw.js") >>= (`shouldBe` 404)
        (statusOf <$> webGet client ("/assets/" <> buildHash <> "/main.js")) >>= (`shouldBe` 404)
        created <- webRequest client "POST" "/api/invoice" []
        statusOf created `shouldSatisfy` (\s -> s /= 404 && s /= 405)

testExportWebapp :: IO ()
testExportWebapp = do
  createDirectoryIfMissing True "tests/tmp"
  withTempDirectory "tests/tmp" "badge-export" $ \root -> do
    staticDir <- prepareStaticDir root
    let outDir = root </> "out"
        lc = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = False, lWebappExportDir = Just outDir, lTrustForwardedFor = False}
        stripeCfg = Just StripeConfig {sSecretKey = "rk_test_x", sPublishableKey = "pk_test_injected", sWebhookSecret = "whsec_x", sSessionMinutes = 60, sHost = "https://api.stripe.com"}
    exportWebapp lc stripeCfg
    idx <- LB.readFile (outDir </> "index.html")
    LB.toStrict idx `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\""
    LB.readFile (outDir </> "sw.js") >>= (`shouldBe` workerJs)
    LB.readFile (outDir </> "assets" </> buildHash </> "main.js") >>= (`shouldBe` assetJs)

type WebClient = (Manager, String)

withWebApp :: (WebEnv -> WebClient -> IO a) -> IO a
withWebApp = withWebAppWith False True holdMicros

withWebAppForwarded :: Bool -> (WebEnv -> WebClient -> IO a) -> IO a
withWebAppForwarded trustForwarded = withWebAppWith trustForwarded True holdMicros

withWebAppHolding :: Int -> (WebEnv -> WebClient -> IO a) -> IO a
withWebAppHolding hold = withWebAppWith False True hold

withWebAppExpectingThrow :: (WebEnv -> WebClient -> IO a) -> IO a
withWebAppExpectingThrow = withWebAppWith False False holdMicros

withWebAppWith :: Bool -> Bool -> Int -> (WebEnv -> WebClient -> IO a) -> IO a
withWebAppWith trustForwarded rethrow hold action =
  withServiceStore $ \st -> do
    createDirectoryIfMissing True "tests/tmp"
    withTempDirectory "tests/tmp" "badge-static" $ \root -> do
      staticDir <- prepareStaticDir root
      withListener [] rethrow hold st (testServiceConfig staticDir trustForwarded) action

withListener :: [Provider] -> Bool -> Int -> DBStore -> ServiceConfig -> (WebEnv -> WebClient -> IO a) -> IO a
withListener providers rethrow hold st cfg action = do
  let runner = if rethrow then Warp.testWithApplicationSettings else Warp.withApplicationSettings
  waiters <- newWaiters
  hints <- newReadHints
  built <- newWebEnv st cfg waiters hints providers
  let env = built {weHoldMicros = hold}
  mgr <- newManager defaultManagerSettings
  runner (webSettings (listener cfg)) (pure (webApp env)) $ \prt ->
    action env (mgr, "http://127.0.0.1:" <> show prt)

webRequest :: WebClient -> ByteString -> String -> [Header] -> IO (Response LB.ByteString)
webRequest client verb target hdrs = webRequestBody client verb target hdrs ""

webRequestBody :: WebClient -> ByteString -> String -> [Header] -> LB.ByteString -> IO (Response LB.ByteString)
webRequestBody (mgr, base) verb target hdrs body = do
  req <- parseRequest base
  let (rawPath, rawQuery) = break (== '?') target
  httpLbs
    req
      { method = verb,
        path = BC.pack rawPath,
        queryString = BC.pack rawQuery,
        requestHeaders = hdrs,
        requestBody = RequestBodyLBS body,
        responseTimeout = responseTimeoutMicro clientTimeout
      }
    mgr

webGet :: WebClient -> String -> IO (Response LB.ByteString)
webGet client target = webRequest client "GET" target []

statusOf :: Response LB.ByteString -> Int
statusOf = statusCode . responseStatus

headerOf :: Response LB.ByteString -> HeaderName -> Maybe ByteString
headerOf r name = lookup name (responseHeaders r)

jsonObject :: HasCallStack => Response LB.ByteString -> IO J.Object
jsonObject r = case J.decode (responseBody r) of
  Just (J.Object o) -> pure o
  _ -> failWith ("not a JSON object: " <> LB.unpack (responseBody r))

fieldOf :: J.Object -> Text -> Maybe J.Value
fieldOf o k = KM.lookup (K.fromText k) o

timedGet :: WebClient -> String -> IO (NominalDiffTime, Response LB.ByteString)
timedGet client target = do
  started <- getCurrentTime
  r <- webGet client target
  elapsed <- (`diffUTCTime` started) <$> getCurrentTime
  pure (elapsed, r)

seedOpenInvoice :: HasCallStack => WebEnv -> IO InvoiceId
seedOpenInvoice WebEnv {weStore} = do
  seedBadgePrice weStore "price1"
  createInvoiceRows weStore sampleInvoice `shouldReturn` Right ()
  pure (niInvoiceId sampleInvoice)

wokenBy :: HasCallStack => WebClient -> InvoiceId -> IO () -> Text -> IO J.Object
wokenBy client iid trigger expected = do
  started <- getCurrentTime
  held <- async $ webGet client (invoicePath iid <> "?wait=open")
  threadDelay holdParkDelay
  parked <- Async.poll held
  parked `shouldSatisfy` isNothing
  trigger
  r <- wait held
  elapsed <- (`diffUTCTime` started) <$> getCurrentTime
  statusOf r `shouldBe` 200
  o <- jsonObject r
  fieldOf o "status" `shouldBe` Just (J.String expected)
  elapsed `shouldSatisfy` (< 1)
  pure o

-- | This delay is long enough for the request to reach the hold and short enough to keep the
-- whole check within the one second a woken answer is allowed.
holdParkDelay :: Int
holdParkDelay = 100000

invoicePath :: InvoiceId -> String
invoicePath (InvoiceId iid) = "/api/invoice/" <> T.unpack iid

markPaidAndPublish :: WebEnv -> InvoiceId -> IO ()
markPaidAndPublish WebEnv {weStore, weWaiters} iid = do
  markPaid weStore iid
  atomically $ publish weWaiters iid ISPaid

expireRow :: DBStore -> InvoiceId -> IO ()
expireRow st (InvoiceId iid) = withConnection st $ \db ->
  DB.execute db "UPDATE sx_badge_service_invoices SET status = 'expired' WHERE invoice_id = ?" (Only iid)

breakStore :: DBStore -> IO ()
breakStore st = withConnection st $ \db ->
  DB.execute_ db "DROP TABLE sx_badge_service_badge_code_invoices"

readsPerMinute :: Int
readsPerMinute = lmPerMinute readLimit

testCachingFollowsTheResolvedPath :: IO ()
testCachingFollowsTheResolvedPath = bounded "cache by resolved path" $ withWebApp $ \_ client -> do
  asset <- webGet client ("/assets/" <> buildHash <> "/main.js")
  headerOf asset hCacheControl `shouldBe` Just "public, max-age=31536000, immutable"
  shell <- webGet client "/"
  headerOf shell hCacheControl `shouldBe` Just "no-cache"
  escaped <- webGet client ("/assets/" <> buildHash <> "/%2e%2e/%2e%2e/index.html")
  statusOf escaped `shouldBe` 200
  responseBody escaped `shouldBe` shellHtml
  headerOf escaped hCacheControl `shouldBe` Just "no-cache"

testShellCarriesPublishableKey :: IO ()
testShellCarriesPublishableKey = bounded "shell carries the publishable key" $
  withServiceStore $ \st -> do
    createDirectoryIfMissing True "tests/tmp"
    withTempDirectory "tests/tmp" "badge-static" $ \root -> do
      staticDir <- prepareStaticDir root
      let cfg = (testServiceConfig staticDir True) {stripe = Just publishTestStripe}
      withListener [] True holdMicros st cfg $ \_ client -> do
        shell <- webGet client "/"
        statusOf shell `shouldBe` 200
        LB.toStrict (responseBody shell) `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\""

publishTestStripe :: StripeConfig
publishTestStripe =
  StripeConfig
    { sSecretKey = "rk_test_x",
      sPublishableKey = "pk_test_injected",
      sWebhookSecret = "whsec_x",
      sSessionMinutes = 60,
      sHost = "https://api.stripe.com"
    }

testServesTheBuild :: IO ()
testServesTheBuild = bounded "serves the build" $ withWebApp $ \_ client -> do
  shell <- webGet client "/"
  statusOf shell `shouldBe` 200
  responseBody shell `shouldBe` shellHtml
  headerOf shell hContentType `shouldBe` Just "text/html; charset=utf-8"
  asset <- webGet client ("/assets/" <> buildHash <> "/main.js")
  statusOf asset `shouldBe` 200
  responseBody asset `shouldBe` assetJs
  headerOf asset hContentType `shouldBe` Just "text/javascript; charset=utf-8"
  worker <- webGet client "/sw.js"
  statusOf worker `shouldBe` 200
  responseBody worker `shouldBe` workerJs
  headerOf worker hContentType `shouldBe` Just "text/javascript; charset=utf-8"
  headerOf worker hCacheControl `shouldBe` Just "no-cache"
  missing <- webGet client ("/assets/" <> buildHash <> "/absent.js")
  statusOf missing `shouldBe` 404

builtSiteDir :: FilePath
builtSiteDir = "apps" </> "simplex-badge-service" </> "web" </> "dist"

testServesBuiltWebApp :: IO ()
testServesBuiltWebApp = bounded "built web app" $ withServiceStore $ \st -> do
  built <- doesFileExist (builtSiteDir </> "index.html")
  if not built
    then pendingWith ("no web build at " <> builtSiteDir <> ": run `npm run build` in apps/simplex-badge-service/web")
    else withListener [] True holdMicros st (testServiceConfig builtSiteDir False) $ \_ client -> do
      shell <- webGet client "/"
      statusOf shell `shouldBe` 200
      LB.map toLower (LB.take 9 (responseBody shell)) `shouldBe` "<!doctype"
      hashes <- listDirectory (builtSiteDir </> "assets")
      hashes `shouldSatisfy` not . null
      assets <- concat <$> mapM (\h -> map (h </>) <$> listDirectory (builtSiteDir </> "assets" </> h)) hashes
      assets `shouldSatisfy` not . null
      served <- mapM (\a -> (a,) . statusOf <$> webGet client ("/assets/" <> a)) assets
      served `shouldSatisfy` all ((== 200) . snd)
      worker <- webGet client "/sw.js"
      statusOf worker `shouldBe` 200
      responseBody worker `shouldSatisfy` not . LB.null

traversalSpellings :: [String]
traversalSpellings =
  [ "/assets/../secret.txt",
    "/assets/%2e%2e/secret.txt",
    "/assets/%2e%2e%2fsecret.txt",
    "/assets/..%2fsecret.txt",
    "/assets/./../secret.txt",
    "/assets//../secret.txt",
    "/assets/" <> buildHash <> "/../../../secret.txt",
    "/assets/%2e%2e%2f%2e%2e%2fsecret.txt",
    "/assets/%2fetc%2fpasswd",
    "/assets/%00/../secret.txt",
    "/assets/escape.txt",
    "/%2e%2e%2fsecret.txt"
  ]

testTraversalRefused :: IO ()
testTraversalRefused = bounded "traversal" $ withWebApp $ \_ client -> do
  control <- webGet client ("/assets/" <> buildHash <> "/main.js")
  statusOf control `shouldBe` 200
  mapM_
    ( \target -> do
        r <- webGet client target
        (target, statusOf r) `shouldBe` (target, 404)
        (target, responseBody r) `shouldBe` (target, notFoundBody)
    )
    traversalSpellings

testInvoiceView :: IO ()
testInvoiceView = bounded "invoice view" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  r <- webGet client (invoicePath iid)
  statusOf r `shouldBe` 200
  headerOf r hContentType `shouldBe` Just "application/json"
  o <- jsonObject r
  sort (map K.toText (KM.keys o))
    `shouldBe` sort ["status", "badgeType", "months", "amount", "currency", "expiresAt", "address", "cryptoAmount", "cryptoCurrency"]
  fieldOf o "status" `shouldBe` Just (J.String "open")
  fieldOf o "badgeType" `shouldBe` Just (J.String "supporter")
  fieldOf o "months" `shouldBe` Just (J.Number 1)
  fieldOf o "amount" `shouldBe` Just (J.Number 500)
  fieldOf o "currency" `shouldBe` Just (J.String "usd")
  fieldOf o "address" `shouldBe` Just (J.String "bc1qexampleaddress")
  fieldOf o "cryptoAmount" `shouldBe` Just (J.String "0.00050000")
  fieldOf o "cryptoCurrency" `shouldBe` Just (J.String "btc")
  case fieldOf o "expiresAt" of
    Just (J.String t) -> T.unpack t `shouldStartWith` "2030-01-01T00:00:00"
    other -> expectationFailure ("expiresAt is " <> show other)
  settle (weStore env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
  settled <- webGet client (invoicePath iid)
  po <- jsonObject settled
  fieldOf po "status" `shouldBe` Just (J.String "paid")
  fieldOf po "settledAt" `shouldBe` Just (J.toJSON settleAt)
  fieldOf po "amountPaid" `shouldBe` Just (J.Number 500)
  fieldOf po "cryptoAmountPaid" `shouldBe` Just (J.String "0.00050000")
  fieldOf po "clientSecret" `shouldBe` Nothing

testUnknownInvoiceIsOpaque :: IO ()
testUnknownInvoiceIsOpaque = bounded "unknown id" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  guessed <- webGet client "/api/invoice/no-such-invoice"
  statusOf guessed `shouldBe` 404
  responseBody guessed `shouldBe` notFoundBody
  nearMiss <- webGet client (invoicePath iid <> "x")
  statusOf nearMiss `shouldBe` 404
  responseBody nearMiss `shouldBe` responseBody guessed

testApiIsNeverCached :: IO ()
testApiIsNeverCached = bounded "no-store" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  ok <- webGet client (invoicePath iid)
  statusOf ok `shouldBe` 200
  headerOf ok hCacheControl `shouldBe` Just "no-store"
  missing <- webGet client "/api/invoice/no-such-invoice"
  statusOf missing `shouldBe` 404
  headerOf missing hCacheControl `shouldBe` Just "no-store"
  refused <- exhaustReadLimit client "/api/invoice/no-such-invoice" []
  statusOf refused `shouldBe` 429
  headerOf refused hCacheControl `shouldBe` Just "no-store"

exhaustReadLimit :: HasCallStack => WebClient -> String -> [Header] -> IO (Response LB.ByteString)
exhaustReadLimit client target hdrs = go (readsPerMinute + 5)
  where
    go :: Int -> IO (Response LB.ByteString)
    go 0 = failWith ("no read of " <> target <> " was refused within 65 requests")
    go n = do
      r <- webRequest client "GET" target hdrs
      if statusOf r == 429 then pure r else go (n - 1)

testWrongMethodIs405 :: IO ()
testWrongMethodIs405 = bounded "wrong method" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  postShell <- webRequest client "POST" "/" []
  statusOf postShell `shouldBe` 405
  headerOf postShell "Allow" `shouldBe` Just "GET"
  postWorker <- webRequest client "POST" "/sw.js" []
  statusOf postWorker `shouldBe` 405
  deleteInvoice <- webRequest client "DELETE" (invoicePath iid) []
  statusOf deleteInvoice `shouldBe` 405
  headerOf deleteInvoice hCacheControl `shouldBe` Just "no-store"
  getCreate <- webRequest client "GET" "/api/invoice" []
  statusOf getCreate `shouldBe` 405
  headerOf getCreate "Allow" `shouldBe` Just "POST"

testUnroutedPathIs404 :: IO ()
testUnroutedPathIs404 = bounded "unrouted" $ withWebApp $ \_ client -> do
  nowhere <- webGet client "/nowhere"
  statusOf nowhere `shouldBe` 404
  responseBody nowhere `shouldBe` notFoundBody
  webhook <- webRequest client "POST" "/webhooks/btcpay" []
  statusOf webhook `shouldBe` 400
  responseBody webhook `shouldBe` ""
  wrongMethod <- webGet client "/webhooks/btcpay"
  statusOf wrongMethod `shouldBe` 405
  headerOf wrongMethod "Allow" `shouldBe` Just "POST"

testWaitAnswersAtOnce :: IO ()
testWaitAnswersAtOnce = bounded "wait answers at once" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  (staleElapsed, stale) <- timedGet client (invoicePath iid <> "?wait=expired")
  statusOf stale `shouldBe` 200
  staleObject <- jsonObject stale
  fieldOf staleObject "status" `shouldBe` Just (J.String "open")
  staleElapsed `shouldSatisfy` (< 1)
  (junkElapsed, junk) <- timedGet client (invoicePath iid <> "?wait=not-a-status")
  junkObject <- jsonObject junk
  fieldOf junkObject "status" `shouldBe` Just (J.String "open")
  junkElapsed `shouldSatisfy` (< 1)
  markPaid (weStore env) iid
  (terminalElapsed, terminalR) <- timedGet client (invoicePath iid <> "?wait=paid")
  terminalObject <- jsonObject terminalR
  fieldOf terminalObject "status" `shouldBe` Just (J.String "paid")
  terminalElapsed `shouldSatisfy` (< 1)

testHoldAnswersAPaymentThePageHasNotSeen :: IO ()
testHoldAnswersAPaymentThePageHasNotSeen = bounded "hold sees the payment" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  settle (weStore env) iid (SigFunded (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISOpen
  (staleElapsed, stale) <- timedGet client (invoicePath iid <> "?wait=open&seenPaid=")
  statusOf stale `shouldBe` 200
  staleElapsed `shouldSatisfy` (< 1)
  staleObject <- jsonObject stale
  fieldOf staleObject "cryptoAmountPaid" `shouldBe` Just (J.String "0.00020000")
  held <- async $ webGet client (invoicePath iid <> "?wait=open&seenPaid=0.00020000")
  threadDelay 100000
  Async.poll held >>= (`shouldSatisfy` isNothing)
  markPaidAndPublish env iid
  statusOf <$> wait held `shouldReturn` 200

testHoldAnswersAVerdictWithNoFigure :: IO ()
testHoldAnswersAVerdictWithNoFigure = bounded "hold sees the verdict" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  settle (weStore env) iid (SigFunded (rcv 0 Nothing) PaidInFull) settleAt `shouldReturn` Right ISOpen
  (elapsed, r) <- timedGet client (invoicePath iid <> "?wait=open&seenPaid=&seenFull=0")
  statusOf r `shouldBe` 200
  elapsed `shouldSatisfy` (< 1)
  o <- jsonObject r
  fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)
  fieldOf o "cryptoAmountPaid" `shouldBe` Nothing
  held <- async $ webGet client (invoicePath iid <> "?wait=open&seenPaid=&seenFull=1")
  threadDelay 100000
  Async.poll held >>= (`shouldSatisfy` isNothing)
  markPaidAndPublish env iid
  statusOf <$> wait held `shouldReturn` 200

testHoldIsWokenNotPolled :: IO ()
testHoldIsWokenNotPolled = bounded "hold is woken" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  _ <- wokenBy client iid (markPaidAndPublish env iid) "paid"
  pure ()

testReadRateLimit :: IO ()
testReadRateLimit = bounded "read rate limit" $ withWebApp $ \_ client -> do
  let target = "/api/invoice/no-such-invoice"
  allowed <- mapM (\_ -> statusOf <$> webGet client target) [1 .. readsPerMinute]
  allowed `shouldSatisfy` all (== 404)
  refused <- webGet client target
  statusOf refused `shouldBe` 429
  responseBody refused `shouldBe` "{\"error\":\"rate_limited\"}"
  case headerOf refused "Retry-After" >>= (readMaybe . BC.unpack) of
    Just seconds -> seconds `shouldSatisfy` \s -> s >= (1 :: Int) && s <= 60
    Nothing -> expectationFailure ("Retry-After is " <> show (headerOf refused "Retry-After"))

testForwardedForOnlyWhenTrusted :: IO ()
testForwardedForOnlyWhenTrusted = bounded "forwarded-for" $ do
  let target = "/api/invoice/no-such-invoice"
      forgedBy i = ("X-Forwarded-For", BC.pack ("203.0.113." <> show (i :: Int)) <> ", 10.0.0.1")
      proxiedFor i = ("X-Forwarded-For", BC.pack ("10.0.0." <> show (i :: Int)))
  withWebApp $ \_ client -> do
    forged <- mapM (\i -> statusOf <$> webRequest client "GET" target [forgedBy i]) [1 .. readsPerMinute]
    forged `shouldSatisfy` all (== 404)
    refused <- webRequest client "GET" target [forgedBy (readsPerMinute + 1)]
    statusOf refused `shouldBe` 429
  withWebAppForwarded True $ \_ client -> do
    forged <- mapM (\i -> statusOf <$> webRequest client "GET" target [forgedBy i]) [1 .. readsPerMinute]
    forged `shouldSatisfy` all (== 404)
    refused <- webRequest client "GET" target [forgedBy (readsPerMinute + 1)]
    statusOf refused `shouldBe` 429
  withWebAppForwarded True $ \_ client -> do
    first' <- mapM (\_ -> statusOf <$> webRequest client "GET" target [proxiedFor 1]) [1 .. readsPerMinute]
    first' `shouldSatisfy` all (== 404)
    statusOf <$> webRequest client "GET" target [proxiedFor 1] `shouldReturn` 429
    statusOf <$> webRequest client "GET" target [proxiedFor 2] `shouldReturn` 404

testForwardedForMustBeAnAddress :: IO ()
testForwardedForMustBeAnAddress = bounded "forwarded-for is an address" $ withWebAppForwarded True $ \_ client -> do
  let target = "/api/invoice/no-such-invoice"
      forged i = ("X-Forwarded-For", BC.pack ("not-an-address-" <> show (i :: Int)))
  minted <- mapM (\i -> statusOf <$> webRequest client "GET" target [forged i]) [1 .. readsPerMinute]
  minted `shouldSatisfy` all (== 404)
  refused <- webRequest client "GET" target [forged (readsPerMinute + 1)]
  statusOf refused `shouldBe` 429
  mapM_
    ( \v -> do
        r <- webRequest client "GET" target [("X-Forwarded-For", v)]
        (v, statusOf r) `shouldBe` (v, 429)
    )
    ["", "not-an-address", "010.0.0.1", "1.2.3.4.5", "256.1.1.1", "1.2.3", "::1%eth0", "1:2:3:4:5:6:7", "[2001:db8::1]", "1.2.3.4:5678", "gggg::1", "12345::1"]
  mapM_
    ( \v -> do
        r <- webRequest client "GET" target [("X-Forwarded-For", v)]
        (v, statusOf r) `shouldBe` (v, 404)
    )
    ["192.0.2.7", "2001:db8::1", "::1", "::", "::ffff:192.0.2.1", "1:2:3:4:5:6:7:8"]

testBucketsStayBounded :: IO ()
testBucketsStayBounded = bounded "bucket cap" $ withWebApp $ \env _ -> do
  let clients = map (\i -> T.pack ("198.51." <> show (i `div` 256) <> "." <> show (i `mod` 256))) [1 .. maxBuckets * 2 + 100]
  mapM_ (takeToken env readLimit) clients
  held <- Map.size <$> readTVarIO (weBuckets env)
  held `shouldSatisfy` \n -> n > 0 && n <= maxBuckets
  answers <- mapM (\_ -> takeToken env readLimit "203.0.113.9") [1 .. readsPerMinute + 1]
  length (filter isJust answers) `shouldBe` 1

  let fill i = do
        n <- Map.size <$> readTVarIO (weBuckets env)
        when (n < maxBuckets) $ do
          _ <- takeToken env readLimit (T.pack ("192.0." <> show (i `div` 256) <> "." <> show (i `mod` 256)))
          fill (i + 1)
  fill (1 :: Int)
  atTheCap <- Map.size <$> readTVarIO (weBuckets env)
  atTheCap `shouldBe` maxBuckets
  refusedAgain <- takeToken env readLimit "203.0.113.9"
  refusedAgain `shouldSatisfy` isJust
  afterARefusal <- Map.size <$> readTVarIO (weBuckets env)
  afterARefusal `shouldSatisfy` (<= atTheCap `div` 2 + 1)

testHoldReportsTheRowNotTheWake :: IO ()
testHoldReportsTheRowNotTheWake = bounded "hold reports the row" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  held <- async $ webGet client (invoicePath iid <> "?wait=open")
  threadDelay 100000
  markPaid (weStore env) iid
  atomically $ publish (weWaiters env) iid ISExpired
  r <- wait held
  statusOf r `shouldBe` 200
  o <- jsonObject r
  fieldOf o "status" `shouldBe` Just (J.String "paid")

testHold :: Int
testHold = 2000000

testHoldTimeoutReportsAnUnpublishedChange :: IO ()
testHoldTimeoutReportsAnUnpublishedChange = bounded "hold timeout" $ withWebAppHolding testHold $ \env client -> do
  iid <- seedOpenInvoice env
  started <- getCurrentTime
  held <- async $ webGet client (invoicePath iid <> "?wait=open")
  threadDelay 50000
  expireRow (weStore env) iid
  r <- wait held
  elapsed <- (`diffUTCTime` started) <$> getCurrentTime
  statusOf r `shouldBe` 200
  o <- jsonObject r
  fieldOf o "status" `shouldBe` Just (J.String "expired")
  elapsed `shouldSatisfy` (>= 1.95)

testHandlerExceptionIsContained :: IO ()
testHandlerExceptionIsContained = bounded "handler exception" $ withWebAppExpectingThrow $ \env client -> do
  iid <- seedOpenInvoice env
  breakStore (weStore env)
  r <- webGet client (invoicePath iid)
  statusOf r `shouldBe` 500
  responseBody r `shouldBe` "{\"error\":\"internal\"}"
  headerOf r hCacheControl `shouldBe` Just "no-store"
  shell <- webGet client "/"
  statusOf shell `shouldBe` 200
  responseBody shell `shouldBe` shellHtml

createsPerMinute :: Int
createsPerMinute = 5

testExpiryMinutes :: Int
testExpiryMinutes = 45

testBTCPayConfig :: BTCPayConfig
testBTCPayConfig =
  BTCPayConfig
    { bHost = "https://btcpay.example",
      bApiKey = "api-key",
      bStoreId = "store-id",
      bWebhookSecret = "webhook-secret",
      bExpiryMinutes = testExpiryMinutes,
      bSpeedPolicy = MediumSpeed,
      bPaymentTolerance = 0.5
    }

supporterPriceId, legendPriceId, disabledPriceId :: Text
supporterPriceId = "price-supporter"
legendPriceId = "price-legend"
disabledPriceId = "price-retired"

anyPriceOfferId, legendOnlyOfferId, disabledOfferId :: Text
anyPriceOfferId = "offer-3m"
legendOnlyOfferId = "offer-3m-legend"
disabledOfferId = "offer-retired"

seedCheckoutCatalog :: DBStore -> IO ()
seedCheckoutCatalog st = do
  insertPrice st supporterPriceId "supporter" 500 "active"
  insertPrice st legendPriceId "legend" 2000 "active"
  insertPrice st disabledPriceId "supporter" 500 "disabled"
  insertOffer st anyPriceOfferId Nothing 3 10 "active"
  insertOffer st legendOnlyOfferId (Just legendPriceId) 3 10 "active"
  insertOffer st disabledOfferId Nothing 3 10 "disabled"

codeDigest :: Text -> ByteString
codeDigest = C.sha256Hash . encodeUtf8

codeHashText :: Text -> Text
codeHashText = T.filter (/= '=') . safeDecodeUtf8 . B64U.encode . codeDigest

sampleCode :: Text
sampleCode = "YDC8AYGQTMPUYZ92TUXP"

createBody :: Text -> Maybe Text -> Text -> Text -> LB.ByteString
createBody priceId offerId method codeHash =
  J.encode . J.object $
    ["priceId" .= priceId, "method" .= method, "codeHash" .= codeHash]
      <> maybe [] (\o -> ["offerId" .= o]) offerId

postCreateAs :: WebClient -> Int -> LB.ByteString -> IO (Response LB.ByteString)
postCreateAs client i body =
  webRequestBody
    client
    "POST"
    "/api/invoice"
    [(hContentType, "application/json"), ("X-Forwarded-For", BC.pack ("203.0.113." <> show i))]
    body

withCheckout :: (IORef StubState -> WebEnv -> WebClient -> IO a) -> IO a
withCheckout = withCheckoutProvider stubProvider

withCheckoutProvider :: (IORef StubState -> Provider) -> (IORef StubState -> WebEnv -> WebClient -> IO a) -> IO a
withCheckoutProvider mkProvider action =
  withServiceStore $ \st -> do
    createDirectoryIfMissing True "tests/tmp"
    withTempDirectory "tests/tmp" "badge-checkout" $ \root -> do
      staticDir <- prepareStaticDir root
      seedCheckoutCatalog st
      ref <- newIORef (newStubState (Right sampleProviderInvoice))
      let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig}
      withListener [mkProvider ref] True holdMicros st cfg (action ref)

invoiceCount :: DBStore -> IO Int
invoiceCount st = withConnection st $ \db -> do
  rows <- DB.query_ db "SELECT COUNT(*) FROM sx_badge_service_invoices" :: IO [Only Int]
  pure $ case rows of
    (Only n : _) -> n
    [] -> 0

plantCodeHash :: DBStore -> Text -> IO ()
plantCodeHash st code = withConnection st $ \db ->
  DB.execute
    db
    "INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)"
    (DB.Binary (codeDigest code), "supporter" :: Text, 1 :: Int, "unpaid" :: Text, "2026-08-31T00:00:00Z" :: Text)

stringField :: HasCallStack => J.Object -> Text -> IO Text
stringField o k = case fieldOf o k of
  Just (J.String t) -> pure t
  other -> failWith (T.unpack k <> " is " <> show other)

errorBody :: Text -> LB.ByteString
errorBody code = "{\"error\":\"" <> LB.pack (T.unpack code) <> "\"}"

testCreateInvoice :: IO ()
testCreateInvoice = bounded "create invoice" $ withCheckout $ \ref env client -> do
  started <- getCurrentTime
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
  statusOf r `shouldBe` 200
  headerOf r hContentType `shouldBe` Just "application/json"
  headerOf r hCacheControl `shouldBe` Just "no-store"
  o <- jsonObject r
  sort (map K.toText (KM.keys o))
    `shouldBe` sort ["invoiceId", "badgeType", "months", "amount", "currency", "expiresAt", "address", "cryptoAmount", "cryptoCurrency"]
  fieldOf o "badgeType" `shouldBe` Just (J.String "supporter")
  fieldOf o "months" `shouldBe` Just (J.Number 1)
  fieldOf o "amount" `shouldBe` Just (J.Number 500)
  fieldOf o "currency" `shouldBe` Just (J.String "usd")
  fieldOf o "address" `shouldBe` Just (J.String "bc1qexampleaddress")
  fieldOf o "cryptoAmount" `shouldBe` Just (J.String "0.00050000")
  fieldOf o "cryptoCurrency" `shouldBe` Just (J.String "btc")
  invId <- InvoiceId <$> stringField o "invoiceId"
  Just row <- getInvoice (weStore env) invId
  irStatus row `shouldBe` ISOpen
  irProvider row `shouldBe` PPCrypto
  irProviderRef row `shouldBe` piProviderRef sampleProviderInvoice
  irBadgeType row `shouldBe` BTSupporter
  irMonths row `shouldBe` 1
  irPrice row `shouldBe` CurrencyAmount 500
  irAmount row `shouldBe` CurrencyAmount 500
  irDestination row `shouldBe` piDestination sampleProviderInvoice
  codeRow <- settledCode (weStore env) invId
  bcPaymentStatus codeRow `shouldBe` CPSUnpaid
  fieldOf o "expiresAt" `shouldBe` Just (J.toJSON (irExpiresAt row))
  diffUTCTime (irExpiresAt row) started `shouldSatisfy` \d -> d > 44 * 60 && d <= 46 * 60
  calls <- stubCalls ref
  case calls of
    [StubCreate method draft] -> do
      method `shouldBe` SPMCrypto CCBtc
      odAmount draft `shouldBe` CurrencyAmount 500
      odCurrency draft `shouldBe` "usd"
    other -> expectationFailure ("provider calls: " <> show other)

testXmrReachesTheProviderAsXmr :: IO ()
testXmrReachesTheProviderAsXmr = bounded "xmr is xmr" $ withCheckout $ \ref _ client -> do
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "xmr" (codeHashText sampleCode))
  statusOf r `shouldBe` 200
  stubCalls ref >>= \case
    [StubCreate method _] -> method `shouldBe` SPMCrypto CCXmr
    other -> expectationFailure ("provider calls: " <> show other)

testCreateCarriesNoCode :: IO ()
testCreateCarriesNoCode = bounded "no code in the response" $ withCheckout $ \_ env client -> do
  let hashText = codeHashText sampleCode
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" hashText)
  statusOf r `shouldBe` 200
  let raw = LB.unpack (responseBody r)
  raw `shouldNotContain` T.unpack sampleCode
  raw `shouldNotContain` T.unpack hashText
  raw `shouldNotContain` T.unpack supporterPriceId
  raw `shouldContain` "invoiceId"
  invoiceCount (weStore env) `shouldReturn` 1

testCreateDerivesFromCatalog :: IO ()
testCreateDerivesFromCatalog = bounded "derived from the catalog" $ withCheckout $ \_ env client -> do
  let tampered =
        J.encode $
          J.object
            [ "priceId" .= legendPriceId,
              "offerId" .= anyPriceOfferId,
              "method" .= ("btc" :: Text),
              "codeHash" .= codeHashText sampleCode,
              "badgeType" .= ("supporter" :: Text),
              "months" .= (1 :: Int),
              "amount" .= (500 :: Int)
            ]
  r <- postCreateAs client 1 tampered
  statusOf r `shouldBe` 200
  o <- jsonObject r
  fieldOf o "badgeType" `shouldBe` Just (J.String "legend")
  fieldOf o "months" `shouldBe` Just (J.Number 3)
  fieldOf o "amount" `shouldBe` Just (J.Number 5400)
  invId <- InvoiceId <$> stringField o "invoiceId"
  Just row <- getInvoice (weStore env) invId
  irBadgeType row `shouldBe` BTLegend
  irMonths row `shouldBe` 3
  irPrice row `shouldBe` CurrencyAmount 6000
  irAmount row `shouldBe` CurrencyAmount 5400

testCatalogRefusalCostsNothing :: IO ()
testCatalogRefusalCostsNothing = bounded "catalog refusals" $ withCheckout $ \ref env client -> do
  let cases :: [(String, Text, Maybe Text)]
      cases =
        [ ("an unknown price", "price-that-never-existed", Nothing),
          ("a disabled price", disabledPriceId, Nothing),
          ("an unknown offer", supporterPriceId, Just "offer-that-never-existed"),
          ("a disabled offer", supporterPriceId, Just disabledOfferId),
          ("an offer belonging to another price", supporterPriceId, Just legendOnlyOfferId)
        ]
  mapM_
    ( \(i, (label, priceId, offerId)) -> do
        r <- postCreateAs client i (createBody priceId offerId "btc" (codeHashText sampleCode))
        (label, statusOf r) `shouldBe` (label, 400)
        (label, responseBody r) `shouldBe` (label, errorBody "catalog_changed")
    )
    (zip [30 ..] cases)
  stubCalls ref `shouldReturn` []
  invoiceCount (weStore env) `shouldReturn` 0

testCodeConflictCostsNothing :: IO ()
testCodeConflictCostsNothing = bounded "code conflict" $ withCheckout $ \ref env client -> do
  first <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
  statusOf first `shouldBe` 200
  sold <- stubCalls ref
  length sold `shouldBe` 1
  again <- postCreateAs client 2 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
  statusOf again `shouldBe` 409
  responseBody again `shouldBe` errorBody "code_conflict"
  stubCalls ref `shouldReturn` sold
  invoiceCount (weStore env) `shouldReturn` 1

testRacingCodeHashIsConflict :: IO ()
testRacingCodeHashIsConflict = bounded "racing code hash" $ do
  planted <- newIORef (Nothing :: Maybe DBStore)
  let racing ref =
        let stub = stubProvider ref
         in stub
              { pCreateInvoice = \method draft -> do
                  readIORef planted >>= mapM_ (`plantCodeHash` sampleCode)
                  pCreateInvoice stub method draft
              }
  withCheckoutProvider racing $ \ref env client -> do
    atomicModifyIORef' planted (const (Just (weStore env), ()))
    r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
    statusOf r `shouldBe` 409
    responseBody r `shouldBe` errorBody "code_conflict"
    length <$> stubCalls ref `shouldReturn` 1
    invoiceCount (weStore env) `shouldReturn` 0

testStoreLostAfterTheProviderCreated :: IO ()
testStoreLostAfterTheProviderCreated = bounded "orphan at the provider" $ do
  broken <- newIORef (Nothing :: Maybe DBStore)
  let losing ref =
        let stub = stubProvider ref
         in stub
              { pCreateInvoice = \method draft -> do
                  readIORef broken >>= mapM_ breakStore
                  pCreateInvoice stub method draft
              }
  withCheckoutProvider losing $ \ref env client -> do
    atomicModifyIORef' broken (const (Just (weStore env), ()))
    r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
    statusOf r `shouldBe` 500
    responseBody r `shouldBe` errorBody "internal"
    headerOf r hCacheControl `shouldBe` Just "no-store"
    length <$> stubCalls ref `shouldReturn` 1
    invoiceCount (weStore env) `shouldReturn` 0

testBadRequestCostsNothing :: IO ()
testBadRequestCostsNothing = bounded "bad requests" $ withCheckout $ \ref env client -> do
  let good = codeHashText sampleCode
      bodies :: [(String, LB.ByteString)]
      bodies =
        [ ("not JSON at all", "priceId=price-supporter"),
          ("a JSON array", "[]"),
          ("no fields", "{}"),
          ("no method", J.encode (J.object ["priceId" .= supporterPriceId, "codeHash" .= good])),
          ("no codeHash", J.encode (J.object ["priceId" .= supporterPriceId, "method" .= ("btc" :: Text)])),
          ("no priceId", J.encode (J.object ["method" .= ("btc" :: Text), "codeHash" .= good])),
          ("an unknown method", createBody supporterPriceId Nothing "paypal" good),
          ("a mistyped method", J.encode (J.object ["priceId" .= supporterPriceId, "method" .= (7 :: Int), "codeHash" .= good])),
          ("a mistyped offerId", J.encode (J.object ["priceId" .= supporterPriceId, "offerId" .= (7 :: Int), "method" .= ("btc" :: Text), "codeHash" .= good])),
          ("an empty codeHash", createBody supporterPriceId Nothing "btc" ""),
          ("a hex codeHash", createBody supporterPriceId Nothing "btc" (T.replicate 64 "a")),
          ("a truncated codeHash", createBody supporterPriceId Nothing "btc" (T.dropEnd 1 good)),
          ("a padded codeHash", createBody supporterPriceId Nothing "btc" (good <> "=")),
          ("a codeHash outside base64url", createBody supporterPriceId Nothing "btc" (T.dropEnd 1 good <> "+")),
          ("a non-canonical codeHash", createBody supporterPriceId Nothing "btc" (T.dropEnd 1 good <> "B"))
        ]
  mapM_
    ( \(i, (label, body)) -> do
        r <- postCreateAs client i body
        (label, statusOf r) `shouldBe` (label, 400)
        (label, responseBody r) `shouldBe` (label, errorBody "bad_request")
    )
    (zip [10 ..] bodies)
  stubCalls ref `shouldReturn` []
  invoiceCount (weStore env) `shouldReturn` 0

testOversizedBodyCostsNothing :: IO ()
testOversizedBodyCostsNothing = bounded "oversized body" $ withCheckout $ \ref env client -> do
  let padded =
        J.encode $
          J.object
            [ "priceId" .= supporterPriceId,
              "method" .= ("btc" :: Text),
              "codeHash" .= codeHashText sampleCode,
              "padding" .= T.replicate (64 * 1024) "x"
            ]
  LB.length padded `shouldSatisfy` (> 64 * 1024)
  r <- postCreateAs client 1 padded
  statusOf r `shouldBe` 400
  responseBody r `shouldBe` errorBody "bad_request"
  stubCalls ref `shouldReturn` []
  invoiceCount (weStore env) `shouldReturn` 0
  small <- postCreateAs client 2 (J.encode (J.object ["priceId" .= supporterPriceId, "method" .= ("btc" :: Text), "codeHash" .= codeHashText sampleCode, "padding" .= T.replicate 16 "x"]))
  statusOf small `shouldBe` 200

testCardUnconfigured503 :: IO ()
testCardUnconfigured503 = bounded "card is unavailable" $ withCheckout $ \ref env client -> do
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
  statusOf r `shouldBe` 503
  responseBody r `shouldBe` errorBody "provider_unavailable"
  stubCalls ref `shouldReturn` []
  invoiceCount (weStore env) `shouldReturn` 0

stripeWebhookPath :: String
stripeWebhookPath = "/webhooks/stripe"

postStripeWebhook :: WebClient -> [Header] -> LB.ByteString -> IO (Response LB.ByteString)
postStripeWebhook client hdrs = webRequestBody client "POST" stripeWebhookPath hdrs

signedStripeEvent :: FakeStripe -> Text -> Text -> IO ([Header], LB.ByteString)
signedStripeEvent fake eventType sid = do
  t <- round . utcTimeToPOSIXSeconds <$> getCurrentTime :: IO Int
  let body = stripeEvent eventType sid
  pure (stripeSigHeader (sWebhookSecret (fsConfig fake)) t body, body)

withFakeStripePoller :: (FakeStripe -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
withFakeStripePoller action =
  withFakeStripe $ \fake ->
    withServiceStore $ \st -> do
      createDirectoryIfMissing True "tests/tmp"
      withTempDirectory "tests/tmp" "badge-stripe-fake" $ \root -> do
        staticDir <- prepareStaticDir root
        seedCheckoutCatalog st
        provider <- stripeProvider (fsConfig fake)
        let cfg = (testServiceConfig staticDir True) {stripe = Just (fsConfig fake)}
        withListener [provider] True holdMicros st cfg $ \env client -> do
          poller <- pollerFor env
          action fake poller env client

testCardCreatesSession :: IO ()
testCardCreatesSession = bounded "card creates a session" $ withFakeStripePoller $ \_ _ env client -> do
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
  statusOf r `shouldBe` 200
  headerOf r hContentType `shouldBe` Just "application/json"
  o <- jsonObject r
  fieldOf o "clientSecret" `shouldSatisfy` isJust
  fieldOf o "badgeType" `shouldBe` Just (J.String "supporter")
  invId <- InvoiceId <$> stringField o "invoiceId"
  Just row <- getInvoice (weStore env) invId
  irProvider row `shouldBe` PPStripe
  irStatus row `shouldBe` ISOpen
  bcPaymentStatus <$> settledCode (weStore env) invId `shouldReturn` CPSUnpaid

testCardSweepCancelsTheIntent :: IO ()
testCardSweepCancelsTheIntent = bounded "card sweep cancels" $ withFakeStripePoller $ \fake poller env client -> do
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
  statusOf r `shouldBe` 200
  o <- jsonObject r
  invId@(InvoiceId iid) <- InvoiceId <$> stringField o "invoiceId"
  Just InvoiceRow {irProviderRef = pid} <- getInvoice (weStore env) invId
  past <- addUTCTime (negate (expiryGrace + 60)) <$> getCurrentTime
  withConnection (weStore env) $ \db ->
    DB.execute db "UPDATE sx_badge_service_invoices SET expires_at = ? WHERE invoice_id = ?" (truncateToSecond past, iid)
  runOnePass poller
  fakeIntentStatus fake pid `shouldReturn` Just "canceled"
  invoiceStatus (weStore env) invId `shouldReturn` ISExpired

-- | This value differs from the default 60 and the btcpay window 45, so a card expiry read from
-- the wrong key would show up as one of those instead.
cardSessionMinutes :: Int
cardSessionMinutes = 90

testCardExpiryFollowsSessionMinutes :: IO ()
testCardExpiryFollowsSessionMinutes = bounded "card expiry from session_minutes" $
  withFakeStripe $ \fake ->
    withServiceStore $ \st -> do
      createDirectoryIfMissing True "tests/tmp"
      withTempDirectory "tests/tmp" "badge-stripe-expiry" $ \root -> do
        staticDir <- prepareStaticDir root
        seedCheckoutCatalog st
        let stripeCfg = (fsConfig fake) {sSessionMinutes = cardSessionMinutes}
            cfg = (testServiceConfig staticDir True) {stripe = Just stripeCfg, btcpay = Just testBTCPayConfig}
        provider <- stripeProvider stripeCfg
        withListener [provider] True holdMicros st cfg $ \env client -> do
          r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
          statusOf r `shouldBe` 200
          o <- jsonObject r
          invId <- InvoiceId <$> stringField o "invoiceId"
          Just row <- getInvoice (weStore env) invId
          fieldOf o "expiresAt" `shouldBe` Just (J.toJSON (irExpiresAt row))
          diffUTCTime (irExpiresAt row) (irCreatedAt row) `shouldBe` fromIntegral (cardSessionMinutes * 60)
          diffUTCTime (irExpiresAt row) (irCreatedAt row) `shouldNotBe` fromIntegral (testExpiryMinutes * 60)

testCardWebhookSettles :: IO ()
testCardWebhookSettles = bounded "card webhook settles" $ withFakeStripePoller $ \fake poller env client -> do
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
  statusOf r `shouldBe` 200
  o <- jsonObject r
  iid <- InvoiceId <$> stringField o "invoiceId"
  Just row <- getInvoice (weStore env) iid
  let pid = irProviderRef row
  setIntentState fake pid ["status" .= ("succeeded" :: Text)]
  (hdrs, body) <- signedStripeEvent fake "payment_intent.succeeded" pid
  delivered <- postStripeWebhook client hdrs body
  statusOf delivered `shouldBe` 200
  responseBody delivered `shouldBe` ""
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  drainHints poller
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid
  bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
  ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "settled"

testProviderFailureWritesNothing :: IO ()
testProviderFailureWritesNothing = bounded "provider failure" $ withCheckout $ \ref env client -> do
  atomicModifyIORef' ref $ \s -> (s {ssCreateResult = Left (ProviderError "connection refused")}, ())
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
  statusOf r `shouldBe` 503
  responseBody r `shouldBe` errorBody "provider_unavailable"
  length <$> stubCalls ref `shouldReturn` 1
  invoiceCount (weStore env) `shouldReturn` 0
  codeHashExists (weStore env) (codeDigest sampleCode) `shouldReturn` False

-- | provider_ref is unique, so a test that creates several invoices must vary it as a real
-- provider would.
distinctProviderRefs :: IORef StubState -> Provider
distinctProviderRefs ref =
  let stub = stubProvider ref
   in stub
        { pCreateInvoice = \method draft -> do
            created <- pCreateInvoice stub method draft
            n <- length <$> stubCalls ref
            pure (fmap (\inv -> inv {piProviderRef = piProviderRef inv <> "-" <> T.pack (show n)}) created)
        }

testCreateRateLimit :: IO ()
testCreateRateLimit = bounded "create rate limit" $ withCheckoutProvider distinctProviderRefs $ \ref env client -> do
  let attempt n = postCreateAs client 20 (createBody supporterPriceId Nothing "btc" (codeHashText (sampleCode <> T.pack (show (n :: Int)))))
  allowed <- mapM (fmap statusOf . attempt) [1 .. createsPerMinute]
  allowed `shouldSatisfy` all (== 200)
  refused <- attempt (createsPerMinute + 1)
  statusOf refused `shouldBe` 429
  responseBody refused `shouldBe` errorBody "rate_limited"
  headerOf refused hCacheControl `shouldBe` Just "no-store"
  case headerOf refused "Retry-After" >>= (readMaybe . BC.unpack) of
    Just seconds -> seconds `shouldSatisfy` \s -> s >= (1 :: Int) && s <= 60
    Nothing -> expectationFailure ("Retry-After is " <> show (headerOf refused "Retry-After"))
  length <$> stubCalls ref `shouldReturn` createsPerMinute
  invoiceCount (weStore env) `shouldReturn` createsPerMinute

settleAt :: UTCTime
settleAt = UTCTime (fromGregorian 2026 9 2) (secondsToDiffTime (12 * 3600 + 34 * 60 + 56))

replayAt :: UTCTime
replayAt = addUTCTime 3600 settleAt

-- | The service always learns of settlement later than it happened, so this differs from
-- settleAt, and using one value for both would let a build that wrote the wrong one still pass.
detectedAt :: UTCTime
detectedAt = addUTCTime 300 settleAt

rcv :: Word32 -> Maybe Text -> Received
rcv amount crypto = Received {rcvAmount = CurrencyAmount amount, rcvCrypto = crypto, rcvDue = Nothing}

settle :: DBStore -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus)
settle st iid signal at = newWaiters >>= \waiters -> settleOrder st waiters iid signal at

seedOpen :: HasCallStack => DBStore -> IO InvoiceId
seedOpen st = do
  seedBadgePrice st "price1"
  createInvoiceRows st sampleInvoice `shouldReturn` Right ()
  pure (niInvoiceId sampleInvoice)

invoiceStatus :: HasCallStack => DBStore -> InvoiceId -> IO InvoiceStatus
invoiceStatus st iid = getInvoice st iid >>= maybe (failWith "no invoice row") (pure . irStatus)

paymentRow :: HasCallStack => DBStore -> InvoiceId -> IO InvoicePayment
paymentRow st iid =
  getInvoice st iid >>= \case
    Just InvoiceRow {irPayment = Just p} -> pure p
    _ -> failWith "no payment row"

data CodeRow = CodeRow {bcPaymentStatus :: BadgeCodePaymentStatus, bcExpiresAt :: Maybe UTCTime, bcRevokedAt :: Maybe UTCTime}
  deriving (Eq, Show)

settledCode :: HasCallStack => DBStore -> InvoiceId -> IO CodeRow
settledCode st (InvoiceId iid) = withConnection st $ \db -> do
  rows <-
    DB.query
      db
      "SELECT c.code_payment_status, c.expires_at, c.revoked_at FROM sx_badge_service_badge_codes c JOIN sx_badge_service_badge_code_invoices ci ON ci.badge_code_id = c.badge_code_id WHERE ci.invoice_id = ?"
      (Only iid)
  case rows of
    (status, expiresAt, revokedAt) : _ -> pure CodeRow {bcPaymentStatus = fromMaybe CPSUnpaid (textDecode status), bcExpiresAt = expiresAt, bcRevokedAt = revokedAt}
    [] -> failWith "no badge_codes row"

paymentIdentity :: DBStore -> InvoiceId -> IO [(Text, Text, Maybe Text, Maybe Text)]
paymentIdentity st (InvoiceId iid) = withConnection st $ \db ->
  DB.query db "SELECT payment_id, provider, provider_ref, currency FROM sx_badge_service_payments WHERE invoice_id = ?" (Only iid)

touchInvoice :: DBStore -> InvoiceId -> UTCTime -> IO ()
touchInvoice st (InvoiceId iid) at = withConnection st $ \db ->
  DB.execute db "UPDATE sx_badge_service_invoices SET updated_at = ? WHERE invoice_id = ?" (at, iid)

-- | On SQLite the DBStore serialises access behind one connection, so a read taken through it
-- during a transaction would block rather than see uncommitted state; testPublishIsAfterCommit
-- needs this read to open its own connection instead.
independentStatus :: DBStore -> InvoiceId -> IO (Maybe Text)
#if defined(dbPostgres)
independentStatus st (InvoiceId iid) = withConnection st $ \db -> do
  rows <- DB.query db "SELECT status FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only iid)
  pure $ case rows of
    (Only s : _) -> Just s
    [] -> Nothing
#else
independentStatus DBStore {dbFilePath} (InvoiceId iid) = E.bracket (SQL.open dbFilePath) SQL.close reader `E.catch` locked
  where
    reader c = do
      rows <- SQL.query c "SELECT status FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only iid)
      pure $ case rows of
        (Only s : _) -> Just s
        [] -> Nothing
    locked :: SQL.SQLError -> IO (Maybe Text)
    locked _ = pure Nothing
#endif

-- | This trigger expires the invoice from inside the settling transaction, and it is a trigger
-- rather than a concurrent thread because the SQLite store puts every access behind one
-- connection and so cannot have a concurrent writer.
expireOnNextPayment :: DBStore -> IO ()
#if defined(dbPostgres)
expireOnNextPayment st = withConnection st $ \db -> do
  DB.execute_
    db
    "CREATE FUNCTION sx_badge_service_test_expire() RETURNS trigger AS $$ BEGIN UPDATE sx_badge_service_invoices SET status = 'expired' WHERE invoice_id = NEW.invoice_id; RETURN NEW; END; $$ LANGUAGE plpgsql"
  DB.execute_
    db
    "CREATE TRIGGER sx_badge_service_test_expire_trg AFTER INSERT ON sx_badge_service_payments FOR EACH ROW EXECUTE FUNCTION sx_badge_service_test_expire()"
#else
expireOnNextPayment st = withConnection st $ \db ->
  DB.execute_
    db
    "CREATE TRIGGER sx_badge_service_test_expire AFTER INSERT ON sx_badge_service_payments BEGIN UPDATE sx_badge_service_invoices SET status = 'expired' WHERE invoice_id = NEW.invoice_id; END"
#endif

testSettlesAnOpenInvoice :: IO ()
testSettlesAnOpenInvoice = bounded "settles an open invoice" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  settle st iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
  invoiceStatus st iid `shouldReturn` ISPaid
  p <- paymentRow st iid
  ipAmount p `shouldBe` Just (CurrencyAmount 500)
  ipCryptoPaid p `shouldBe` Just "0.00050000"
  ipStatus p `shouldBe` "settled"
  ipUpdatedAt p `shouldBe` settleAt
  ipUpdatedAt p `shouldNotBe` detectedAt
  paymentIdentity st iid `shouldReturn` [("inv1", "crypto", Just (niProviderRef sampleInvoice), Just "usd")]
  code <- settledCode st iid
  bcPaymentStatus code `shouldBe` CPSPaid
  bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime settleAt)
  bcExpiresAt code `shouldNotBe` Just (addUTCTime codeLifetime detectedAt)
  bcRevokedAt code `shouldBe` Nothing

testLateSettlementIsLegal :: IO ()
testLateSettlementIsLegal = bounded "late settlement" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  expireRow st iid
  invoiceStatus st iid `shouldReturn` ISExpired
  settle st iid (SigSettled (rcv 500 Nothing) settleAt) detectedAt `shouldReturn` Right ISPaid
  invoiceStatus st iid `shouldReturn` ISPaid
  ipStatus <$> paymentRow st iid `shouldReturn` "settled"
  bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSPaid

testFundedRecordsWithoutMoving :: IO ()
testFundedRecordsWithoutMoving = bounded "funded records only" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  settle st iid (SigFunded (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISOpen
  invoiceStatus st iid `shouldReturn` ISOpen
  p <- paymentRow st iid
  ipAmount p `shouldBe` Just (CurrencyAmount 200)
  ipStatus p `shouldBe` "pending"
  code <- settledCode st iid
  bcPaymentStatus code `shouldBe` CPSUnpaid
  bcExpiresAt code `shouldBe` Nothing
  expireRow st iid
  settle st iid (SigFunded (rcv 300 (Just "0.00030000")) PaidInPart) replayAt `shouldReturn` Right ISExpired
  invoiceStatus st iid `shouldReturn` ISExpired
  ipAmount <$> paymentRow st iid `shouldReturn` Just (CurrencyAmount 300)
  bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSUnpaid

testClosedExpiresAnOpenInvoice :: IO ()
testClosedExpiresAnOpenInvoice = bounded "closed expires" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) settleAt `shouldReturn` Right ISExpired
  invoiceStatus st iid `shouldReturn` ISExpired
  p <- paymentRow st iid
  ipAmount p `shouldBe` Just (CurrencyAmount 200)
  ipStatus p `shouldBe` "pending"
  bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSUnpaid

testClosedWithNothingWritesNoPayment :: IO ()
testClosedWithNothingWritesNoPayment = bounded "closed on nothing" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  settle st iid (SigClosed (rcv 0 Nothing)) settleAt `shouldReturn` Right ISExpired
  invoiceStatus st iid `shouldReturn` ISExpired
  Just row <- getInvoice st iid
  irPayment row `shouldBe` Nothing
  bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSUnpaid

testClosedReplayIsIdempotent :: IO ()
testClosedReplayIsIdempotent = bounded "closed replay" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) settleAt `shouldReturn` Right ISExpired
  settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) replayAt `shouldReturn` Right ISExpired
  invoiceStatus st iid `shouldReturn` ISExpired
  p <- paymentRow st iid
  ipAmount p `shouldBe` Just (CurrencyAmount 200)
  ipCryptoPaid p `shouldBe` Just "0.00020000"
  ipStatus p `shouldBe` "pending"
  length <$> paymentIdentity st iid `shouldReturn` 1

testPaidRefusesEverySignal :: IO ()
testPaidRefusesEverySignal = bounded "paid refuses" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  settle st iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
  settled <- paymentRow st iid
  deadline <- bcExpiresAt <$> settledCode st iid
  mapM_
    ( \signal -> do
        settle st iid signal replayAt `shouldReturn` Right ISPaid
        (signal, ) <$> paymentRow st iid `shouldReturn` (signal, settled)
    )
    [ SigSettled (rcv 900 (Just "0.00090000")) replayAt,
      SigFunded (rcv 900 (Just "0.00090000")) PaidInPart,
      SigClosed (rcv 900 (Just "0.00090000"))
    ]
  invoiceStatus st iid `shouldReturn` ISPaid
  bcExpiresAt <$> settledCode st iid `shouldReturn` deadline

testAmountIsMonotonic :: IO ()
testAmountIsMonotonic = bounded "monotonic amount" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  settle st iid (SigFunded (rcv 40000 (Just "0.734")) PaidInPart) settleAt `shouldReturn` Right ISOpen
  settle st iid (SigFunded (rcv 10000 (Just "0.180")) PaidInPart) replayAt `shouldReturn` Right ISOpen
  p <- paymentRow st iid
  ipAmount p `shouldBe` Just (CurrencyAmount 40000)
  ipCryptoPaid p `shouldBe` Just "0.734"
  settle st iid (SigFunded (rcv 40000 (Just "0.734")) PaidInPart) replayAt `shouldReturn` Right ISOpen
  settle st iid (SigFunded (rcv 40000 (Just "0.734")) PaidInPart) replayAt `shouldReturn` Right ISOpen
  ipAmount <$> paymentRow st iid `shouldReturn` Just (CurrencyAmount 40000)
  settle st iid (SigFunded (rcv 50000 (Just "0.900")) PaidInPart) replayAt `shouldReturn` Right ISOpen
  p' <- paymentRow st iid
  ipAmount p' `shouldBe` Just (CurrencyAmount 50000)
  ipCryptoPaid p' `shouldBe` Just "0.900"

testDeadlineIsFromTheFirstSettlement :: IO ()
testDeadlineIsFromTheFirstSettlement = bounded "deadline from the first settlement" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  settle st iid (SigSettled (rcv 500 Nothing) settleAt) detectedAt `shouldReturn` Right ISPaid
  let firstDeadline = addUTCTime codeLifetime settleAt
  bcExpiresAt <$> settledCode st iid `shouldReturn` Just firstDeadline
  withTransaction st $ \db -> markCodePaid db (niCodeHash sampleInvoice) (addUTCTime codeLifetime replayAt)
  bcExpiresAt <$> settledCode st iid `shouldReturn` Just firstDeadline
  bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSPaid

testStatusGuardRefusesAStaleObservation :: IO ()
testStatusGuardRefusesAStaleObservation = bounded "stale observation" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  markPaid st iid
  stale <- withTransaction st $ \db -> updateInvoiceStatus db iid ISOpen ISExpired settleAt
  stale `shouldBe` False
  invoiceStatus st iid `shouldReturn` ISPaid
  let second' = sampleInvoice {niInvoiceId = InvoiceId "inv-2", niProviderRef = "p-2", niCodeHash = digestFixture 15}
  createInvoiceRows st second' `shouldReturn` Right ()
  moved <- withTransaction st $ \db -> updateInvoiceStatus db (niInvoiceId second') ISOpen ISExpired settleAt
  moved `shouldBe` True
  invoiceStatus st (niInvoiceId second') `shouldReturn` ISExpired

testUnknownInvoiceSettlesNothing :: IO ()
testUnknownInvoiceSettlesNothing = bounded "unknown invoice" $ withServiceStore $ \st -> do
  _ <- seedOpen st
  r <- settle st (InvoiceId "no-such-invoice") (SigSettled (rcv 500 Nothing) settleAt) settleAt
  r `shouldSatisfy` isLeft
  paymentIdentity st (InvoiceId "no-such-invoice") `shouldReturn` []

testPublishIsAfterCommit :: IO ()
testPublishIsAfterCommit = bounded "publish after commit" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  waiters <- newWaiters
  seen <- newEmptyMVar
  _ <- forkIO $ do
    woken <- awaitStatus waiters iid ((\s -> (s, ("", False))) <$> invoiceStatus st iid) (ISOpen, ("", False)) waitCeiling
    visible <- independentStatus st iid
    putMVar seen (woken, visible)
  threadDelay 100000
  settleOrder st waiters iid (SigSettled (rcv 500 Nothing) settleAt) settleAt `shouldReturn` Right ISPaid
  takeMVar seen `shouldReturn` (ISPaid, Just "paid")

waitCeiling :: Int
waitCeiling = 10 * 1000000

testSettlementWakesAHeldRequest :: IO ()
testSettlementWakesAHeldRequest = bounded "settlement wakes a hold" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  let settled =
        settleOrder (weStore env) (weWaiters env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) settleAt
          `shouldReturn` Right ISPaid
  o <- wokenBy client iid settled "paid"
  fieldOf o "amountPaid" `shouldBe` Just (J.Number 500)

testFutureSettledInstantIsRefused :: IO ()
testFutureSettledInstantIsRefused = bounded "future settled instant" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  let inMilliseconds = posixSecondsToUTCTime (1000 * utcTimeToPOSIXSeconds detectedAt)
  settle (weStore env) iid (SigSettled (rcv 500 (Just "0.00050000")) inMilliseconds) detectedAt
    `shouldReturn` Right ISPaid
  code <- settledCode (weStore env) iid
  bcPaymentStatus code `shouldBe` CPSPaid
  bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime detectedAt)
  o <- jsonObject =<< webGet client (invoicePath iid)
  fieldOf o "settledAt" `shouldBe` Just (J.toJSON detectedAt)

testAbsurdSettledInstantIsRefused :: IO ()
testAbsurdSettledInstantIsRefused = bounded "absurd settled instant" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  let epochZero = posixSecondsToUTCTime 0
  settle (weStore env) iid (SigSettled (rcv 500 (Just "0.00050000")) epochZero) detectedAt
    `shouldReturn` Right ISPaid
  code <- settledCode (weStore env) iid
  bcPaymentStatus code `shouldBe` CPSPaid
  bcExpiresAt code `shouldSatisfy` maybe False (> detectedAt)
  o <- jsonObject =<< webGet client (invoicePath iid)
  fieldOf o "status" `shouldBe` Just (J.String "paid")
  fieldOf o "settledAt" `shouldBe` Just (J.toJSON detectedAt)

testSettledAtIsThePaymentRow :: IO ()
testSettledAtIsThePaymentRow = bounded "settledAt" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  settle (weStore env) iid (SigSettled (rcv 500 Nothing) settleAt) detectedAt `shouldReturn` Right ISPaid
  o <- jsonObject =<< webGet client (invoicePath iid)
  fieldOf o "status" `shouldBe` Just (J.String "paid")
  fieldOf o "settledAt" `shouldBe` Just (J.toJSON settleAt)
  fieldOf o "settledAt" `shouldNotBe` Just (J.toJSON someCreated)
  fieldOf o "settledAt" `shouldNotBe` Just (J.toJSON detectedAt)
  touchInvoice (weStore env) iid replayAt
  o' <- jsonObject =<< webGet client (invoicePath iid)
  fieldOf o' "settledAt" `shouldBe` Just (J.toJSON settleAt)

testLosingTheStatusGuardStillWakesTheHold :: IO ()
testLosingTheStatusGuardStillWakesTheHold = bounded "losing the guard" $ withWebAppHolding raceHold $ \env client -> do
  iid <- seedOpenInvoice env
  expireOnNextPayment (weStore env)
  _ <- wokenBy client iid (settledIntoAnExpiredRow env iid) "expired"
  pure ()

settledIntoAnExpiredRow :: HasCallStack => WebEnv -> InvoiceId -> IO ()
settledIntoAnExpiredRow env iid = do
  settleOrder (weStore env) (weWaiters env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) settleAt
    `shouldReturn` Right ISExpired
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  code <- settledCode (weStore env) iid
  bcPaymentStatus code `shouldBe` CPSUnpaid
  bcExpiresAt code `shouldBe` Nothing
  ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "settled"

raceHold :: Int
raceHold = 3 * 1000000

testSettledPaymentIsNotDowngraded :: IO ()
testSettledPaymentIsNotDowngraded = bounded "settled is not downgraded" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  row <- getInvoice st iid >>= maybe (failWith "no invoice row") pure
  withTransaction st $ \db -> upsertPayment db row PSSettled (CurrencyAmount 500) (Just "0.00050000") Nothing False settleAt
  withTransaction st $ \db -> upsertPayment db row PSPending (CurrencyAmount 200) (Just "0.00020000") Nothing False replayAt
  p <- paymentRow st iid
  ipStatus p `shouldBe` "settled"
  ipUpdatedAt p `shouldBe` settleAt
  ipAmount p `shouldBe` Just (CurrencyAmount 500)
  ipCryptoPaid p `shouldBe` Just "0.00050000"
  let second' = sampleInvoice {niInvoiceId = InvoiceId "inv-pending", niProviderRef = "p-pending", niCodeHash = digestFixture 16}
  createInvoiceRows st second' `shouldReturn` Right ()
  row' <- getInvoice st (niInvoiceId second') >>= maybe (failWith "no invoice row") pure
  withTransaction st $ \db -> upsertPayment db row' PSPending (CurrencyAmount 100) Nothing Nothing False settleAt
  withTransaction st $ \db -> upsertPayment db row' PSSettled (CurrencyAmount 500) (Just "0.00050000") Nothing False replayAt
  p' <- paymentRow st (niInvoiceId second')
  ipStatus p' `shouldBe` "settled"
  ipUpdatedAt p' `shouldBe` replayAt

testCryptoAmountFillsInFromNull :: IO ()
testCryptoAmountFillsInFromNull = bounded "crypto fills in" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  settle st iid (SigFunded (rcv 500 Nothing) PaidInPart) settleAt `shouldReturn` Right ISOpen
  ipCryptoPaid <$> paymentRow st iid `shouldReturn` Nothing
  settle st iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
  ipCryptoPaid <$> paymentRow st iid `shouldReturn` Just "0.00050000"
  ipAmount <$> paymentRow st iid `shouldReturn` Just (CurrencyAmount 500)

pollerFor :: WebEnv -> IO PollerEnv
pollerFor WebEnv {weStore, weConfig, weWaiters, weHints, weProviders} =
  newPollerEnv weStore weWaiters weHints weProviders (poll weConfig)

withStubPoller :: Int -> (IORef StubState -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
withStubPoller = withStubPollerOf stubProvider

withStubPollerOf :: (IORef StubState -> Provider) -> Int -> (IORef StubState -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
withStubPollerOf mkProvider hold action =
  withServiceStore $ \st -> do
    createDirectoryIfMissing True "tests/tmp"
    withTempDirectory "tests/tmp" "badge-poller" $ \root -> do
      staticDir <- prepareStaticDir root
      ref <- newIORef (newStubState (Right sampleProviderInvoice))
      let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig}
      withListener [mkProvider ref] True hold st cfg $ \env client -> do
        poller <- pollerFor env
        action ref poller env client

withFakePoller :: (FakeBTCPay -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
withFakePoller = withFakePollerHolding holdMicros

withFakePollerHolding :: Int -> (FakeBTCPay -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
withFakePollerHolding hold action =
  withFakeBTCPay $ \fake ->
    withServiceStore $ \st -> do
      createDirectoryIfMissing True "tests/tmp"
      withTempDirectory "tests/tmp" "badge-poller-fake" $ \root -> do
        staticDir <- prepareStaticDir root
        seedCheckoutCatalog st
        provider <- btcpayProvider (fbConfig fake)
        let cfg = (testServiceConfig staticDir True) {btcpay = Just (fbConfig fake)}
        withListener [provider] True hold st cfg $ \env client -> do
          poller <- pollerFor env
          action fake poller env client

withFakeProvider :: (FakeBTCPay -> Provider -> IO a) -> IO a
withFakeProvider action = withFakeBTCPay $ \fake -> btcpayProvider (fbConfig fake) >>= action fake

setSignals :: IORef StubState -> [(Text, PaymentSignal)] -> IO ()
setSignals ref signals = atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.fromList signals}, ())

clearCalls :: IORef StubState -> IO ()
clearCalls ref = atomicModifyIORef' ref $ \s -> (s {ssCalls = []}, ())

setSkipped :: IORef StubState -> [(Maybe Text, Text)] -> IO ()
setSkipped ref reasons = atomicModifyIORef' ref $ \s -> (s {ssSkipped = reasons}, ())

failList :: IORef StubState -> Maybe ProviderError -> IO ()
failList ref e = atomicModifyIORef' ref $ \s -> (s {ssListError = e}, ())

failRead :: IORef StubState -> Maybe ProviderError -> IO ()
failRead ref e = atomicModifyIORef' ref $ \s -> (s {ssReadError = e}, ())

seedOpenRef :: HasCallStack => DBStore -> Int -> Text -> UTCTime -> IO InvoiceId
seedOpenRef = seedOpenRefOf PPCrypto

seedOpenRefOf :: HasCallStack => PaymentProvider -> DBStore -> Int -> Text -> UTCTime -> IO InvoiceId
seedOpenRefOf provider st i providerRef expiresAt = do
  -- The row is created at the current time because the poller reads only invoices inside its
  -- recent settle window and sweeps anything older.
  createdAt <- truncateToSecond <$> getCurrentTime
  let n = T.pack (show i)
      iid = InvoiceId ("inv-poll-" <> n)
      ni =
        sampleInvoice
          { niInvoiceId = iid,
            niProviderRef = providerRef,
            niCodeHash = digestFixture (fromIntegral i + 20),
            niExpiresAt = expiresAt,
            niCreatedAt = createdAt,
            niProvider = provider
          }
  createInvoiceRows st ni `shouldReturn` Right ()
  pure iid

seedOtherProvider :: HasCallStack => DBStore -> Int -> Text -> IO InvoiceId
seedOtherProvider st i providerRef = do
  createdAt <- truncateToSecond <$> getCurrentTime
  let n = T.pack (show i)
      iid = InvoiceId ("inv-poll-" <> n)
      ni =
        sampleInvoice
          { niInvoiceId = iid,
            niProviderRef = providerRef,
            niCodeHash = digestFixture (fromIntegral i + 40),
            niProvider = PPStripe,
            niCreatedAt = createdAt
          }
  createInvoiceRows st ni `shouldReturn` Right ()
  pure iid

settledSignal :: PaymentSignal
settledSignal = SigSettled (rcv 500 (Just "0.00050000")) settleAt

testSettlesWithNoWebhookAtAll :: IO ()
testSettlesWithNoWebhookAtAll = bounded "no webhook at all" $ withFakePoller $ \fake poller env client -> do
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "xmr" (codeHashText sampleCode))
  statusOf r `shouldBe` 200
  o <- jsonObject r
  iid <- InvoiceId <$> stringField o "invoiceId"
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
  Just row <- getInvoice (weStore env) iid
  setInvoiceState fake (irProviderRef row) ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.32095000" :: Text)]
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid
  code <- settledCode (weStore env) iid
  bcPaymentStatus code `shouldBe` CPSPaid
  bcExpiresAt code `shouldSatisfy` isJust
  p <- paymentRow (weStore env) iid
  ipStatus p `shouldBe` "settled"
  ipAmount p `shouldBe` Just (CurrencyAmount 5400)
  ipCryptoPaid p `shouldBe` Just "0.32095000"

testPassReadsWhatItAwaits :: IO ()
testPassReadsWhatItAwaits = bounded "reads what it awaits" $ withStubPoller raceHold $ \ref poller env _ -> do
  seedBadgePrice (weStore env) "price1"
  a <- seedOpenRef (weStore env) 1 "p-1" someExpiry
  b <- seedOpenRef (weStore env) 2 "p-2" someExpiry
  c <- seedOpenRef (weStore env) 3 "p-3" someExpiry
  setSignals ref [("p-1", settledSignal), ("p-2", settledSignal), ("p-3", settledSignal)]
  runOnePass poller
  stubCalls ref `shouldReturn` [StubRead "p-1", StubRead "p-2", StubRead "p-3", StubListOpen]
  mapM (invoiceStatus (weStore env)) [a, b, c] `shouldReturn` [ISPaid, ISPaid, ISPaid]

testIdlePassAsksNothing :: IO ()
testIdlePassAsksNothing = bounded "idle pass" $ withStubPoller raceHold $ \ref poller env _ -> do
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRef (weStore env) 1 "p-1" someExpiry
  setSignals ref [("p-1", settledSignal)]
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid
  clearCalls ref
  runOnePass poller
  stubCalls ref `shouldReturn` []

testManyOpenInvoicesList :: IO ()
testManyOpenInvoicesList = bounded "many open" $ withStubPoller raceHold $ \ref poller env _ -> do
  seedBadgePrice (weStore env) "price1"
  mapM_ (\i -> seedOpenRef (weStore env) i ("p-many-" <> tshow i) someExpiry) [1 .. readsPerPass + 1]
  runOnePass poller
  stubCalls ref `shouldReturn` [StubListOpen]

testNoProviderAccountsForNothing :: HasCallStack => IO ()
testNoProviderAccountsForNothing = bounded "no provider" $ withStubPoller raceHold $ \_ poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  let overdue i = seedOpenRef (weStore env) i ("p-none-" <> tshow i) (addUTCTime (negate (expiryGrace + 60)) now)
  few <- mapM overdue [1 .. 3]
  let blind = poller {peProviders = []}
  runOnePass blind
  mapM (invoiceStatus (weStore env)) few `shouldReturn` replicate 3 ISOpen
  many <- mapM overdue [4 .. readsPerPass + 4]
  runOnePass blind
  mapM (invoiceStatus (weStore env)) (few <> many) `shouldReturn` replicate (length few + length many) ISOpen

testBulkListIsTheOnlyList :: HasCallStack => IO ()
testBulkListIsTheOnlyList = bounded "bulk lists once" $ withStubPoller raceHold $ \ref poller env _ -> do
  seedBadgePrice (weStore env) "price1"
  mapM_ (\i -> seedOpenRef (weStore env) i ("p-cadence-" <> tshow i) someExpiry) [1 .. readsPerPass + 1]
  setSignals ref [("p-cadence-" <> tshow i, settledSignal) | i <- [1 .. readsPerPass]]
  runOnePass poller
  stubCalls ref `shouldReturn` [StubListOpen]
  clearCalls ref
  runOnePass poller
  calls <- stubCalls ref
  filter (== StubListOpen) calls `shouldBe` []

testMixedProvidersHoldTheSweep :: HasCallStack => IO ()
testMixedProvidersHoldTheSweep = bounded "mixed providers" $ withStubPoller raceHold $ \_ poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  mapM_ (\i -> seedOpenRef (weStore env) i ("p-mixed-" <> tshow i) someExpiry) [1 .. readsPerPass + 1]
  createdAt <- truncateToSecond <$> getCurrentTime
  let iid = InvoiceId "inv-poll-stripe"
      stripeRow =
        sampleInvoice
          { niInvoiceId = iid,
            niProviderRef = "p-stripe-mixed",
            niCodeHash = digestFixture 99,
            niProvider = PPStripe,
            niExpiresAt = addUTCTime (negate (expiryGrace + 60)) now,
            niCreatedAt = createdAt
          }
  createInvoiceRows (weStore env) stripeRow `shouldReturn` Right ()
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen

testEverySignalSettles :: IO ()
testEverySignalSettles = bounded "every signal settles" $ withStubPoller raceHold $ \ref poller env _ -> do
  seedBadgePrice (weStore env) "price1"
  paid <- seedOpenRef (weStore env) 1 "p-settled" someExpiry
  funded <- seedOpenRef (weStore env) 2 "p-funded" someExpiry
  closed <- seedOpenRef (weStore env) 3 "p-closed" someExpiry
  setSignals
    ref
    [ ("p-settled", settledSignal),
      ("p-funded", SigFunded (rcv 200 (Just "0.00020000")) PaidInPart),
      ("p-closed", SigClosed (rcv 100 (Just "0.00010000")))
    ]
  runOnePass poller
  invoiceStatus (weStore env) paid `shouldReturn` ISPaid
  invoiceStatus (weStore env) funded `shouldReturn` ISOpen
  ipAmount <$> paymentRow (weStore env) funded `shouldReturn` Just (CurrencyAmount 200)
  invoiceStatus (weStore env) closed `shouldReturn` ISExpired
  ipCryptoPaid <$> paymentRow (weStore env) closed `shouldReturn` Just "0.00010000"
  bcPaymentStatus <$> settledCode (weStore env) paid `shouldReturn` CPSPaid
  bcPaymentStatus <$> settledCode (weStore env) funded `shouldReturn` CPSUnpaid
  bcPaymentStatus <$> settledCode (weStore env) closed `shouldReturn` CPSUnpaid

testForeignRefIsPassedOver :: IO ()
testForeignRefIsPassedOver = bounded "foreign ref" $ withStubPoller raceHold $ \ref poller env _ -> do
  seedBadgePrice (weStore env) "price1"
  ours <- seedOpenRef (weStore env) 1 "p-1" someExpiry
  otherLane <- seedOtherProvider (weStore env) 2 "p-stripe"
  setSignals ref [("p-1", settledSignal), ("someone-elses-invoice", settledSignal), ("p-stripe", settledSignal)]
  runOnePass poller
  invoiceStatus (weStore env) ours `shouldReturn` ISPaid
  invoiceStatus (weStore env) otherLane `shouldReturn` ISOpen
  invoiceCount (weStore env) `shouldReturn` 2

testProviderFailureLosesNothing :: IO ()
testProviderFailureLosesNothing = bounded "provider outage" $ withStubPoller raceHold $ \ref poller env _ -> do
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRef (weStore env) 1 "p-1" someExpiry
  setSignals ref [("p-1", settledSignal)]
  failList ref (Just (ProviderError "connection refused"))
  failRead ref (Just (ProviderError "connection refused"))
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  Just row <- getInvoice (weStore env) iid
  irPayment row `shouldBe` Nothing
  bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
  failList ref Nothing
  failRead ref Nothing
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid
  stubCalls ref `shouldReturn` [StubRead "p-1", StubListOpen, StubRead "p-1"]

testCadenceFollowsTheWaiters :: IO ()
testCadenceFollowsTheWaiters = bounded "cadence" $ withStubPoller raceHold $ \_ poller env client -> do
  iid <- seedOpenInvoice env
  let PollConfig {pWaitingSeconds, pIdleSeconds} = poll (weConfig env)
  pWaitingSeconds `shouldNotBe` pIdleSeconds
  waitingCount (weWaiters env) `shouldReturn` 0
  passDelayNow poller `shouldReturn` (pIdleSeconds * 1000000)
  held <- async $ webGet client (invoicePath iid <> "?wait=open")
  threadDelay 100000
  passDelayNow poller `shouldReturn` (pWaitingSeconds * 1000000)
  waitingCount (weWaiters env) `shouldReturn` 1
  markPaidAndPublish env iid
  _ <- wait held
  passDelayNow poller `shouldReturn` (pIdleSeconds * 1000000)

passDelayNow :: PollerEnv -> IO Int
passDelayNow PollerEnv {peWaiters, pePoll} = passDelay pePoll <$> waitingCount peWaiters

testHintsDoNotPostponeThePass :: IO ()
testHintsDoNotPostponeThePass = bounded "hints do not postpone the pass" $ withStubPoller raceHold $ \ref _ env _ -> do
  seedBadgePrice (weStore env) "price1"
  mapM_ (\i -> seedOpenRef (weStore env) i (burstRef i) someExpiry) burstRefs
  built <- newPollerEnv (weStore env) (weWaiters env) (weHints env) (weProviders env) PollConfig {pWaitingSeconds = 1, pIdleSeconds = 1}
  let poller = built {peStrayEvery = 0}
  setSignals ref [(burstRef i, settledSignal) | i <- burstRefs]
  runOnePass poller
  clearCalls ref
  setReadDelay ref slowHintRead
  mapM_ (\i -> queueReadHint (weHints env) (burstRef i) `shouldReturn` True) burstRefs
  Async.withAsync (runPoller poller) $ \_ -> do
    calls <- awaitCalls ref (\cs -> length (filter (== StubListOpen) cs) >= 2)
    length (filter isRead calls) `shouldSatisfy` (< length burstRefs)
  where
    isRead = \case
      StubRead _ -> True
      _ -> False

burstRefs :: [Int]
burstRefs = [1 .. 10]

burstRef :: Int -> Text
burstRef i = "p-burst-" <> T.pack (show i)

slowHintRead :: Int
slowHintRead = 300000

awaitCalls :: IORef StubState -> ([StubCall] -> Bool) -> IO [StubCall]
awaitCalls ref p = do
  calls <- stubCalls ref
  if p calls then pure calls else threadDelay 10000 >> awaitCalls ref p

testWaiterCutsTheIdleSleepShort :: IO ()
testWaiterCutsTheIdleSleepShort = bounded "waiter cuts the sleep" $ withStubPoller raceHold $ \_ _ env client -> do
  iid <- seedOpenInvoice env
  poller <- newPollerEnv (weStore env) (weWaiters env) (weHints env) (weProviders env) PollConfig {pWaitingSeconds = 1, pIdleSeconds = 10}
  started <- getCurrentTime
  slept <- async (passDue poller >>= atomically)
  threadDelay 200000
  Async.poll slept >>= (`shouldSatisfy` isNothing)
  held <- async $ webGet client (invoicePath iid <> "?wait=open")
  wait slept
  elapsed <- (`diffUTCTime` started) <$> getCurrentTime
  elapsed `shouldSatisfy` (< 5)
  elapsed `shouldSatisfy` (>= 0.9)
  markPaidAndPublish env iid
  _ <- wait held
  pure ()

testCadenceHasAFloor :: IO ()
testCadenceHasAFloor = do
  let zeroed = PollConfig {pWaitingSeconds = 0, pIdleSeconds = 0}
      negated = PollConfig {pWaitingSeconds = -5, pIdleSeconds = -60}
  map (passDelay zeroed) [1, 0] `shouldBe` [1000000, 1000000]
  map (passDelay negated) [1, 0] `shouldBe` [1000000, 1000000]
  map (passDelay PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60}) [1, 0] `shouldBe` [3000000, 60000000]

testPollerWakesAHeldRequest :: IO ()
testPollerWakesAHeldRequest = bounded "poller wakes a hold" $ withStubPoller raceHold $ \ref poller env client -> do
  iid <- seedOpenInvoice env
  setSignals ref [(niProviderRef sampleInvoice, settledSignal)]
  _ <- wokenBy client iid (runOnePass poller) "paid"
  pure ()

testSweepExpiresPastTheGrace :: IO ()
testSweepExpiresPastTheGrace = bounded "expiry sweep" $ withStubPoller raceHold $ \ref poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  overdue <- seedOpenRef (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
  inGrace <- seedOpenRef (weStore env) 2 "p-ingrace" (addUTCTime (negate (expiryGrace - 60)) now)
  ahead <- seedOpenRef (weStore env) 3 "p-ahead" (addUTCTime 3600 now)
  runOnePass poller
  invoiceStatus (weStore env) overdue `shouldReturn` ISExpired
  invoiceStatus (weStore env) inGrace `shouldReturn` ISOpen
  invoiceStatus (weStore env) ahead `shouldReturn` ISOpen
  stubCalls ref `shouldReturn` [StubRead "p-overdue", StubRead "p-ingrace", StubRead "p-ahead", StubListOpen]

testSweepWritesStatusAlone :: IO ()
testSweepWritesStatusAlone = bounded "sweep writes status alone" $ withStubPoller raceHold $ \ref poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRef (weStore env) 1 "p-1" (addUTCTime (negate (expiryGrace + 60)) now)
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  Just row <- getInvoice (weStore env) iid
  irPayment row `shouldBe` Nothing
  setSignals ref [("p-1", SigClosed (rcv 200 (Just "0.00020000")))]
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  p <- paymentRow (weStore env) iid
  ipAmount p `shouldBe` Just (CurrencyAmount 200)
  ipCryptoPaid p `shouldBe` Just "0.00020000"

testSweepWakesAHeldRequest :: IO ()
testSweepWakesAHeldRequest = bounded "sweep wakes a hold" $ withStubPoller raceHold $ \_ poller env client -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRef (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
  _ <- wokenBy client iid (runOnePass poller) "expired"
  pure ()

withPayableStubPoller :: Int -> (IORef StubState -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
withPayableStubPoller = withStubPollerOf (\ref -> (stubProvider ref) {pProvider = PPStripe})

-- | Creates an order older than 72 hours, which only the expiry sweep still looks at. A higher i is newer.
seedPastWindow :: HasCallStack => DBStore -> Int -> Text -> PaymentProvider -> IO InvoiceId
seedPastWindow st i providerRef provider = do
  now <- truncateToSecond <$> getCurrentTime
  let createdAt = addUTCTime (negate (settleWindow + 3600) + fromIntegral i) now
      iid = InvoiceId ("inv-old-" <> T.pack (show i))
      ni = sampleInvoice {niInvoiceId = iid, niProviderRef = providerRef, niProvider = provider, niCodeHash = digestFixture (fromIntegral i + 60), niCreatedAt = createdAt, niExpiresAt = addUTCTime 3600 createdAt}
  createInvoiceRows st ni `shouldReturn` Right ()
  pure iid

-- | Runs one pass to get the list call out of the way, so the next pass only does the expiry sweep.
passListing :: IORef StubState -> PollerEnv -> IO ()
passListing ref poller = runOnePass poller >> clearCalls ref

-- hDuplicateTo changes stderr's buffering, so put the original setting back.
capturingStderr :: IO () -> IO Text
capturingStderr action = do
  createDirectoryIfMissing True "tests/tmp"
  withTempDirectory "tests/tmp" "badge-stderr" $ \dir -> do
    let path = dir </> "stderr.log"
    withFile path WriteMode $ \h -> do
      buffering <- hGetBuffering stderr
      saved <- hDuplicate stderr
      (hDuplicateTo h stderr >> action) `E.finally` (hDuplicateTo saved stderr >> hClose saved >> hSetBuffering stderr buffering)
    T.readFile path

loggedError :: Text -> Text -> Bool
loggedError message = any (\l -> "[ERROR " `T.isPrefixOf` l && message `T.isInfixOf` l) . T.lines

failCancels :: IORef StubState -> IO ()
failCancels ref = atomicModifyIORef' ref $ \s -> (s {ssCancelError = Just (ProviderError "refused")}, ())

testSweepCancelsBeforeExpiring :: IO ()
testSweepCancelsBeforeExpiring = bounded "sweep cancels" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  overdue <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
  ahead <- seedOpenRefOf PPStripe (weStore env) 2 "p-ahead" (addUTCTime 3600 now)
  runOnePass poller
  invoiceStatus (weStore env) overdue `shouldReturn` ISExpired
  invoiceStatus (weStore env) ahead `shouldReturn` ISOpen
  stubCalls ref `shouldReturn` [StubRead "p-overdue", StubRead "p-ahead", StubListOpen, StubCancel "p-overdue"]

testSweepKeepsOpenWhenCancelFails :: IO ()
testSweepKeepsOpenWhenCancelFails = bounded "sweep cancel fails" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
  failCancels ref
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  atomicModifyIORef' ref $ \s -> (s {ssCancelError = Nothing}, ())
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  filter (== StubCancel "p-overdue") <$> stubCalls ref `shouldReturn` [StubCancel "p-overdue", StubCancel "p-overdue"]

testSweepSettlesWhatItCannotCancel :: IO ()
testSweepSettlesWhatItCannotCancel = bounded "sweep settles uncancelled" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
  passListing ref poller
  seedBadgePrice (weStore env) "price1"
  iid <- seedPastWindow (weStore env) 1 "p-old" PPStripe
  failCancels ref
  setSignals ref [("p-old", settledSignal)]
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid
  stubCalls ref `shouldReturn` [StubCancel "p-old", StubRead "p-old"]

testSweepExpiresWhatAReadShowsCancelled :: IO ()
testSweepExpiresWhatAReadShowsCancelled = bounded "sweep reads a cancel" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
  atomicModifyIORef' ref $ \s -> (s {ssCancelLost = True}, ())
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  stubCalls ref `shouldReturn` [StubRead "p-overdue", StubListOpen, StubCancel "p-overdue", StubRead "p-overdue"]

testSweepGivesUpPastTheWindow :: IO ()
testSweepGivesUpPastTheWindow = bounded "sweep gives up" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
  passListing ref poller
  seedBadgePrice (weStore env) "price1"
  iid <- seedPastWindow (weStore env) 1 "p-old" PPStripe
  failCancels ref
  firstLog <- capturingStderr (runOnePass poller >> runOnePass poller)
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  firstLog `shouldNotSatisfy` T.isInfixOf "expired here only"
  failedAnHourAgo poller "p-old"
  lastLog <- capturingStderr (runOnePass poller)
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  loggedError "invoice p-old could not be cancelled at the provider, so it was expired here only" lastLog `shouldBe` True
  let attempt = [StubCancel "p-old", StubRead "p-old"]
  stubCalls ref `shouldReturn` concat (replicate 3 attempt)
  runOnePass poller
  stubCalls ref `shouldReturn` concat (replicate 3 attempt)

testSweepExpiresWithoutItsProvider :: IO ()
testSweepExpiresWithoutItsProvider = bounded "sweep without provider" $ withStubPoller raceHold $ \ref poller env _ -> do
  passListing ref poller
  seedBadgePrice (weStore env) "price1"
  iid <- seedPastWindow (weStore env) 1 "p-old" PPStripe
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  failedAnHourAgo poller "p-old"
  logged <- capturingStderr (runOnePass poller)
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  loggedError "no provider is configured for it" logged `shouldBe` True
  stubCalls ref `shouldReturn` []

testSweepKeepsFailuresBeyondTheCap :: IO ()
testSweepKeepsFailuresBeyondTheCap = bounded "sweep keeps failures past the cap" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
  passListing ref poller
  seedBadgePrice (weStore env) "price1"
  let count = readsPerPass + 1
      newest = "p-" <> T.pack (show count)
  mapM_ (\i -> seedPastWindow (weStore env) i ("p-" <> T.pack (show i)) PPStripe) [1 .. count]
  failCancels ref
  failedAnHourAgo poller newest
  runOnePass poller
  stubCalls ref >>= (`shouldNotSatisfy` elem (StubCancel newest))
  Map.member newest <$> readTVarIO (peCancelFailed poller) `shouldReturn` True

-- | Pretends the first cancel failure was an hour ago, so the test doesn't have to wait.
failedAnHourAgo :: PollerEnv -> Text -> IO ()
failedAnHourAgo PollerEnv {peCancelFailed} ref = do
  now <- getCurrentTime
  atomically $ modifyTVar' peCancelFailed (Map.insert ref (addUTCTime (negate cancelGiveUpDelay) now))

testSweepWarnsOncePerOrder :: IO ()
testSweepWarnsOncePerOrder = bounded "sweep warns once" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
  failCancels ref
  let warnings = Map.filterWithKey (\k _ -> "p-overdue" `T.isInfixOf` k) <$> readTVarIO (peSkipped poller)
  runOnePass poller
  first <- warnings
  Map.size first `shouldBe` 1
  runOnePass poller
  warnings `shouldReturn` first
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen

testSweepCapsCancelsPerPass :: IO ()
testSweepCapsCancelsPerPass = bounded "sweep caps cancels" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  let count = readsPerPass + 1
  iids <- mapM (\i -> seedOpenRefOf PPStripe (weStore env) i ("p-" <> T.pack (show i)) (addUTCTime (negate (expiryGrace + 60)) now)) [1 .. count]
  let cancels = length . filter isCancel <$> stubCalls ref
      isCancel = \case
        StubCancel _ -> True
        _ -> False
      expiredCount = length . filter (== ISExpired) <$> mapM (invoiceStatus (weStore env)) iids
  runOnePass poller
  cancels `shouldReturn` readsPerPass
  expiredCount `shouldReturn` readsPerPass
  runOnePass poller
  cancels `shouldReturn` count
  expiredCount `shouldReturn` count

testSkipWarningsAreRateLimited :: IO ()
testSkipWarningsAreRateLimited = bounded "skip warnings" $ withStubPoller raceHold $ \ref poller env _ -> do
  let reason = "btcpay invoice SOMEONEELSESINVOICE: unknown status Frobnicated"
      onwards t = addUTCTime t settleAt
  dueToWarn poller settleAt reason `shouldReturn` True
  dueToWarn poller (onwards 3) reason `shouldReturn` False
  dueToWarn poller (onwards (skipWarnInterval - 1)) reason `shouldReturn` False
  dueToWarn poller (onwards skipWarnInterval) reason `shouldReturn` True
  dueToWarn poller (onwards skipWarnInterval) "btcpay invoice OTHER: unknown status Frobnicated" `shouldReturn` True
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRef (weStore env) 1 "p-1" someExpiry
  setSkipped ref [(Just "SOMEONEELSESINVOICE", reason)]
  setSignals ref [("p-1", settledSignal)]
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid

testSkipNamingOurInvoiceIsRaised :: IO ()
testSkipNamingOurInvoiceIsRaised = bounded "skip ownership" $ withStubPoller raceHold $ \ref poller env _ -> do
  seedBadgePrice (weStore env) "price1"
  _ <- seedOpenRef (weStore env) 1 "p-ours" someExpiry
  skipOwner poller PPCrypto (Just "p-ours") `shouldReturn` SkipOurs
  skipOwner poller PPCrypto (Just "SOMEONEELSESINVOICE") `shouldReturn` SkipStranger
  skipOwner poller PPCrypto Nothing `shouldReturn` SkipUnaccounted
  _ <- seedOtherProvider (weStore env) 3 "p-stripe-skip"
  skipOwner poller PPCrypto (Just "p-stripe-skip") `shouldReturn` SkipStranger
  iid <- seedOpenRef (weStore env) 2 "p-2" someExpiry
  setSkipped
    ref
    [ (Just "p-ours", "btcpay invoice p-ours: unknown status Frobnicated"),
      (Just "SOMEONEELSESINVOICE", "btcpay invoice SOMEONEELSESINVOICE: unknown status Frobnicated")
    ]
  setSignals ref [("p-2", settledSignal)]
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid

testSkipReasonsStayBounded :: IO ()
testSkipReasonsStayBounded = bounded "skip reasons bounded" $ withStubPoller raceHold $ \ref poller _ _ -> do
  let reasons n = [(Just ("p-" <> tshow i), "btcpay invoice p-" <> tshow i <> ": unknown method") | i <- [1 .. n :: Int]]
  setSkipped ref (reasons (maxSkipReasons + 500))
  runOnePass poller
  held <- Map.size <$> readTVarIO (peSkipped poller)
  held `shouldSatisfy` (<= maxSkipReasons)

-- | The failure text carries the whole request, whose window moves with the clock, so the two
-- messages differ only in startDate to prove the limiter key ignores it rather than warning
-- every pass.
testOutageWarnsOnceNotEveryPass :: IO ()
testOutageWarnsOnceNotEveryPass = bounded "outage warnings" $ withStubPoller raceHold $ \ref poller _ _ -> do
  let warnKeys PollerEnv {peSkipped} = Map.size <$> readTVarIO peSkipped
  failList ref (Just (ProviderError "list invoices failed: ... startDate=1000000 ..."))
  runOnePass poller
  warnKeys poller `shouldReturn` 1
  failList ref (Just (ProviderError "list invoices failed: ... startDate=1000003 ..."))
  runOnePass poller
  warnKeys poller `shouldReturn` 1

testOneBadInvoiceDoesNotStopThePass :: IO ()
testOneBadInvoiceDoesNotStopThePass = bounded "one bad invoice" $ withStubPoller raceHold $ \ref poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  InvoiceId badId <- seedOpenRef (weStore env) 1 "p-bad" (addUTCTime 3600 now)
  good <- seedOpenRef (weStore env) 2 "p-good" (addUTCTime 3600 now)
  overdue <- seedOpenRef (weStore env) 3 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
  -- Setting the provider to a value this build does not know makes reading the row throw rather
  -- than answer.
  withConnection (weStore env) $ \db ->
    DB.execute db "UPDATE sx_badge_service_invoices SET provider = ? WHERE invoice_id = ?" ("nonsense" :: Text, badId)

  setSignals ref [("p-bad", settledSignal), ("p-good", settledSignal)]
  runOnePass poller
  invoiceStatus (weStore env) good `shouldReturn` ISPaid
  invoiceStatus (weStore env) overdue `shouldReturn` ISOpen

  setSignals ref []
  setSkipped ref [(Just "p-bad", "some reason the provider gave")]
  runOnePass poller
  invoiceStatus (weStore env) overdue `shouldReturn` ISOpen

testSweepWaitsForAPassThatSawEverything :: IO ()
testSweepWaitsForAPassThatSawEverything = bounded "sweep guards" $ withStubPoller raceHold $ \ref poller env _ -> do
  now <- getCurrentTime
  seedBadgePrice (weStore env) "price1"
  overdue <- seedOpenRef (weStore env) 1 "p-overdue" (addUTCTime (-3600) now)
  let stillOpen :: Text -> IO ()
      stillOpen why = do
        runOnePass poller
        (why, ) <$> invoiceStatus (weStore env) overdue `shouldReturn` (why, ISOpen)
  failRead ref (Just (ProviderError "connection refused"))
  stillOpen "the reads never answered"
  failRead ref Nothing
  mapM_ (\i -> seedOpenRef (weStore env) i ("p-bulk-" <> tshow i) someExpiry) [2 .. readsPerPass + 2]
  setSkipped ref [(Just "p-overdue", "btcpay invoice p-overdue: unknown status Frobnicated")]
  stillOpen "it answered and left one of ours unread"
  setSkipped ref [(Nothing, "btcpay: the list stopped at 50 pages")]
  stillOpen "it stopped early without saying whose invoices it missed"
  setSkipped ref []
  runOnePass poller
  invoiceStatus (weStore env) overdue `shouldReturn` ISExpired

testListPaginates :: IO ()
testListPaginates = bounded "paging" $ withFakeProvider $ \fake p -> do
  refs <- replicateM (listPageSize + 1) (piProviderRef <$> createdAtFake p)
  case reverse refs of
    [] -> failWith "no invoices were created"
    (onSecondPage : _) -> do
      setInvoiceState fake onSecondPage ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)]
      pListOpen p >>= \case
        Left e -> failWith ("expected a list, got " <> show e)
        Right ListPass {lpMoved} -> map fst lpMoved `shouldSatisfy` elem onSecondPage
      gets <- apiRequests fake "GET" ["invoices"]
      let pageOf FakeRequest {frQuery} = (join (lookup "take" frQuery), join (lookup "skip" frQuery))
          size = BC.pack (show listPageSize)
      map pageOf gets `shouldBe` [(Just size, Just "0"), (Just size, Just size)]

testPagingStopsAtTheCeiling :: IO ()
testPagingStopsAtTheCeiling = bounded "paging ceiling" $ withFakeProvider $ \fake p -> do
  ignoreListPaging fake
  replicateM_ listPageSize (void (createdAtFake p))
  r <- pListOpen p
  gets <- apiRequests fake "GET" ["invoices"]
  length gets `shouldBe` maxListPages
  case r of
    Left e -> failWith ("expected a list, got " <> show e)
    Right ListPass {lpSkipped} -> do
      map snd lpSkipped `shouldSatisfy` any (T.isInfixOf "stopped at")
      map snd lpSkipped `shouldSatisfy` any (T.isInfixOf (T.pack (show (maxListPages * listPageSize))))
      map fst lpSkipped `shouldSatisfy` all isNothing

createdAtFake :: HasCallStack => Provider -> IO ProviderInvoice
createdAtFake p =
  pCreateInvoice p (SPMCrypto CCBtc) sampleDraft >>= \case
    Right inv -> pure inv
    Left e -> failWith ("expected an invoice at the fake, got " <> show e)

webhookPath :: String
webhookPath = "/webhooks/btcpay"

hookRef :: Text
hookRef = "p-hooked"

hookedEvent :: LB.ByteString
hookedEvent = webhookEvent "InvoiceSettled" hookRef

someSig :: [Header]
someSig = webhookSigHeader "not-the-secret" hookedEvent

postWebhook :: WebClient -> [Header] -> LB.ByteString -> IO (Response LB.ByteString)
postWebhook client hdrs = webRequestBody client "POST" webhookPath hdrs

slowProviderRead :: Int
slowProviderRead = 1000000

testWebhookVerifiesARealSignature :: IO ()
testWebhookVerifiesARealSignature = bounded "real signature" $ withFakePoller $ \fake poller env client -> do
  r <- postCreateAs client 1 (createBody supporterPriceId Nothing "xmr" (codeHashText sampleCode))
  statusOf r `shouldBe` 200
  o <- jsonObject r
  iid <- InvoiceId <$> stringField o "invoiceId"
  Just row <- getInvoice (weStore env) iid
  let secret = bWebhookSecret (fbConfig fake)
      body = webhookEvent "InvoiceSettled" (irProviderRef row)
  delivered <- postWebhook client (webhookSigHeader secret body) body
  statusOf delivered `shouldBe` 200
  responseBody delivered `shouldBe` ""
  tampered <- postWebhook client (webhookSigHeader secret body) (body <> " ")
  statusOf tampered `shouldBe` 400
  responseBody tampered `shouldBe` ""
  unsigned <- postWebhook client [] body
  statusOf unsigned `shouldBe` 400
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  setInvoiceState fake (irProviderRef row) ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.32095000" :: Text)]
  drainHints poller
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid
  bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid

testWebhookPassesTheRawBytes :: IO ()
testWebhookPassesTheRawBytes = bounded "raw bytes" $ withStubPoller raceHold $ \ref _ env client -> do
  seedBadgePrice (weStore env) "price1"
  _ <- seedOpenRef (weStore env) 1 hookRef someExpiry
  setVerifyResult ref (Right (Just hookRef))
  let hdrs = webhookSigHeader "any-secret" hookedEvent
  r <- postWebhook client hdrs hookedEvent
  statusOf r `shouldBe` 200
  stubWebhooks ref >>= \case
    [(seenHdrs, seenBody)] -> do
      seenBody `shouldBe` LB.toStrict hookedEvent
      lookup "BTCPay-Sig" seenHdrs `shouldBe` lookup "BTCPay-Sig" hdrs
    other -> failWith ("expected one verify call, got " <> show (length other))
  case J.decode hookedEvent :: Maybe J.Value of
    Nothing -> failWith "the event body is not JSON"
    Just parsed -> J.encode parsed `shouldSatisfy` (/= hookedEvent)

testWebhookQueuesARead :: IO ()
testWebhookQueuesARead = bounded "webhook queues" $ withStubPoller raceHold $ \ref _ env client -> do
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRef (weStore env) 1 hookRef someExpiry
  setVerifyResult ref (Right (Just hookRef))
  r <- postWebhook client someSig hookedEvent
  statusOf r `shouldBe` 200
  responseBody r `shouldBe` ""
  headerOf r hCacheControl `shouldBe` Just "no-store"
  stubCalls ref `shouldReturn` []
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  Just row <- getInvoice (weStore env) iid
  irPayment row `shouldBe` Nothing

testWebhookSettlesByThePollerPath :: IO ()
testWebhookSettlesByThePollerPath = bounded "one settlement lane" $ withStubPoller raceHold $ \ref poller env client -> do
  seedBadgePrice (weStore env) "price1"
  hinted <- seedOpenRef (weStore env) 1 hookRef someExpiry
  listed <- seedOpenRef (weStore env) 2 "p-listed" someExpiry
  setSignals ref [(hookRef, settledSignal), ("p-listed", settledSignal)]
  setVerifyResult ref (Right (Just hookRef))
  r <- postWebhook client someSig hookedEvent
  statusOf r `shouldBe` 200
  invoiceStatus (weStore env) hinted `shouldReturn` ISOpen
  drainHints poller
  stubCalls ref `shouldReturn` [StubRead hookRef]
  invoiceStatus (weStore env) hinted `shouldReturn` ISPaid
  bcPaymentStatus <$> settledCode (weStore env) hinted `shouldReturn` CPSPaid
  ipStatus <$> paymentRow (weStore env) hinted `shouldReturn` "settled"
  runOnePass poller
  invoiceStatus (weStore env) listed `shouldReturn` ISPaid
  bcPaymentStatus <$> settledCode (weStore env) listed `shouldReturn` CPSPaid
  ipStatus <$> paymentRow (weStore env) listed `shouldReturn` "settled"

testWebhookDoesNotWaitOnTheProvider :: IO ()
testWebhookDoesNotWaitOnTheProvider = bounded "webhook does not wait" $ withStubPoller raceHold $ \ref _ env client -> do
  seedBadgePrice (weStore env) "price1"
  _ <- seedOpenRef (weStore env) 1 hookRef someExpiry
  setSignals ref [(hookRef, settledSignal)]
  setVerifyResult ref (Right (Just hookRef))
  setReadDelay ref slowProviderRead
  started <- getCurrentTime
  r <- postWebhook client someSig hookedEvent
  elapsed <- (`diffUTCTime` started) <$> getCurrentTime
  statusOf r `shouldBe` 200
  elapsed `shouldSatisfy` (< 0.5)
  stubCalls ref `shouldReturn` []

testWebhookRefusesASignature :: IO ()
testWebhookRefusesASignature = bounded "webhook refuses" $ withStubPoller raceHold $ \ref poller env client -> do
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRef (weStore env) 1 hookRef someExpiry
  setSignals ref [(hookRef, settledSignal)]
  setVerifyResult ref (Left (WebhookError "BTCPay-Sig does not verify"))
  r <- postWebhook client someSig hookedEvent
  statusOf r `shouldBe` 400
  responseBody r `shouldBe` ""
  drainHints poller
  stubCalls ref `shouldReturn` []
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen

testWebhookIgnoresWhatItCannotActOn :: IO ()
testWebhookIgnoresWhatItCannotActOn = bounded "webhook ignores" $ withStubPoller raceHold $ \ref poller env client -> do
  seedBadgePrice (weStore env) "price1"
  ours <- seedOpenRef (weStore env) 1 hookRef someExpiry
  otherLane <- seedOtherProvider (weStore env) 2 "p-stripe"
  setSignals ref [(hookRef, settledSignal), ("p-stripe", settledSignal)]
  setVerifyResult ref (Right Nothing)
  unhandled <- postWebhook client someSig (webhookEvent "InvoiceReceivedPayment" hookRef)
  statusOf unhandled `shouldBe` 200
  responseBody unhandled `shouldBe` ""
  setVerifyResult ref (Right (Just "p-no-such-invoice"))
  unknown <- postWebhook client someSig (webhookEvent "InvoiceSettled" "p-no-such-invoice")
  statusOf unknown `shouldBe` 200
  responseBody unknown `shouldBe` ""
  setVerifyResult ref (Right (Just "p-stripe"))
  crossed <- postWebhook client someSig (webhookEvent "InvoiceSettled" "p-stripe")
  statusOf crossed `shouldBe` 200
  responseBody crossed `shouldBe` ""
  drainHints poller
  stubCalls ref `shouldReturn` []
  invoiceStatus (weStore env) ours `shouldReturn` ISOpen
  invoiceStatus (weStore env) otherLane `shouldReturn` ISOpen

testWebhookRefusesAnOversizedBody :: IO ()
testWebhookRefusesAnOversizedBody = bounded "webhook body cap" $ withStubPoller raceHold $ \ref _ _ client -> do
  setVerifyResult ref (Left (WebhookError "BTCPay-Sig does not verify"))
  atCap <- postWebhook client someSig (LB.replicate (fromIntegral maxWebhookBytes) 'x')
  statusOf atCap `shouldBe` 400
  length <$> stubWebhooks ref `shouldReturn` 1
  over <- postWebhook client someSig (LB.replicate (fromIntegral maxWebhookBytes + 1) 'x')
  statusOf over `shouldBe` 413
  responseBody over `shouldBe` ""
  length <$> stubWebhooks ref `shouldReturn` 1

testReadHintQueuedOnce :: IO ()
testReadHintQueuedOnce = bounded "hint queued once" $ withStubPoller raceHold $ \ref poller env _ -> do
  seedBadgePrice (weStore env) "price1"
  _ <- seedOpenRef (weStore env) 1 hookRef someExpiry
  replicateM_ 5 (queueReadHint (weHints env) hookRef `shouldReturn` True)
  drainHints poller
  stubCalls ref `shouldReturn` [StubRead hookRef]
  queueReadHint (weHints env) hookRef `shouldReturn` True
  drainHints poller
  stubCalls ref `shouldReturn` [StubRead hookRef, StubRead hookRef]

testWebhookDropsAHintWhenFull :: IO ()
testWebhookDropsAHintWhenFull = bounded "full hint queue" $ withStubPoller raceHold $ \ref poller env client -> do
  seedBadgePrice (weStore env) "price1"
  iid <- seedOpenRef (weStore env) 1 hookRef someExpiry
  setSignals ref [(hookRef, settledSignal)]
  let fillers = ["p-filler-" <> T.pack (show i) | i <- [1 .. hintQueueSize]]
  mapM (queueReadHint (weHints env)) fillers `shouldReturn` map (const True) fillers
  queueReadHint (weHints env) "p-one-more" `shouldReturn` False
  setVerifyResult ref (Right (Just hookRef))
  r <- postWebhook client someSig hookedEvent
  statusOf r `shouldBe` 200
  responseBody r `shouldBe` ""
  drainHints poller
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  runOnePass poller
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid

testWebhookNeverAnswers5xx :: IO ()
testWebhookNeverAnswers5xx = bounded "webhook never 5xx" $ withStubPoller raceHold $ \ref _ env client -> do
  seedBadgePrice (weStore env) "price1"
  _ <- seedOpenRef (weStore env) 1 hookRef someExpiry
  setVerifyThrows ref True
  threw <- postWebhook client someSig hookedEvent
  statusOf threw `shouldBe` 200
  responseBody threw `shouldBe` ""
  setVerifyThrows ref False
  setVerifyResult ref (Right (Just hookRef))
  breakStore (weStore env)
  r <- postWebhook client someSig hookedEvent
  statusOf r `shouldBe` 200
  responseBody r `shouldBe` ""
  stubCalls ref `shouldReturn` []

paidInFull, paidInPart :: Text
paidInFull = "0.00050000"
paidInPart = "0.00020000"

fullyPaid, partlyPaid :: J.Value
fullyPaid = J.Number 5400
partlyPaid = J.Number 2160

buyBadge :: HasCallStack => WebEnv -> WebClient -> Int -> Text -> IO (InvoiceId, Text)
buyBadge env client i code = do
  r <- postCreateAs client i (createBody supporterPriceId Nothing "btc" (codeHashText code))
  statusOf r `shouldBe` 200
  o <- jsonObject r
  iid <- InvoiceId <$> stringField o "invoiceId"
  getInvoice (weStore env) iid >>= \case
    Just InvoiceRow {irProviderRef} -> pure (iid, irProviderRef)
    Nothing -> failWith "the create answered 200 and wrote no invoice row"

atProvider :: FakeBTCPay -> Text -> Text -> Text -> Text -> IO ()
atProvider fake ref status additional paid =
  atProviderDue fake ref status additional paid (if paid == paidInFull then "0.00000000" else dueAfterPart)

atProviderDue :: FakeBTCPay -> Text -> Text -> Text -> Text -> Text -> IO ()
atProviderDue fake ref status additional paid due =
  setInvoiceState fake ref ["status" .= status, "additionalStatus" .= additional, "paymentMethodPaid" .= paid, "due" .= due]

dueAfterPart :: Text
dueAfterPart = "0.00030500"

viewInvoice :: HasCallStack => WebClient -> InvoiceId -> IO J.Object
viewInvoice client iid = do
  r <- webGet client (invoicePath iid)
  statusOf r `shouldBe` 200
  headerOf r hCacheControl `shouldBe` Just "no-store"
  jsonObject r

scenarioPaidPurchase :: IO ()
scenarioPaidPurchase = bounded "scenario: paid purchase" $ withFakePoller $ \fake poller env client -> do
  (iid, ref) <- buyBadge env client 1 sampleCode
  unpaid <- viewInvoice client iid
  fieldOf unpaid "status" `shouldBe` Just (J.String "open")
  fieldOf unpaid "amountPaid" `shouldBe` Nothing
  fieldOf unpaid "cryptoAmountPaid" `shouldBe` Nothing
  atProvider fake ref "Settled" "None" paidInFull
  runOnePass poller
  paid <- viewInvoice client iid
  fieldOf paid "status" `shouldBe` Just (J.String "paid")
  fieldOf paid "amountPaid" `shouldBe` Just fullyPaid
  fieldOf paid "cryptoAmountPaid" `shouldBe` Just (J.String paidInFull)
  fieldOf paid "settledAt" `shouldSatisfy` isJust
  p <- paymentRow (weStore env) iid
  ipStatus p `shouldBe` "settled"
  code <- settledCode (weStore env) iid
  bcPaymentStatus code `shouldBe` CPSPaid
  bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime (ipUpdatedAt p))

scenarioHeldWaitWakes :: IO ()
scenarioHeldWaitWakes = bounded "scenario: held wait" $ withFakePollerHolding raceHold $ \fake poller env client -> do
  (iid, ref) <- buyBadge env client 1 sampleCode
  held <- async $ webGet client (invoicePath iid <> "?wait=open")
  threadDelay 100000
  Async.poll held >>= \parked -> parked `shouldSatisfy` isNothing
  atProvider fake ref "Settled" "None" paidInFull
  settling <- getCurrentTime
  runOnePass poller
  r <- wait held
  elapsed <- (`diffUTCTime` settling) <$> getCurrentTime
  statusOf r `shouldBe` 200
  o <- jsonObject r
  fieldOf o "status" `shouldBe` Just (J.String "paid")
  fieldOf o "amountPaid" `shouldBe` Just fullyPaid
  elapsed `shouldSatisfy` (< 1)
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid

scenarioPartPaymentIsReported :: IO ()
scenarioPartPaymentIsReported = bounded "scenario: part paid" $ withFakePoller $ \fake poller env client -> do
  (iid, ref) <- buyBadge env client 1 sampleCode
  atProvider fake ref "New" "PaidPartial" paidInPart
  runOnePass poller
  o <- viewInvoice client iid
  fieldOf o "status" `shouldBe` Just (J.String "open")
  fieldOf o "amountPaid" `shouldBe` Just partlyPaid
  fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String paidInPart)
  -- The due figure is the provider's own, which includes the network fee a partial payment adds,
  -- so it is 0.00030500 rather than the 0.00030000 a subtraction would give.
  fieldOf o "cryptoAmountDue" `shouldBe` Just (J.String dueAfterPart)
  fieldOf o "settledAt" `shouldBe` Nothing
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "pending"
  code <- settledCode (weStore env) iid
  bcPaymentStatus code `shouldBe` CPSUnpaid
  bcExpiresAt code `shouldBe` Nothing

scenarioExpiryReportsWhatArrived :: IO ()
scenarioExpiryReportsWhatArrived = bounded "scenario: expired part paid" $ withFakePoller $ \fake poller env client -> do
  (iid, ref) <- buyBadge env client 1 sampleCode
  atProvider fake ref "Expired" "PaidPartial" paidInPart
  runOnePass poller
  o <- viewInvoice client iid
  fieldOf o "status" `shouldBe` Just (J.String "expired")
  fieldOf o "amountPaid" `shouldBe` Just partlyPaid
  fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String paidInPart)
  fieldOf o "settledAt" `shouldBe` Nothing
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "pending"
  code <- settledCode (weStore env) iid
  bcPaymentStatus code `shouldBe` CPSUnpaid
  bcExpiresAt code `shouldBe` Nothing

scenarioLateSettlement :: IO ()
scenarioLateSettlement = bounded "scenario: late settlement" $ withFakePoller $ \fake poller env client -> do
  (iid, ref) <- buyBadge env client 1 sampleCode
  atProvider fake ref "Expired" "PaidPartial" paidInPart
  runOnePass poller
  expired <- viewInvoice client iid
  fieldOf expired "status" `shouldBe` Just (J.String "expired")
  fieldOf expired "amountPaid" `shouldBe` Just partlyPaid
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
  atProvider fake ref "Settled" "PaidLate" paidInFull
  runOnePass poller
  paid <- viewInvoice client iid
  fieldOf paid "status" `shouldBe` Just (J.String "paid")
  fieldOf paid "amountPaid" `shouldBe` Just fullyPaid
  fieldOf paid "cryptoAmountPaid" `shouldBe` Just (J.String paidInFull)
  fieldOf paid "settledAt" `shouldSatisfy` isJust
  invoiceStatus (weStore env) iid `shouldReturn` ISPaid
  p <- paymentRow (weStore env) iid
  ipStatus p `shouldBe` "settled"
  code <- settledCode (weStore env) iid
  bcPaymentStatus code `shouldBe` CPSPaid
  bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime (ipUpdatedAt p))

scenarioReplayChangesNothing :: IO ()
scenarioReplayChangesNothing = bounded "scenario: replay" $ withFakePoller $ \fake poller env client -> do
  (iid, ref) <- buyBadge env client 1 sampleCode
  atProvider fake ref "Settled" "None" paidInFull
  runOnePass poller
  settled <- viewInvoice client iid
  fieldOf settled "status" `shouldBe` Just (J.String "paid")
  firstPayment <- paymentRow (weStore env) iid
  firstCode <- settledCode (weStore env) iid
  length <$> paymentIdentity (weStore env) iid `shouldReturn` 1
  runOnePass poller
  length <$> apiRequests fake "GET" ["invoices"] `shouldReturn` 1
  length <$> paymentIdentity (weStore env) iid `shouldReturn` 1
  paymentRow (weStore env) iid `shouldReturn` firstPayment
  settledCode (weStore env) iid `shouldReturn` firstCode
  viewInvoice client iid `shouldReturn` settled

scenarioInvalidClosesAsExpired :: IO ()
scenarioInvalidClosesAsExpired = bounded "scenario: invoice invalid" $ withFakePoller $ \fake poller env client -> do
  (iid, ref) <- buyBadge env client 1 sampleCode
  atProvider fake ref "Invalid" "None" paidInPart
  let body = webhookEvent "InvoiceInvalid" ref
  delivered <- postWebhook client (webhookSigHeader (bWebhookSecret (fbConfig fake)) body) body
  statusOf delivered `shouldBe` 200
  responseBody delivered `shouldBe` ""
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  drainHints poller
  o <- viewInvoice client iid
  fieldOf o "status" `shouldBe` Just (J.String "expired")
  fieldOf o "amountPaid" `shouldBe` Just partlyPaid
  fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String paidInPart)
  invoiceStatus (weStore env) iid `shouldReturn` ISExpired
  bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
  detailReads <- apiRequests fake "GET" ["invoices", ref]
  length detailReads `shouldBe` 1

scenarioCodeConflictCreatesNothing :: IO ()
scenarioCodeConflictCreatesNothing = bounded "scenario: code conflict" $ withFakePoller $ \fake poller env client -> do
  (iid, ref) <- buyBadge env client 1 sampleCode
  fakeInvoiceIds fake `shouldReturn` [ref]
  again <- postCreateAs client 2 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
  statusOf again `shouldBe` 409
  responseBody again `shouldBe` errorBody "code_conflict"
  fakeInvoiceIds fake `shouldReturn` [ref]
  invoiceCount (weStore env) `shouldReturn` 1
  (_, otherRef) <- buyBadge env client 3 (sampleCode <> "2")
  otherRef `shouldSatisfy` (/= ref)
  fakeInvoiceIds fake `shouldReturn` sort [ref, otherRef]
  invoiceCount (weStore env) `shouldReturn` 2
  atProvider fake ref "Settled" "None" paidInFull
  runOnePass poller
  paid <- viewInvoice client iid
  fieldOf paid "status" `shouldBe` Just (J.String "paid")
  bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid

scenarioNoWebhookAnywhere :: IO ()
scenarioNoWebhookAnywhere = bounded "scenario: no webhook" $ withFakePoller $ \fake poller env client -> do
  (iid, ref) <- buyBadge env client 1 sampleCode
  atProvider fake ref "Settled" "None" paidInFull
  drainHints poller
  invoiceStatus (weStore env) iid `shouldReturn` ISOpen
  runOnePass poller
  paid <- viewInvoice client iid
  fieldOf paid "status" `shouldBe` Just (J.String "paid")
  bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
  byId <- apiRequests fake "GET" ["invoices", ref]
  byId `shouldSatisfy` (not . null)

cancelPath :: InvoiceId -> String
cancelPath iid = invoicePath iid <> "/cancel"

webPost :: WebClient -> String -> IO (Response LB.ByteString)
webPost client target = webRequest client "POST" target []

withCancel :: (IORef StubState -> WebEnv -> WebClient -> IO a) -> IO a
withCancel action = withCheckout $ \ref env client -> do
  _ <- seedOpenInvoice env
  action ref env client

testCancelClosesTheInvoiceAtBothEnds :: IO ()
testCancelClosesTheInvoiceAtBothEnds = bounded "cancel" $ withCancel $ \ref _ client -> do
  let iid = niInvoiceId sampleInvoice
  r <- webPost client (cancelPath iid)
  statusOf r `shouldBe` 200
  o <- jsonObject r
  fieldOf o "status" `shouldBe` Just (J.String "expired")
  stubCalls ref `shouldReturn` [StubCancel (niProviderRef sampleInvoice)]
  reread <- webGet client (invoicePath iid)
  ao <- jsonObject reread
  fieldOf ao "status" `shouldBe` Just (J.String "expired")

testCancelWakesAHeldRequest :: IO ()
testCancelWakesAHeldRequest = bounded "cancel wakes a hold" $ withCancel $ \_ _ client -> do
  let iid = niInvoiceId sampleInvoice
  _ <- wokenBy client iid (void (webPost client (cancelPath iid))) "expired"
  pure ()

testCancelIsRefusedOnceItIsNotOpen :: IO ()
testCancelIsRefusedOnceItIsNotOpen = bounded "cancel not open" $ withCancel $ \ref env client -> do
  let iid = niInvoiceId sampleInvoice
  markPaid (weStore env) iid
  r <- webPost client (cancelPath iid)
  statusOf r `shouldBe` 409
  responseBody r `shouldBe` errorBody "not_open"
  stubCalls ref `shouldReturn` []
  reread <- webGet client (invoicePath iid)
  ao <- jsonObject reread
  fieldOf ao "status" `shouldBe` Just (J.String "paid")

testCancelLeavesTheInvoiceOpenWhenTheProviderFails :: IO ()
testCancelLeavesTheInvoiceOpenWhenTheProviderFails = bounded "cancel provider down" $ withCancel $ \ref _ client -> do
  let iid = niInvoiceId sampleInvoice
  atomicModifyIORef' ref $ \s -> (s {ssCancelError = Just (ProviderError "boom")}, ())
  r <- webPost client (cancelPath iid)
  statusOf r `shouldBe` 503
  reread <- webGet client (invoicePath iid)
  ao <- jsonObject reread
  fieldOf ao "status" `shouldBe` Just (J.String "open")

testCancelIsOpaqueForAnUnknownInvoice :: IO ()
testCancelIsOpaqueForAnUnknownInvoice = bounded "cancel unknown" $ withCancel $ \ref _ client -> do
  r <- webPost client "/api/invoice/no-such-invoice/cancel"
  statusOf r `shouldBe` 404
  responseBody r `shouldBe` notFoundBody
  stubCalls ref `shouldReturn` []

testCancelRefusesOtherMethods :: IO ()
testCancelRefusesOtherMethods = bounded "cancel verb" $ withCancel $ \_ _ client -> do
  r <- webGet client (cancelPath (niInvoiceId sampleInvoice))
  statusOf r `shouldBe` 405
  headerOf r "Allow" `shouldBe` Just "POST"

testExpireOverdueSparesAFundedInvoice :: IO ()
testExpireOverdueSparesAFundedInvoice = withServiceStore $ \st -> do
  seedBadgePrice st "price1"
  now <- getCurrentTime
  let pastExpiry = addUTCTime (-3600) now
      funded = sampleInvoice {niExpiresAt = pastExpiry}
      empty' = sampleInvoice {niInvoiceId = InvoiceId "inv-empty", niProviderRef = "p-empty", niCodeHash = digestFixture 15, niExpiresAt = pastExpiry}
  createInvoiceRows st funded `shouldReturn` Right ()
  createInvoiceRows st empty' `shouldReturn` Right ()
  settle st (niInvoiceId funded) (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) now `shouldReturn` Right ISOpen
  moved <- expireAllOverdue st now
  moved `shouldBe` [niInvoiceId empty']
  Just fundedRow <- getInvoice st (niInvoiceId funded)
  irStatus fundedRow `shouldBe` ISOpen
  settle st (niInvoiceId funded) (SigSettled (rcv 500 (Just "0.00050000")) now) now `shouldReturn` Right ISPaid

testCancelExpiresAFundedInvoice :: IO ()
testCancelExpiresAFundedInvoice = withServiceStore $ \st -> do
  seedBadgePrice st "price1"
  now <- getCurrentTime
  let iid = niInvoiceId sampleInvoice
  createInvoiceRows st sampleInvoice `shouldReturn` Right ()
  settle st iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) now `shouldReturn` Right ISOpen
  cancelOpenInvoice st iid now `shouldReturn` True
  Just row <- getInvoice st iid
  irStatus row `shouldBe` ISExpired
  (ipCryptoPaid <$> irPayment row) `shouldBe` Just (Just "0.00050000")

testCancelIsRefusedOnceItIsFunded :: IO ()
testCancelIsRefusedOnceItIsFunded = bounded "cancel funded" $ withCancel $ \ref env client -> do
  let iid = niInvoiceId sampleInvoice
  settle (weStore env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated `shouldReturn` Right ISOpen
  r <- webPost client (cancelPath iid)
  statusOf r `shouldBe` 409
  responseBody r `shouldBe` errorBody "funded"
  stubCalls ref `shouldReturn` []
  reread <- webGet client (invoicePath iid)
  ao <- jsonObject reread
  fieldOf ao "status" `shouldBe` Just (J.String "open")

testViewNamesTheConfirmationsSettlementNeeds :: IO ()
testViewNamesTheConfirmationsSettlementNeeds = bounded "required confirmations" $ withCancel $ \_ _ client -> do
  r <- webGet client (invoicePath (niInvoiceId sampleInvoice))
  statusOf r `shouldBe` 200
  o <- jsonObject r
  -- MediumSpeed is BTCPay's one-confirmation policy, so settlement needs one confirmation.
  fieldOf o "requiredConfirmations" `shouldBe` Just (J.Number 1)

testViewOmitsConfirmationsWithoutBTCPay :: IO ()
testViewOmitsConfirmationsWithoutBTCPay = bounded "no confirmations" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  r <- webGet client (invoicePath iid)
  o <- jsonObject r
  fieldOf o "requiredConfirmations" `shouldBe` Nothing

testHeldWaitWakesOnAPaymentThatDoesNotSettle :: IO ()
testHeldWaitWakesOnAPaymentThatDoesNotSettle = bounded "funded wakes a hold" $ withCheckout $ \_ env client -> do
  iid <- seedOpenInvoice env
  held <- async $ webGet client (invoicePath iid <> "?wait=open")
  threadDelay 100000
  waitingCount (weWaiters env) `shouldReturn` 1
  settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated
    `shouldReturn` Right ISOpen
  r <- wait held
  statusOf r `shouldBe` 200
  o <- jsonObject r
  fieldOf o "status" `shouldBe` Just (J.String "open")
  fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String "0.00050000")

testARepeatedSignalDoesNotWakeAHold :: IO ()
testARepeatedSignalDoesNotWakeAHold = bounded "repeat signal" $ withWebApp $ \env client -> do
  iid <- seedOpenInvoice env
  let funded = SigFunded (rcv 500 (Just "0.00050000")) PaidInPart
  settleOrder (weStore env) (weWaiters env) iid funded settleAt `shouldReturn` Right ISOpen
  held <- async $ webGet client (invoicePath iid <> "?wait=open&seenPaid=0.00050000&seenFull=0")
  threadDelay holdParkDelay
  Async.poll held >>= (`shouldSatisfy` isNothing)

  settleOrder (weStore env) (weWaiters env) iid funded settleAt `shouldReturn` Right ISOpen
  threadDelay holdParkDelay
  stillParked <- Async.poll held
  stillParked `shouldSatisfy` isNothing

  settleOrder (weStore env) (weWaiters env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) settleAt
    `shouldReturn` Right ISPaid
  r <- wait held
  statusOf r `shouldBe` 200
  o <- jsonObject r
  fieldOf o "status" `shouldBe` Just (J.String "paid")

testHeldWaitIsNotWokenByAPassThatWroteNothing :: IO ()
testHeldWaitIsNotWokenByAPassThatWroteNothing = bounded "no churn" $ withCheckout $ \_ env _ -> do
  iid <- seedOpenInvoice env
  markPaid (weStore env) iid
  waitingBefore <- waitingCount (weWaiters env)
  settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated
    `shouldReturn` Right ISPaid
  waitingAfter <- waitingCount (weWaiters env)
  waitingAfter `shouldBe` waitingBefore

testViewCarriesTheProvidersPaidVerdict :: IO ()
testViewCarriesTheProvidersPaidVerdict = bounded "paid in full" $ withCheckout $ \_ env client -> do
  iid <- seedOpenInvoice env
  settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 400 (Just "0.00040000")) PaidInFull) someCreated
    `shouldReturn` Right ISOpen
  o <- jsonObject =<< webGet client (invoicePath iid)
  fieldOf o "status" `shouldBe` Just (J.String "open")
  fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)
  fieldOf o "amountPaid" `shouldBe` Just (J.Number 400)

testPaidVerdictIsNotWithdrawnByALaterRead :: IO ()
testPaidVerdictIsNotWithdrawnByALaterRead = bounded "verdict sticks" $ withCheckout $ \_ env client -> do
  iid <- seedOpenInvoice env
  settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInFull) someCreated
    `shouldReturn` Right ISOpen
  settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated
    `shouldReturn` Right ISOpen
  o <- jsonObject =<< webGet client (invoicePath iid)
  fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)

testExpireOverdueSparesAZeroAmount :: IO ()
testExpireOverdueSparesAZeroAmount = withServiceStore $ \st -> do
  seedBadgePrice st "price1"
  now <- getCurrentTime
  let pastExpiry = addUTCTime (-3600) now
      dust = sampleInvoice {niExpiresAt = pastExpiry}
      verdict = sampleInvoice {niInvoiceId = InvoiceId "inv-verdict", niProviderRef = "p-verdict", niCodeHash = digestFixture 16, niExpiresAt = pastExpiry}
  createInvoiceRows st dust `shouldReturn` Right ()
  createInvoiceRows st verdict `shouldReturn` Right ()
  settle st (niInvoiceId dust) (SigFunded (rcv 0 (Just "0.00000001")) PaidInPart) now `shouldReturn` Right ISOpen
  settle st (niInvoiceId verdict) (SigFunded (rcv 0 Nothing) PaidInFull) now `shouldReturn` Right ISOpen
  expireAllOverdue st now `shouldReturn` []
  mapM_ (\iid ->
    getInvoice st iid >>= \case
      Just InvoiceRow {irStatus, irPayment} -> do
        irStatus `shouldBe` ISOpen
        maybe False paymentHolds irPayment `shouldBe` True
      Nothing -> failWith "the invoice went missing") [niInvoiceId dust, niInvoiceId verdict]