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

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

module Bots.StoreService.WebTests
  ( badgeWebTests,
    withServiceStore,
    withServiceStores,
    columnsOf,
    runMigrations,
    digestFixture,
    capturingStderr,
    StubState (..),
    StubCall (..),
    newStubState,
    stubProvider,
    stubCalls,
    setSignals,
    sampleProviderInvoice,
    prepareStaticDir,
    testServiceConfig,
    testBTCPayConfig,
    WebClient,
    webRequestBody,
    webGet,
    statusOf,
    jsonObject,
    fieldOf,
    rcv,
    bounded,
  )
where

import StoreService.Catalog (catalogCurrency, defaultCatalog)
import StoreService.Config (BTCPayConfig (..), ListenerConfig (..), PollConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..))
import StoreService.Log (logInfo)
import StoreService.Names.Abi (hex)
import StoreService.Orders (cancelOpenInvoice, codeLifetime, expireOverdue, settleOrder)
import StoreService.Poller
import StoreService.Providers
import StoreService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages)
import StoreService.Providers.Stripe (stripeProvider)
import StoreService.Store (CreditedPurchase (..), FundingCredit (..), KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), NewStorePurchase (..), PaymentRebind (..), PurchaseSubscription (..), RevokeResult (..), appendLedgerPlan, createCodePurchase, createStorePurchase, getCodePurchaseForKey, getLedgerEntries, getLedgerTip, getManagedGroup, getMovedFromExpiry, getPurchaseByKey, getPurchaseSubscription, getStorePaymentCredit, insertBadgeCode, insertManagedGroup, insertSubscriptionCharge, markOwnerBootstrapped, rebindStorePayment, revokeCode)
import StoreService.StoreReceipts (StoreCharge (..))
import StoreService.Store.Invoices
import StoreService.Waiters (awaitStatus, newWaiters, publish, waitingCount)
import StoreService.Web.Http
import StoreService.Web.Server
import Bots.StoreService.BotTests (codeCounts, newPurchaseKeys)
import Bots.StoreService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource)
import Bots.StoreService.FakeBTCPay
import Bots.StoreService.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 (MVar, newEmptyMVar, newMVar, putMVar, takeMVar, withMVar)
import Control.Concurrent.STM (atomically, modifyTVar', readTVarIO)
import qualified Control.Exception as E
import Control.Monad (forM, forM_, 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.Functor ((<&>))
import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)
import Data.Int (Int64)
import Data.List (isInfixOf, sort, sortOn)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, isJust, isNothing, fromMaybe, mapMaybe)
import qualified Data.Set as S
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 qualified GHC.IO.Device as IODevice
import qualified GHC.IO.FD as FD
import GHC.IO.Handle.FD (handleToFd)
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 (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeType (..))
import Simplex.Chat.Badges.Ledger (addMonths, debitEntry, emptyEntry, grantEntry, issueEntry)
import Simplex.Chat.StoreService (BadgeOffer (..), BadgePrice (..), StatementCreditType (..), StatementDebitType (..), StatementEntry (..), SubscriptionState (..))
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 (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.BBS (BBSSignature (..))
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 (BufferMode (..), IOMode (..), hFlush, 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 StoreService.Store.Postgres.Migrations (schemaMigrations, storeServiceSchemaMigrations)
import ChatClient (testDBConnstr)
import Database.PostgreSQL.Simple (Only (..))
import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
#else
import StoreService.Store.SQLite.Migrations (schemaMigrations, storeServiceSchemaMigrations)
import Data.String (fromString)
import Database.SQLite.Simple (Only (..))
import qualified Database.SQLite.Simple as SQL
import Simplex.Messaging.Agent.Store.DB (TrackQueries (..))
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
#endif

withServiceStore :: (DBStore -> IO a) -> IO a
withServiceStore action = withServiceStores (>>= action)

-- | Each store the action opens is a new one over the same test database, as a restarted service opens; all are closed at the end.
withServiceStores :: (IO DBStore -> IO a) -> IO a
withServiceStores action = withServiceDBOpts $ \opts -> do
  opened <- newIORef []
  let open = do
        Right st <- createDBStore opts storeServiceSchemaMigrations (MigrationConfig MCError Nothing)
        st <$ modifyIORef' opened (st :)
  action open `E.finally` (readIORef opened >>= mapM_ closeDBStore)

withServiceDBOpts :: (DBOpts -> IO a) -> IO a
#if defined(dbPostgres)
withServiceDBOpts action = do
  n <- atomicModifyIORef' serviceSchemaCounter (\i -> (i + 1, i))
  action
    DBOpts
      { connstr = BC.pack testDBConnstr,
        schema = "sx_badge_service_web_test_" <> BC.pack (show n),
        poolSize = 4,
        createSchema = True
      }

serviceSchemaCounter :: IORef Int
serviceSchemaCounter = unsafePerformIO $ newIORef 0
{-# NOINLINE serviceSchemaCounter #-}
#else
withServiceDBOpts action = do
  createDirectoryIfMissing True "tests/tmp"
  withTempDirectory "tests/tmp" "badge-web" $ \dir -> action (DBOpts (dir </> "badge_service_test.db") [] "" False True TQOff)
#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 "store service schema" $ do
    it "carries the service-only columns, and none of the subscription columns it never wrote" testServiceColumns
    it "refuses a duplicate provider_ref" testProviderRefUnique
    it "M20260918 adds the multi-use columns and the group table" testGroupOpsColumns
    it "M20260918 defaults a fresh code to one use with none spent" testGroupOpsRedeemCounts
    it "declares its migrations in name order, master's badge migrations before the names ones" testMigrationOrder
    it "migrates all the way down and up again" testSchemaDownUpCycle
    it "rolls back only the group migration and re-applies it, keeping a code redeemed twice spent" testGroupOpsDownUp
    it "rolls back only the subscription migration, restoring the columns it dropped, and re-applies it" testSubscriptionsDownUp
  describe "store 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 "a multi-use code can be revoked while it has uses left, and not once they are gone" testRevokeMultiUseCode
    it "every timestamp round-trips to the second" testTimestampRoundTrip
    it "stores a charge credit with its charge, and reads it back at the tip and in the statement" testChargeCreditRoundTrip
    it "stores transfers and an upgrade with the purchase each names, and reads them back at the tip and in the statement" testTransferEntriesRoundTrip
    it "refuses a ledger row naming a purchase key with no purchase, writing nothing" testUnknownPurchaseKeyRefused
    it "moves a store payment to a new key, ending the old purchase's share with a transferOut naming it" testPaymentRebind
    it "moves nothing when the old purchase's ledger or the payment's binding moved since they were read" testPaymentRebindLostRace
    it "reads the latest credential expiry of the purchase a payment last moved from" testMovedFromExpiry
  describe "managed group" $ do
    it "round-trips and bootstraps once" testManagedGroupRoundTripsAndBootstrapsOnce
    it "refuses a second row and burns the flag per group" testManagedGroupIsSingleRow
  describe "multi-use" $ do
    it "finds a key's own purchase with its newest credential, and none for another key" testKeyPurchaseLookup
    it "gives concurrent claims exactly the code's uses" testMultiUseConcurrentClaimsUpToLimit
    it "refuses a second claim by the same key without using up a use" testSameKeyClaimsOnce
  describe "store 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 "StoreService.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 "store service log" $
    it "keeps each record whole on its own line while many threads log at once, in every buffering mode" testLogRecordsWhole
  describe "store 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 "carries a closed invoice's paid-in-full verdict, the status staying expired" testViewCarriesAClosedPaidVerdict
    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
    it "logs a handler exception as one service log record, never a bare line" testHandlerExceptionIsLogged
  describe "StoreService names: sites" $ do
    it "exports both sites, each with the publishable key" testExportsBothSites
    it "serves each site on its own port only, whatever the Host, and the API on both" testEachPortServesItsSite
    it "listens on the badges port alone without the names site" testOneListenerWithoutTheNamesSite
    it "serves a names asset with its type" testServesANamesAsset
    it "keeps every traversal spelling on the names port inside the names build" testNamesTraversalRefused
    it "refuses a build folder that is not there, only where it is served or exported" testSiteDirsMustExist
  describe "store 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 "store 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 "warns once for all the invoices it did not sell, not once per invoice" testStrangerSkipsShareOneWarning
    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 and sweeps 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 "store 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 "store 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 "store 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 "store 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 "store 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"])
  assertSubscriptionColumns st

assertSubscriptionColumns :: HasCallStack => DBStore -> IO ()
assertSubscriptionColumns st = do
  columnsOf st "sx_badge_service_subscription_charges"
    >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["charge_id", "payment_id", "provider_charge_ref", "plan_id", "period_start", "period_end", "amount", "currency", "created_at"])
  columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["charge_id", "from_purchase_id", "to_purchase_id"])
  payments <- columnsOf st "sx_badge_service_payments"
  payments `shouldSatisfy` \cs -> all (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token", "rebound_at"]
  payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_renews_at", "grace_until", "cancelled"])

testGroupOpsColumns :: IO ()
testGroupOpsColumns = withServiceStore assertGroupOpsColumns

assertGroupOpsColumns :: HasCallStack => DBStore -> IO ()
assertGroupOpsColumns st = do
  columnsOf st "sx_badge_service_badge_codes"
    >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["redeem_limit", "redeem_count", "group_item_id", "group_item_sent_at"])
  columnsOf st "sx_badge_service_group"
    >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["group_id", "group_link", "owner_bootstrapped", "created_at"])

runMigrations :: DBStore -> MigrationsToRun -> IO ()
#if defined(dbPostgres)
runMigrations st = Migrations.run st Nothing
#else
runMigrations st = Migrations.run st Nothing True
#endif

-- | Applied migrations must be a prefix of this list by name, so a migration of ours dated
-- before one of master's breaks upgrading a badge-service database.
testMigrationOrder :: IO ()
testMigrationOrder = do
  let declared = map (\(n, _, _) -> n) schemaMigrations
  [(a, b) | (a, b) <- zip declared (drop 1 declared), a >= b] `shouldBe` []
  let (badges, ours) = span (`elem` badgeMigrations) (map name storeServiceSchemaMigrations)
  badges `shouldBe` badgeMigrations
  ours `shouldBe` ["20261013_names", "20261022_drop_taken_codes", "20261022_name_balances", "20261022_name_late_wait", "20261023_name_terms", "20261027_name_invoiced_units"]
  where
    badgeMigrations = ["20260915_badge_service_schema", "20260918_badge_group_ops", "20260925_badge_store_receipts", "20261012_badge_subscriptions"]

testSchemaDownUpCycle :: IO ()
testSchemaDownUpCycle = withServiceStore $ \st -> do
  let downMigrations = mapMaybe toDownMigration storeServiceSchemaMigrations
  length downMigrations `shouldBe` length storeServiceSchemaMigrations
  runMigrations st $ MTRDown downMigrations
  columnsOf st "sx_badge_service_badge_codes" `shouldReturn` []
  columnsOf st "sx_badge_service_group" `shouldReturn` []
  columnsOf st "sx_badge_service_subscription_charges" `shouldReturn` []
  runMigrations st $ MTRUp storeServiceSchemaMigrations
  assertGroupOpsColumns st
  assertSubscriptionColumns st

testSubscriptionsDownUp :: IO ()
testSubscriptionsDownUp = withServiceStore $ \st -> do
  let subscriptions = [m | m@Migration {name = "20261012_badge_subscriptions"} <- storeServiceSchemaMigrations]
  length subscriptions `shouldBe` 1
  runMigrations st $ MTRDown (mapMaybe toDownMigration subscriptions)
  columnsOf st "sx_badge_service_subscription_charges" `shouldReturn` []
  columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldNotSatisfy` \cs -> any (`elem` cs) ["charge_id", "from_purchase_id", "to_purchase_id"])
  payments <- columnsOf st "sx_badge_service_payments"
  payments `shouldSatisfy` \cs -> all (`elem` cs) ["subscription_renews_at", "grace_until", "cancelled"]
  payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token", "rebound_at"])
  runMigrations st $ MTRUp subscriptions
  assertSubscriptionColumns st

testGroupOpsDownUp :: IO ()
testGroupOpsDownUp = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  let redeemedHash = digestFixture 44
      unredeemedHash = digestFixture 45
      groupOps = [m | m@Migration {name = "20260918_badge_group_ops"} <- storeServiceSchemaMigrations]
  redeemed <- insertCode st redeemedHash CPSPaid 2 now
  void $ insertCode st unredeemedHash CPSPaid 1 now
  -- Two purchases of one code would break a down migration that restored the unique index.
  replicateM_ 2 $ newPurchaseKeys >>= claimUse st redeemed now >>= (`shouldSatisfy` isJust)
  runMigrations st $ MTRDown (mapMaybe toDownMigration groupOps)
  columnsOf st "sx_badge_service_badge_codes" >>= (`shouldNotSatisfy` elem "redeem_count")
  runMigrations st $ MTRUp groupOps
  codeCounts st redeemedHash `shouldReturn` Just (1, 1)
  codeCounts st unredeemedHash `shouldReturn` Just (1, 0)

testGroupOpsRedeemCounts :: IO ()
testGroupOpsRedeemCounts = withServiceStore $ \st -> do
  let codeHash = digestFixture 43
  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 codeHash, "supporter" :: Text, 1 :: Int, "free" :: Text, someCreated)
  codeCounts st codeHash `shouldReturn` Just (1, 0)

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 ()
  expireNamed st now [niInvoiceId named] `shouldReturn` [niInvoiceId named]
  invoiceStatus st (niInvoiceId named) `shouldReturn` ISExpired
  invoiceStatus st (niInvoiceId unnamed) `shouldReturn` ISOpen
  expireNamed st now [niInvoiceId named] `shouldReturn` []

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

expireNamed :: DBStore -> UTCTime -> [InvoiceId] -> IO [InvoiceId]
expireNamed st now invIds = newWaiters >>= \waiters -> expireOverdue st waiters Nothing now now invIds

testRevokeAndRedeemExcludeEachOther :: IO ()
testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  keys <- newPurchaseKeys
  let newCode codeHash = insertCode st codeHash CPSPaid 1 now
      redeem badgeCodeId = claimUse st badgeCodeId now keys
      revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
  revokedFirst <- newCode "revoked-first"
  revoke "revoked-first" `shouldReturn` Revoked revokedFirst
  redeem revokedFirst `shouldReturn` Nothing
  codeCounts st "revoked-first" `shouldReturn` Just (1, 0)
  redeemedFirst <- newCode "redeemed-first"
  isJust <$> redeem redeemedFirst `shouldReturn` True
  revoke "redeemed-first" `shouldReturn` AlreadyRedeemed
  redeem redeemedFirst `shouldReturn` Nothing

testRevokeMultiUseCode :: IO ()
testRevokeMultiUseCode = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  let newCode codeHash = insertCode st codeHash CPSPaid 2 now
      -- A purchase key redeems once, so every redemption here brings its own.
      redeem badgeCodeId = newPurchaseKeys >>= claimUse st badgeCodeId now
      revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
  partlyUsed <- newCode "partly-used"
  isJust <$> redeem partlyUsed `shouldReturn` True
  revoke "partly-used" `shouldReturn` Revoked partlyUsed
  redeem partlyUsed `shouldReturn` Nothing
  usedUp <- newCode "used-up"
  isJust <$> redeem usedUp `shouldReturn` True
  isJust <$> redeem usedUp `shouldReturn` True
  revoke "used-up" `shouldReturn` AlreadyRedeemed

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-store-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

testChargeCreditRoundTrip :: IO ()
testChargeCreditRoundTrip = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  (purchaseKey, masterKey) <- newPurchaseKeys
  Just purchaseId <- withTransaction st $ \db ->
    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
  withTransaction st $ \db ->
    insertSubscriptionCharge db "pay1" "ch1" StoreCharge {chargeRef = "2000000812345672", planId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", periodStart = now, periodEnd = addMonths 1 now, chargePaid = Nothing, revoked = False, offer = False} now
  let charge = grantEntry now "e1" BTSupporter 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
  withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [charge] Nothing
  withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just [J.toJSON charge]) . fmap (map J.toJSON)
  withTransaction st (`getLedgerTip` purchaseId) >>= (`shouldBe` Just (J.toJSON charge)) . fmap J.toJSON

testTransferEntriesRoundTrip :: IO ()
testTransferEntriesRoundTrip = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  (purchaseKey, masterKey) <- newPurchaseKeys
  (otherKey, otherMasterKey) <- newPurchaseKeys
  Just purchaseId <- withTransaction st $ \db ->
    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
  Just _ <- withTransaction st $ \db ->
    createStorePurchase db NewStorePurchase {paymentId = "pay2", provider = PPApple, providerRef = "2000000812345673", paid = Nothing, purchaseKey = otherKey, masterKey = otherMasterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
  let transferIn = grantEntry now "e1" BTSupporter 2 (SCTransferIn otherKey) (emptyEntry now BTSupporter)
      upgrade = debitEntry now "e2" (SDUpgrade purchaseKey) transferIn
      transferOut = debitEntry now "e3" (SDTransferOut otherKey) upgrade
      rows = [transferIn, upgrade, transferOut]
  withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing rows Nothing
  withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just (map J.toJSON rows)) . fmap (map J.toJSON)
  withTransaction st (`getLedgerTip` purchaseId) >>= (`shouldBe` Just (J.toJSON transferOut)) . fmap J.toJSON

testUnknownPurchaseKeyRefused :: IO ()
testUnknownPurchaseKeyRefused = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  (purchaseKey, masterKey) <- newPurchaseKeys
  (unknownKey, _) <- newPurchaseKeys
  Just purchaseId <- withTransaction st $ \db ->
    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Nothing, providerToken = Nothing} now
  let granted = grantEntry now "e1" BTSupporter 2 SCCode (emptyEntry now BTSupporter)
  withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [granted] Nothing
  let upgraded = debitEntry now "e2" (SDUpgrade purchaseKey) granted
  refused <- E.try $ withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [upgraded, debitEntry now "e3" (SDTransferOut unknownKey) upgraded] Nothing
  (refused :: Either E.SomeException ()) `shouldSatisfy` isLeft
  withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just [J.toJSON granted]) . fmap (map J.toJSON)

testPaymentRebind :: IO ()
testPaymentRebind = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  (k2, mk2) <- newPurchaseKeys
  (p1, k1Rows@[_, issued1]) <- chargedStorePurchase st now
  reboundAt st "pay1" `shouldReturn` [Nothing]
  let transferOut = debitEntry now "e3" (SDTransferOut k2) issued1
      charge2 = grantEntry now "e4" BTSupporter 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
  Just issued2 <- pure $ issueEntry now "e5" charge2
  Just p2 <- withTransaction st $ \db -> do
    p2_ <- rebindStorePayment db PaymentRebind {paymentId = "pay1", fromPurchaseId = p1, fromTipId = "e2", fromRows = [transferOut], purchaseKey = k2, masterKey = mk2, badgeType = BTSupporter} now
    forM_ p2_ $ \p2 -> appendLedgerPlan db p2 Nothing [charge2] (Just (charge2, issued2, seededCredential mk2 (balanceStartTs issued2)))
    pure p2_
  withTransaction st (`getLedgerTip` p1) >>= (`shouldBe` Just (J.toJSON transferOut)) . fmap J.toJSON
  withTransaction st (\db -> getLedgerEntries db p1 0) >>= (`shouldBe` Just (map J.toJSON (k1Rows <> [transferOut]))) . fmap (map J.toJSON)
  withTransaction st (\db -> getLedgerEntries db p2 0) >>= (`shouldBe` Just (map J.toJSON [charge2, issued2])) . fmap (map J.toJSON)
  subscriptionPayment st p1 `shouldReturn` Nothing
  subscriptionPayment st p2 `shouldReturn` Just "pay1"
  creditedPurchaseId st `shouldReturn` Just p2
  reboundAt st "pay1" `shouldReturn` [Just now]

testPaymentRebindLostRace :: IO ()
testPaymentRebindLostRace = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  (k2, mk2) <- newPurchaseKeys
  (k3, mk3) <- newPurchaseKeys
  (p1, k1Rows@[charge1, issued1]) <- chargedStorePurchase st now
  let rebindTo (k, mk) fromTipId tip = PaymentRebind {paymentId = "pay1", fromPurchaseId = p1, fromTipId, fromRows = [debitEntry now "x" (SDTransferOut k) tip], purchaseKey = k, masterKey = mk, badgeType = BTSupporter}
      k1Entries = withTransaction st (\db -> getLedgerEntries db p1 0) <&> fmap (map J.toJSON)
  withTransaction st (\db -> rebindStorePayment db (rebindTo (k3, mk3) "e1" charge1) now) `shouldReturn` Nothing
  k1Entries `shouldReturn` Just (map J.toJSON k1Rows)
  creditedPurchaseId st `shouldReturn` Just p1
  reboundAt st "pay1" `shouldReturn` [Nothing]
  let transferOut = debitEntry now "x" (SDTransferOut k2) issued1
  Just _ <- withTransaction st $ \db -> rebindStorePayment db (rebindTo (k2, mk2) "e2" issued1) now
  withTransaction st (\db -> rebindStorePayment db (rebindTo (k3, mk3) "x" transferOut) (addUTCTime 60 now)) `shouldReturn` Nothing
  k1Entries `shouldReturn` Just (map J.toJSON (k1Rows <> [transferOut]))
  reboundAt st "pay1" `shouldReturn` [Just now]
  isNothing <$> withTransaction st (`getPurchaseByKey` k3) `shouldReturn` True

testMovedFromExpiry :: IO ()
testMovedFromExpiry = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  [(k0, mk0), (k1, mk1), (k2, mk2)] <- replicateM 3 newPurchaseKeys
  let day n = addUTCTime (n * 86400) now
      granted uuid = grantEntry now uuid BTSupporter 1 SCCode (emptyEntry now BTSupporter)
      movedFromExpiry = withTransaction st (`getMovedFromExpiry` "pay1")
      move fromPurchaseId fromTipId (k, mk) tipId =
        withTransaction st $ \db -> do
          Just purchaseId <- rebindStorePayment db PaymentRebind {paymentId = "pay1", fromPurchaseId, fromTipId, fromRows = [debitEntry now (fromTipId <> "-out") (SDTransferOut k) (granted fromTipId)], purchaseKey = k, masterKey = mk, badgeType = BTSupporter} now
          appendLedgerPlan db purchaseId Nothing [granted tipId] Nothing
          pure purchaseId
  Just p0 <- withTransaction st $ \db ->
    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey = k0, masterKey = mk0, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
  withTransaction st $ \db -> appendLedgerPlan db p0 Nothing [granted "g0"] Nothing
  seedIssuance st p0 "i0a" mk0 now (day 10)
  seedIssuance st p0 "i0b" mk0 now (day 20)
  movedFromExpiry `shouldReturn` Nothing
  p1 <- move p0 "g0" (k1, mk1) "g1"
  seedIssuance st p1 "i1b" mk1 now (day 40)
  seedIssuance st p1 "i1a" mk1 now (day 30)
  movedFromExpiry `shouldReturn` Just (day 20)
  p2 <- move p1 "g1" (k2, mk2) "g2"
  seedIssuance st p2 "i2a" mk2 now (day 50)
  seedIssuance st p2 "i2b" mk2 now (day 60)
  movedFromExpiry `shouldReturn` Just (day 40)

-- A purchase holding payment pay1 (provider ref 2000000812345671), funded by charge ch1, with its month issued as e2.
chargedStorePurchase :: DBStore -> UTCTime -> IO (Int64, [StatementEntry])
chargedStorePurchase st now = do
  (purchaseKey, masterKey) <- newPurchaseKeys
  Just purchaseId <- withTransaction st $ \db ->
    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
  withTransaction st $ \db ->
    insertSubscriptionCharge db "pay1" "ch1" StoreCharge {chargeRef = "2000000812345672", planId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", periodStart = now, periodEnd = addMonths 1 now, chargePaid = Nothing, revoked = False, offer = False} now
  let charge = grantEntry now "e1" BTSupporter 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
  Just issued <- pure $ issueEntry now "e2" charge
  withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [charge] (Just (charge, issued, seededCredential masterKey (balanceStartTs issued)))
  pure (purchaseId, [charge, issued])

reboundAt :: DBStore -> Text -> IO [Maybe UTCTime]
reboundAt st paymentId =
  withConnection st $ \db -> map fromOnly <$> DB.query db "SELECT rebound_at FROM sx_badge_service_payments WHERE payment_id = ?" (Only paymentId)

subscriptionPayment :: DBStore -> Int64 -> IO (Maybe Text)
subscriptionPayment st purchaseId =
  fmap (\PurchaseSubscription {paymentId} -> paymentId) <$> withTransaction st (`getPurchaseSubscription` purchaseId)

creditedPurchaseId :: DBStore -> IO (Maybe Int64)
creditedPurchaseId st =
  withTransaction st (\db -> getStorePaymentCredit db PPApple "2000000812345671") <&> \case
    Credited CreditedPurchase {badgePurchaseId} -> Just badgePurchaseId
    _ -> Nothing

testManagedGroupRoundTripsAndBootstrapsOnce :: IO ()
testManagedGroupRoundTripsAndBootstrapsOnce = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  beforeInsert <- withTransaction st getManagedGroup
  beforeInsert `shouldBe` Nothing
  withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now
  afterInsert <- withTransaction st getManagedGroup
  afterInsert `shouldBe` Just ManagedGroup {mgGroupId = 42, mgGroupLink = "https://link", mgOwnerBootstrapped = False}
  show afterInsert `shouldNotSatisfy` ("https://link" `isInfixOf`)
  firstMark <- withTransaction st (`markOwnerBootstrapped` 42)
  secondMark <- withTransaction st (`markOwnerBootstrapped` 42)
  (firstMark, secondMark) `shouldBe` (True, False)

testManagedGroupIsSingleRow :: IO ()
testManagedGroupIsSingleRow = withServiceStore $ \st -> do
  now <- truncateToSecond <$> getCurrentTime
  withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now
  withTransaction st $ \db -> insertManagedGroup db 43 "https://other" now
  withTransaction st $ \db -> insertManagedGroup db 42 "https://again" now
  managedGroupRows st `shouldReturn` [(42, "https://link")]
  withTransaction st (`markOwnerBootstrapped` 43) `shouldReturn` False
  (fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just False
  withTransaction st (`markOwnerBootstrapped` 42) `shouldReturn` True
  (fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just True

managedGroupRows :: DBStore -> IO [(Int64, Text)]
managedGroupRows st =
  withConnection st $ \db -> DB.query_ db "SELECT group_id, group_link FROM sx_badge_service_group ORDER BY group_id"

insertCode :: DBStore -> ByteString -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64
insertCode st codeHash paymentStatus redeemLimit now =
  withTransaction st $ \db -> insertBadgeCode db codeHash BTSupporter 1 paymentStatus redeemLimit now

claimUse :: DBStore -> Int64 -> UTCTime -> (C.PublicKeyEd25519, BadgeMasterKey) -> IO (Maybe Int64)
claimUse st badgeCodeId now (purchaseKey, masterKey) =
  withTransaction st $ \db ->
    createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now

-- The signature is dummy bytes, since only the JSON round-trip is under test; 80 is the length its decoder accepts.
seededCredential :: BadgeMasterKey -> UTCTime -> BadgeCredential
seededCredential masterKey expiry =
  BadgeCredential {badgeKeyIdx = 1, masterKey, signature = BBSSignature (BS.replicate 80 7), badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}}

seedIssuance :: DBStore -> Int64 -> Text -> BadgeMasterKey -> UTCTime -> UTCTime -> IO ()
seedIssuance st purchaseId issuanceId masterKey at periodEnd =
  withConnection st $ \db ->
    DB.execute
      db
      "INSERT INTO sx_badge_service_badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at) VALUES (?,?,?,?,?,?,?,?)"
      (issuanceId, purchaseId, "supporter" :: Text, at, periodEnd, periodEnd, DB.Binary (LB.toStrict (J.encode (seededCredential masterKey periodEnd))), at)

testKeyPurchaseLookup :: IO ()
testKeyPurchaseLookup = withServiceStore $ \st -> do
  now <- getCurrentTime
  let codeHash = digestFixture 41
  badgeCodeId <- insertCode st codeHash CPSFree 2 now
  keys@(k1, mk1) <- newPurchaseKeys
  Just purchaseId <- claimUse st badgeCodeId now keys
  withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1) >>= \case
    KeyRedeemedUnreadable -> pure ()
    _ -> expectationFailure "expected a purchase with no issuance to be unreadable"
  let firstPeriodEnd = someExpiry
      renewedPeriodEnd = addUTCTime 86400 someExpiry
  seedIssuance st purchaseId "iss-first" mk1 now firstPeriodEnd
  seedIssuance st purchaseId "iss-renewed" mk1 now renewedPeriodEnd
  (unusedKey, _) <- newPurchaseKeys
  withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId unusedKey) >>= \case
    KeyUnredeemed -> pure ()
    _ -> expectationFailure "expected no purchase for a key that never redeemed"
  replayed <- withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1)
  case replayed of
    KeyRedeemed KeyPurchase {badgePurchaseId, credential} -> do
      badgePurchaseId `shouldBe` purchaseId
      credential `shouldBe` seededCredential mk1 renewedPeriodEnd
    _ -> expectationFailure "expected the redeemed key's purchase"

testSameKeyClaimsOnce :: IO ()
testSameKeyClaimsOnce = withServiceStore $ \st -> do
  now <- getCurrentTime
  let codeHash = digestFixture 46
  badgeCodeId <- insertCode st codeHash CPSFree 3 now
  keys <- newPurchaseKeys
  claimUse st badgeCodeId now keys >>= (`shouldSatisfy` isJust)
  -- The key is unique across purchases, so the second insert fails and its transaction returns the use.
  claimUse st badgeCodeId now keys `shouldThrow` anyException
  codeCounts st codeHash `shouldReturn` Just (3, 1)

testMultiUseConcurrentClaimsUpToLimit :: IO ()
testMultiUseConcurrentClaimsUpToLimit = withServiceStore $ \st -> do
  now <- getCurrentTime
  let codeHash = digestFixture 42
  badgeCodeId <- insertCode st codeHash CPSFree 3 now
  contenders <- replicateM 6 newPurchaseKeys
  results <- Async.mapConcurrently (claimUse st badgeCodeId now) contenders
  length (catMaybes results) `shouldBe` 3
  codeCounts st codeHash `shouldReturn` Just (3, 3)

data StubCall
  = StubCreate ServicePaymentMethod OrderDraft
  | StubRead Text
  | StubCancel Text
  | StubListOpen
  | StubRate CryptoCurrency
  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,
    ssRate :: Either ProviderError Rate
  }

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,
      ssRate = Right stubRate
    }

-- | Below the stored invoices' rate of 62500.
stubRate :: Rate
stubRate = Rate {rateText = "60000.5", rateValue = 60000.5}

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) PaidInPart) (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},
      pCurrentRate = Just $ \cc -> do
        record ref (StubRate cc)
        ssRate <$> readIORef ref,
      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", odReference = "badge:0x01"}

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", lBadgesPort = 0, lBadgesStaticDir = staticDir, lServeWebapp = True, lBadgesExportDir = Nothing, lTrustForwardedFor = trustForwarded, lNamesStaticDir = Nothing, lNamesExportDir = Nothing, lNamesPort = Nothing},
      btcpay = Nothing,
      stripe = Nothing,
      poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60},
      appleStore = Nothing,
      playStore = Nothing,
      issuer = Nothing,
      devIssuerKeys = [],
      group = Nothing,
      names = Nothing,
      devAcceptUnverifiedStoreReceipts = False,
      devCheckStoreDuringCoverage = False,
      devCreditTestPurchases = 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", lBadgesPort = 0, lBadgesStaticDir = staticDir, lServeWebapp = False, lBadgesExportDir = Just outDir, lTrustForwardedFor = False, lNamesStaticDir = Nothing, lNamesExportDir = Nothing, lNamesPort = Nothing}
        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)

namesShellHtml :: LB.ByteString
namesShellHtml = "<!doctype html><title>simplex.domains</title><meta name=\"stripe-publishable-key\" content=\"\">"

namesShellWithKey :: LB.ByteString
namesShellWithKey = "<!doctype html><title>simplex.domains</title><meta name=\"stripe-publishable-key\" content=\"pk_test_injected\">"

namesFont :: LB.ByteString
namesFont = "wOF2 Manrope Bold"

namesFontPath :: FilePath
namesFontPath = "fonts" </> "Manrope" </> "Manrope-Bold.woff2"

namesManifest :: LB.ByteString
namesManifest = "{\"name\":\"SimpleX names\"}"

prepareNamesDir :: FilePath -> IO FilePath
prepareNamesDir root = do
  let namesDir = root </> "names"
  createDirectoryIfMissing True (namesDir </> "fonts" </> "Manrope")
  LB.writeFile (namesDir </> "index.html") namesShellHtml
  LB.writeFile (namesDir </> namesFontPath) namesFont
  LB.writeFile (namesDir </> "manifest.webmanifest") namesManifest
  pure namesDir

testExportsBothSites :: IO ()
testExportsBothSites = do
  createDirectoryIfMissing True "tests/tmp"
  withTempDirectory "tests/tmp" "names-export" $ \root -> do
    staticDir <- prepareStaticDir root
    namesDir <- prepareNamesDir root
    let badgesOut = root </> "badges-out"
        namesOut = root </> "names-out"
        lc = (listener (testServiceConfig staticDir False)) {lServeWebapp = False, lBadgesExportDir = Just badgesOut, lNamesStaticDir = Just namesDir, lNamesExportDir = Just namesOut}
    exportWebapp lc (Just publishTestStripe)
    badgesShell <- LB.readFile (badgesOut </> "index.html")
    LB.toStrict badgesShell `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\""
    LB.readFile (badgesOut </> "assets" </> buildHash </> "main.js") >>= (`shouldBe` assetJs)
    doesFileExist (badgesOut </> namesFontPath) `shouldReturn` False
    LB.readFile (namesOut </> "index.html") >>= (`shouldBe` namesShellWithKey)
    LB.readFile (namesOut </> namesFontPath) >>= (`shouldBe` namesFont)
    LB.readFile (namesOut </> "manifest.webmanifest") >>= (`shouldBe` namesManifest)
    doesFileExist (namesOut </> "sw.js") `shouldReturn` False

-- | The badges site's client and the names site's, each on the port the env listens on for it.
withBothSites :: (WebClient -> WebClient -> IO a) -> IO a
withBothSites action =
  withServiceStore $ \st -> do
    createDirectoryIfMissing True "tests/tmp"
    withTempDirectory "tests/tmp" "names-static" $ \root -> do
      staticDir <- prepareStaticDir root
      namesDir <- prepareNamesDir root
      let base = testServiceConfig staticDir True
          cfg = base {listener = (listener base) {lBadgesPort = 8080, lNamesStaticDir = Just namesDir, lNamesPort = Just 8081}, stripe = Just publishTestStripe}
      withListener [] True holdMicros st cfg $ \env badges@(mgr, _) -> do
        map fst (webListeners env) `shouldBe` [8080, 8081]
        [_, (_, namesSite)] <- pure (webListeners env)
        Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure namesSite) $ \prt ->
          action badges (mgr, "http://127.0.0.1:" <> show prt)

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

testEachPortServesItsSite :: IO ()
testEachPortServesItsSite = bounded "each port its site" $ withBothSites $ \badges names -> do
  forM_ ["simplex.domains", "badges.simplex.chat", "127.0.0.1"] $ \host -> do
    namesShell <- webGetAt names host "/"
    (statusOf namesShell, responseBody namesShell) `shouldBe` (200, namesShellWithKey)
    headerOf namesShell hContentType `shouldBe` Just "text/html; charset=utf-8"
    badgesShell <- webGetAt badges host "/"
    statusOf badgesShell `shouldBe` 200
    LB.toStrict (responseBody badgesShell) `shouldSatisfy` BC.isInfixOf "SimpleX badges"
    LB.toStrict (responseBody badgesShell) `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\""
  namesIndex <- webGet names "/index.html"
  (statusOf namesIndex, responseBody namesIndex) `shouldBe` (200, namesShellWithKey)
  (statusOf <$> webGet names ("/assets/" <> buildHash <> "/main.js")) `shouldReturn` 404
  (statusOf <$> webGet names "/sw.js") `shouldReturn` 404
  (statusOf <$> webGet badges ("/" <> namesFontPath)) `shouldReturn` 404
  (statusOf <$> webGet badges "/manifest.webmanifest") `shouldReturn` 404
  postShell <- webRequest names "POST" "/" []
  statusOf postShell `shouldBe` 405
  forM_ [badges, names] $ \client -> do
    api <- webGet client "/api/invoice"
    statusOf api `shouldBe` 405
    headerOf api "Allow" `shouldBe` Just "POST"
    webhook <- webGet client "/webhooks/stripe"
    statusOf webhook `shouldBe` 405
    headerOf webhook "Allow" `shouldBe` Just "POST"

testOneListenerWithoutTheNamesSite :: IO ()
testOneListenerWithoutTheNamesSite =
  withServiceStore $ \st -> do
    createDirectoryIfMissing True "tests/tmp"
    withTempDirectory "tests/tmp" "badge-static" $ \root -> do
      staticDir <- prepareStaticDir root
      let base = testServiceConfig staticDir False
          apiOnly = base {listener = (listener base) {lBadgesPort = 8080, lServeWebapp = False}}
      forM_ [base {listener = (listener base) {lBadgesPort = 8080}}, apiOnly] $ \cfg ->
        withListener [] True holdMicros st cfg $ \env _ -> map fst (webListeners env) `shouldBe` [8080]

testServesANamesAsset :: IO ()
testServesANamesAsset = bounded "names asset" $ withBothSites $ \_ names -> do
  font <- webGet names ("/" <> namesFontPath)
  (statusOf font, responseBody font) `shouldBe` (200, namesFont)
  headerOf font hContentType `shouldBe` Just "font/woff2"
  manifest <- webGet names "/manifest.webmanifest"
  (statusOf manifest, responseBody manifest) `shouldBe` (200, namesManifest)
  headerOf manifest hContentType `shouldBe` Just "application/manifest+json"
  (statusOf <$> webGet names "/fonts/Manrope/absent.woff2") `shouldReturn` 404

namesTraversalSpellings :: [String]
namesTraversalSpellings =
  [ "/../dist/index.html",
    "/%2e%2e/dist/index.html",
    "/..%2fdist%2findex.html",
    "/fonts/../../dist/index.html",
    "/fonts/Manrope/%2e%2e/%2e%2e/%2e%2e/secret.txt",
    "/..%2fsecret.txt"
  ]

testNamesTraversalRefused :: IO ()
testNamesTraversalRefused = bounded "names traversal" $ withBothSites $ \_ names ->
  forM_ namesTraversalSpellings $ \target -> do
    r <- webGet names target
    (target, statusOf r, responseBody r) `shouldBe` (target, 404, notFoundBody)

testSiteDirsMustExist :: IO ()
testSiteDirsMustExist = do
  createDirectoryIfMissing True "tests/tmp"
  withTempDirectory "tests/tmp" "site-dirs" $ \root -> do
    staticDir <- prepareStaticDir root
    namesDir <- prepareNamesDir root
    let absent = root </> "absent"
        lc = listener (testServiceConfig staticDir False)
        missing site dir = Left ("listener." <> site <> "_static_dir = " <> dir <> " is not a directory; set it to the " <> site <> " build, since the default is the Docker image's path")
    checkSiteDirs lc `shouldReturn` Right ()
    checkSiteDirs lc {lNamesStaticDir = Just namesDir, lNamesPort = Just 8081} `shouldReturn` Right ()
    checkSiteDirs lc {lBadgesStaticDir = absent} `shouldReturn` missing "badges" absent
    checkSiteDirs lc {lBadgesStaticDir = absent, lServeWebapp = False} `shouldReturn` Right ()
    checkSiteDirs lc {lBadgesStaticDir = absent, lServeWebapp = False, lBadgesExportDir = Just (root </> "out")} `shouldReturn` missing "badges" absent
    checkSiteDirs lc {lNamesStaticDir = Just absent, lNamesPort = Just 8081} `shouldReturn` missing "names" absent
    checkSiteDirs lc {lServeWebapp = False, lNamesStaticDir = Just absent} `shouldReturn` Right ()
    checkSiteDirs lc {lServeWebapp = False, lNamesStaticDir = Just absent, lNamesExportDir = Just (root </> "names-out")} `shouldReturn` missing "names" absent
    checkSiteDirs lc {lBadgesStaticDir = root </> "secret.txt"} `shouldReturn` missing "badges" (root </> "secret.txt")

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 Nothing
  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-store-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-store-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 (weHttp env) readLimit) clients
  held <- Map.size <$> readTVarIO (heBuckets (weHttp env))
  held `shouldSatisfy` \n -> n > 0 && n <= maxBuckets
  answers <- mapM (\_ -> takeToken (weHttp env) readLimit "203.0.113.9") [1 .. readsPerMinute + 1]
  length (filter isJust answers) `shouldBe` 1

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

awaitWaitingCount :: WebEnv -> Int -> IO ()
awaitWaitingCount env n = do
  parked <- waitingCount (weWaiters env)
  when (parked /= n) $ threadDelay 10000 >> awaitWaitingCount env n

testHoldTimeoutReportsAnUnpublishedChange :: IO ()
testHoldTimeoutReportsAnUnpublishedChange = bounded "hold timeout" $ withWebAppHolding testHold $ \env client -> do
  iid <- seedOpenInvoice env
  started <- getCurrentTime
  held <- async $ webGet client (invoicePath iid <> "?wait=open")
  awaitWaitingCount env 1
  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

-- | Warp reports an exception after sending the 500, and serves the connection's next request only after that report.
testHandlerExceptionIsLogged :: IO ()
testHandlerExceptionIsLogged = bounded "handler exception logged" $ withWebAppExpectingThrow $ \env client -> do
  iid <- seedOpenInvoice env
  breakStore (weStore env)
  logs <- capturingStderr $ do
    statusOf <$> webGet client (invoicePath iid) >>= (`shouldBe` 500)
    statusOf <$> webGet client "/" >>= (`shouldBe` 200)
  logs `shouldSatisfy` loggedError "store service: a web request failed: "
  filter (not . ("[ERROR " `T.isPrefixOf`)) (filter ("badge_code_invoices" `T.isInfixOf`) (T.lines logs)) `shouldBe` []

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
  irProduct row `shouldBe` IPBadge BTSupporter 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"
      odReference draft `shouldBe` "badge:" <> hex (codeDigest sampleCode)
    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
  irProduct row `shouldBe` IPBadge BTLegend 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

-- | Nothing confirmed and no units, as the badge paths read it.
rcv :: Word32 -> Maybe Text -> Received
rcv amount crypto =
  Received
    { rcvAmount = CurrencyAmount amount,
      rcvCrypto = crypto,
      rcvDue = Nothing,
      rcvUnits = Nothing,
      rcvInvoicedUnits = Nothing,
      rcvRate = Nothing,
      rcvConfirmed = Confirmed {cfCents = CurrencyAmount 0, cfUnits = Nothing},
      rcvUncreditable = Nothing
    }

settle :: DBStore -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus)
settle st iid signal at = newWaiters >>= \waiters -> settleOrder st waiters Nothing 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")) PaidInPart) 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) PaidInPart) 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")) PaidInPart) settleAt `shouldReturn` Right ISExpired
  settle st iid (SigClosed (rcv 200 (Just "0.00020000")) PaidInPart) 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")) PaidInPart
    ]
  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 Nothing 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) Nothing 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) Nothing 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 (rcv 500 (Just "0.00050000")) False settleAt
  withTransaction st $ \db -> upsertPayment db row PSPending (rcv 200 (Just "0.00020000")) 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 (rcv 100 Nothing) False settleAt
  withTransaction st $ \db -> upsertPayment db row' PSSettled (rcv 500 (Just "0.00050000")) 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 Nothing 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")) PaidInPart)
    ]
  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")
  awaitWaitingCount env 1
  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) Nothing (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) Nothing (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")) PaidInPart)]
  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

stderrCaptureLock :: MVar ()
stderrCaptureLock = unsafePerformIO $ newMVar ()
{-# NOINLINE stderrCaptureLock #-}

-- testLogRecordsWhole changes stderr's buffering, so put the original setting back.
capturingStderr :: IO () -> IO Text
capturingStderr action = withMVar stderrCaptureLock $ \_ -> 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
      fd <- handleToFd h
      hFlush stderr
      saved <- IODevice.dup FD.stderr
      (IODevice.dup2 fd FD.stderr >> action) `E.finally` (hFlush stderr >> IODevice.dup2 saved FD.stderr >> IODevice.close saved >> hSetBuffering stderr buffering)
    T.readFile path

logThreads :: Int
logThreads = 16

recordsPerThread :: Int
recordsPerThread = 50

-- | Every tenth record is longer than a handle's 8 KiB buffer, so a write committed buffer by buffer splits it.
longRecordEvery, longRecordPad :: Int
longRecordEvery = 10
longRecordPad = 9000

logRecordTag :: Text
logRecordTag = "log-whole"

logRecord :: Int -> Int -> Text
logRecord t i = T.unwords [logRecordTag, tshow t, tshow i, T.replicate pad "x"]
  where
    pad :: Int
    pad = if i `mod` longRecordEvery == 0 then longRecordPad else i

infoRecord :: Text -> Maybe Text
infoRecord ln = T.stripPrefix "[INFO " ln >>= T.stripPrefix "] " . snd . T.breakOn "] "

testLogRecordsWhole :: IO ()
testLogRecordsWhole = do
  outcomes <- forM bufferModes $ \mode -> do
    logs <- capturingStderr $ do
      hSetBuffering stderr mode
      Async.forConcurrently_ [1 .. logThreads] $ \t -> forM_ [1 .. recordsPerThread] $ logInfo . logRecord t
    let ours = filter (logRecordTag `T.isInfixOf`) (T.lines logs)
        whole :: Text -> Bool
        whole ln = maybe False (`S.member` expected) (infoRecord ln)
    pure (mode, length ours, S.size (S.fromList (mapMaybe infoRecord ours)), map (T.take 200) (take 3 (filter (not . whole) ours)))
  outcomes `shouldBe` map (\mode -> (mode, S.size expected, S.size expected, [])) bufferModes
  where
    bufferModes :: [BufferMode]
    bufferModes = [NoBuffering, LineBuffering, BlockBuffering Nothing]
    expected :: S.Set Text
    expected = S.fromList [logRecord t i | t <- [1 .. logThreads], i <- [1 .. recordsPerThread]]

loggedError :: Text -> Text -> Bool
loggedError message = any (\l -> "[ERROR " `T.isInfixOf` 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 $ \_ poller _ _ -> do
  now <- getCurrentTime
  forM_ [1 .. maxSkipReasons + 500] $ \i -> dueToWarn poller now ("btcpay invoice p-" <> tshow i <> ": unknown method")
  runOnePass poller
  held <- Map.size <$> readTVarIO (peSkipped poller)
  held `shouldSatisfy` (<= maxSkipReasons)

testStrangerSkipsShareOneWarning :: IO ()
testStrangerSkipsShareOneWarning = bounded "stranger skips" $ withStubPoller raceHold $ \ref poller _ _ -> do
  setSkipped ref [(Just ("stranger-" <> tshow i), "btcpay invoice stranger-" <> tshow i <> ": unknown method") | i <- [1 .. 3 :: Int]]
  runOnePass poller
  Map.size <$> readTVarIO (peSkipped poller) `shouldReturn` 1

-- | 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
  -- only the invoice that failed is kept out of the sweep
  invoiceStatus (weStore env) overdue `shouldReturn` ISExpired

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
  newWaiters >>= \waiters -> cancelOpenInvoice st waiters Nothing 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")
  awaitWaitingCount env 1
  waitingCount (weWaiters env) `shouldReturn` 1
  settleOrder (weStore env) (weWaiters env) Nothing 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) Nothing 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) Nothing iid funded settleAt `shouldReturn` Right ISOpen
  threadDelay holdParkDelay
  stillParked <- Async.poll held
  stillParked `shouldSatisfy` isNothing

  settleOrder (weStore env) (weWaiters env) Nothing 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) Nothing 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) Nothing 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) Nothing iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInFull) someCreated
    `shouldReturn` Right ISOpen
  settleOrder (weStore env) (weWaiters env) Nothing 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)

testViewCarriesAClosedPaidVerdict :: IO ()
testViewCarriesAClosedPaidVerdict = bounded "closed in full" $ withCheckout $ \_ env client -> do
  iid <- seedOpenInvoice env
  let readVerdict = (\o -> (fieldOf o "status", fieldOf o "paidInFull", fieldOf o "amountPaid")) <$> (jsonObject =<< webGet client (invoicePath iid))
  settleOrder (weStore env) (weWaiters env) Nothing iid (SigClosed (rcv 250 (Just "0.00025000")) PaidInPart) someCreated
    `shouldReturn` Right ISExpired
  readVerdict `shouldReturn` (Just (J.String "expired"), Just (J.Bool False), Just (J.Number 250))
  settleOrder (weStore env) (weWaiters env) Nothing iid (SigClosed (rcv 500 (Just "0.00050000")) PaidInFull) someCreated
    `shouldReturn` Right ISExpired
  readVerdict `shouldReturn` (Just (J.String "expired"), Just (J.Bool True), Just (J.Number 500))

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]