mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-09-27 15:48:54 +00:00
sh
5ef9080c09
* badges: fill skip log in cap test without logging * badges: aggregate foreign invoice skip warnings * badges: document dedicated payment store
3373 lines
166 KiB
Haskell
3373 lines
166 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Bots.BadgeService.WebTests (badgeWebTests) where
|
|
|
|
import BadgeService.Catalog (catalogCurrency, defaultCatalog)
|
|
import BadgeService.Config (BTCPayConfig (..), ListenerConfig (..), PollConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..))
|
|
import BadgeService.Orders (codeLifetime, settleOrder)
|
|
import BadgeService.Poller
|
|
import BadgeService.Providers
|
|
import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages)
|
|
import BadgeService.Providers.Stripe (stripeProvider)
|
|
import BadgeService.Store (CodeRedemption (..), IssuedCode (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getBadgeCode, insertBadgeCode, revokeCode)
|
|
import BadgeService.Store.Invoices
|
|
import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount)
|
|
import BadgeService.Web.Server
|
|
import Bots.BadgeService.BotTests (newPurchaseKeys)
|
|
import Bots.BadgeService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource)
|
|
import Bots.BadgeService.FakeBTCPay
|
|
import Bots.BadgeService.FakeStripe (FakeStripe (..), fakeIntentStatus, setIntentState, stripeEvent, stripeSigHeader, withFakeStripe)
|
|
import Control.Concurrent (forkIO, threadDelay)
|
|
import Control.Concurrent.Async (async, wait)
|
|
import qualified Control.Concurrent.Async as Async
|
|
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
|
|
import Control.Concurrent.STM (atomically, modifyTVar', readTVarIO)
|
|
import qualified Control.Exception as E
|
|
import Control.Monad (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.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
|
|
import Data.List (sort, sortOn)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe (isJust, isNothing, fromMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import qualified Data.Text.IO as T
|
|
import Data.Time.Calendar (fromGregorian)
|
|
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, picosecondsToDiffTime, secondsToDiffTime)
|
|
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
|
|
import Data.Word (Word32, Word8)
|
|
import GHC.IO.Handle (hDuplicate, hDuplicateTo)
|
|
import Network.HTTP.Client (Manager, Request (..), RequestBody (..), Response, defaultManagerSettings, httpLbs, newManager, parseRequest, responseBody, responseHeaders, responseStatus, responseTimeoutMicro)
|
|
import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType)
|
|
import Network.HTTP.Types.Status (statusCode)
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import Simplex.Chat.Badges (BadgeType (..))
|
|
import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..))
|
|
import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..))
|
|
import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..), ServicePaymentMethod (..))
|
|
import Simplex.Messaging.Agent.Store.Common (DBStore (..), withConnection, withTransaction)
|
|
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
|
import Simplex.Messaging.Agent.Store.Interface
|
|
import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Encoding.String (textDecode, textEncode)
|
|
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
|
|
import System.Directory (createDirectoryIfMissing, createFileLink, doesFileExist, listDirectory)
|
|
import System.FilePath ((</>))
|
|
import System.IO (IOMode (..), hClose, hGetBuffering, hSetBuffering, stderr, withFile)
|
|
import System.IO.Unsafe (unsafePerformIO)
|
|
import System.Timeout (timeout)
|
|
import Test.Hspec
|
|
import Text.Read (readMaybe)
|
|
import UnliftIO.Temporary (withTempDirectory)
|
|
|
|
#if defined(dbPostgres)
|
|
import BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations)
|
|
import ChatClient (testDBConnectInfo, testDBConnstr)
|
|
import Database.PostgreSQL.Simple (Only (..))
|
|
import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser)
|
|
#else
|
|
import BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations)
|
|
import Data.String (fromString)
|
|
import Database.SQLite.Simple (Only (..))
|
|
import qualified Database.SQLite.Simple as SQL
|
|
import Simplex.Messaging.Agent.Store.DB (TrackQueries (..))
|
|
#endif
|
|
|
|
#if defined(dbPostgres)
|
|
withServiceStore :: (DBStore -> IO a) -> IO a
|
|
withServiceStore action =
|
|
E.bracket_
|
|
(dropDatabaseAndUser testDBConnectInfo >> createDBAndUserIfNotExists testDBConnectInfo)
|
|
(dropDatabaseAndUser testDBConnectInfo)
|
|
$ do
|
|
Right st <- createDBStore serviceDBOpts badgeServiceSchemaMigrations (MigrationConfig MCError Nothing)
|
|
action st `E.finally` closeDBStore st
|
|
where
|
|
serviceDBOpts =
|
|
DBOpts
|
|
{ connstr = BC.pack testDBConnstr,
|
|
schema = "sx_badge_service_web_test",
|
|
poolSize = 4,
|
|
createSchema = True
|
|
}
|
|
#else
|
|
withServiceStore :: (DBStore -> IO a) -> IO a
|
|
withServiceStore action = do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-web" $ \dir -> do
|
|
Right st <- createDBStore (DBOpts (dir </> "badge_service_test.db") [] "" False True TQOff) badgeServiceSchemaMigrations (MigrationConfig MCError Nothing)
|
|
action st `E.finally` closeDBStore st
|
|
#endif
|
|
|
|
columnsOf :: DBStore -> Text -> IO [Text]
|
|
columnsOf st table = withConnection st $ \db ->
|
|
#if defined(dbPostgres)
|
|
map fromOnly
|
|
<$> DB.query
|
|
db
|
|
"SELECT column_name FROM information_schema.columns WHERE table_schema = current_schema() AND table_name = ?"
|
|
(Only table)
|
|
#else
|
|
map fromOnly
|
|
<$> DB.query_ db (fromString ("SELECT name FROM pragma_table_info('" ++ T.unpack table ++ "')"))
|
|
#endif
|
|
|
|
badgeWebTests :: Spec
|
|
badgeWebTests = do
|
|
describe "badge service schema" $ do
|
|
it "carries the five service-only columns" testServiceColumns
|
|
it "refuses a duplicate provider_ref" testProviderRefUnique
|
|
describe "badge service store" $ do
|
|
it "writes the invoice, its code and their link atomically" testCreationIsAtomic
|
|
it "newInvoiceId is 128 CSPRNG bits, base64url, and two calls differ" testNewInvoiceIdRandom
|
|
it "codeHashExists is true for a hash already written" testCodeHashExists
|
|
it "expireOverdue moves only open, past-expiry rows, and names them" testExpireOverdueMovesOnlyQualifying
|
|
it "expireOverdue moves only the overdue invoices it is given" testExpireOverdueMovesOnlyTheNamed
|
|
it "expireOverdue never sweeps an invoice that has been paid into" testExpireOverdueSparesAFundedInvoice
|
|
it "expireOverdue spares an invoice funded by dust, or by the verdict alone" testExpireOverdueSparesAZeroAmount
|
|
it "readCatalogRows drops every disabled row" testReadCatalogRowsDropsDisabled
|
|
it "a revoked code cannot be redeemed, and a redeemed code cannot be revoked" testRevokeAndRedeemExcludeEachOther
|
|
it "every timestamp round-trips to the second" testTimestampRoundTrip
|
|
describe "badge service catalog seed" $ do
|
|
it "writes the compiled-in catalog into an empty database" testSeedWritesTheCatalog
|
|
it "leaves exactly one row per id when the service starts twice" testSeedIsIdempotent
|
|
it "leaves a price and an offer an operator withdrew withdrawn" testSeedNeverResurrectsAWithdrawnRow
|
|
it "seeds exactly what web/src/catalog.ts compiles into the page" testSeedMatchesWebCatalog
|
|
it "prices a btc checkout, and answers card provider_unavailable" testSeededCatalogSellsSomething
|
|
describe "BadgeService.Providers stub" $ do
|
|
it "constructs a Provider record and records every call, in order" testStubProviderRecordsCalls
|
|
it "makes pCreateInvoice fail on demand, so provider_unavailable is exercisable" testStubProviderCreateFailsOnDemand
|
|
it "records nothing when the caller never reaches the provider" testStubProviderNotCalledWhenSkipped
|
|
describe "badge service web" $ do
|
|
it "serves the shell at / and a hashed asset under /assets" testServesTheBuild
|
|
it "fills the shell's publishable key from the ini at boot" testShellCarriesPublishableKey
|
|
it "caches by where the file is, not by how the request spelled it" testCachingFollowsTheResolvedPath
|
|
it "serves the built web app, exactly as it is shipped" testServesBuiltWebApp
|
|
it "serves no static routes when serve_webapp is off, and still answers the API" testServeWebappOff
|
|
it "exports the injected webapp to a folder for a proxy to serve" testExportWebapp
|
|
it "refuses every traversal spelling, by canonicalisation" testTraversalRefused
|
|
it "answers the read fields, with cryptoCurrency lowercase" testInvoiceView
|
|
it "names the confirmations settlement needs, from the speed policy" testViewNamesTheConfirmationsSettlementNeeds
|
|
it "omits the confirmations where no provider is configured" testViewOmitsConfirmationsWithoutBTCPay
|
|
it "carries the provider's paid-in-full verdict, which the amounts cannot give" testViewCarriesTheProvidersPaidVerdict
|
|
it "never withdraws a paid-in-full verdict on a later read" testPaidVerdictIsNotWithdrawnByALaterRead
|
|
it "answers an unknown id with 404 not_found and nothing else" testUnknownInvoiceIsOpaque
|
|
it "releases a held wait when a payment lands without settling" testHeldWaitWakesOnAPaymentThatDoesNotSettle
|
|
it "leaves a held wait alone when a pass writes nothing" testHeldWaitIsNotWokenByAPassThatWroteNothing
|
|
it "is not woken by the same figures arriving again" testARepeatedSignalDoesNotWakeAHold
|
|
it "carries Cache-Control: no-store on every API response" testApiIsNeverCached
|
|
it "answers a known path reached with the wrong method with 405" testWrongMethodIs405
|
|
it "answers a path this task does not implement with 404" testUnroutedPathIs404
|
|
it "answers ?wait= at once when it is terminal, stale or unparseable" testWaitAnswersAtOnce
|
|
it "answers at once when it holds a payment the page has not seen" testHoldAnswersAPaymentThePageHasNotSeen
|
|
it "answers a verdict that arrived with no figure to go with it" testHoldAnswersAVerdictWithNoFigure
|
|
it "holds ?wait=open, and is woken by publish rather than polled" testHoldIsWokenNotPolled
|
|
it "refuses over sixty reads a minute from one IP" testReadRateLimit
|
|
it "takes the client from X-Forwarded-For only when it is trusted" testForwardedForOnlyWhenTrusted
|
|
it "uses a forwarded client only when it parses as an IP address" testForwardedForMustBeAnAddress
|
|
it "holds the bucket map under its cap through a flood of distinct clients" testBucketsStayBounded
|
|
it "answers a hold from the row it read, not from the status it woke on" testHoldReportsTheRowNotTheWake
|
|
it "answers a hold that timed out with a change nothing published" testHoldTimeoutReportsAnUnpublishedChange
|
|
it "answers a handler exception with 500 internal, and keeps serving" testHandlerExceptionIsContained
|
|
describe "badge service settlement" $ do
|
|
it "settles an open invoice: paid, a settled payment row, and the code" testSettlesAnOpenInvoice
|
|
it "settles an expired invoice, because late settlement is routine" testLateSettlementIsLegal
|
|
it "records what arrived without moving an unsettled invoice" testFundedRecordsWithoutMoving
|
|
it "expires an open invoice whose window closed, recording what arrived" testClosedExpiresAnOpenInvoice
|
|
it "writes no payment for a window that closed on nothing" testClosedWithNothingWritesNoPayment
|
|
it "rewrites the same values when a closed window is redelivered" testClosedReplayIsIdempotent
|
|
it "changes nothing for any signal against a paid invoice" testPaidRefusesEverySignal
|
|
it "takes the larger of the stored and the reported amount" testAmountIsMonotonic
|
|
it "measures the code deadline from the first settlement" testDeadlineIsFromTheFirstSettlement
|
|
it "leaves an invoice another transaction moved first alone" testStatusGuardRefusesAStaleObservation
|
|
it "publishes what it found when it loses the status guard" testLosingTheStatusGuardStillWakesTheHold
|
|
it "never downgrades a settled payment row" testSettledPaymentIsNotDowngraded
|
|
it "fills in a crypto amount that only arrived later" testCryptoAmountFillsInFromNull
|
|
it "answers Left for an invoice this service does not hold" testUnknownInvoiceSettlesNothing
|
|
it "publishes after the commit, so a woken reader finds the row" testPublishIsAfterCommit
|
|
it "wakes a request the listener is holding, from settleOrder itself" testSettlementWakesAHeldRequest
|
|
it "reports settledAt from the payment row, not from the invoice" testSettledAtIsThePaymentRow
|
|
it "refuses a settlement instant the provider cannot have meant" testAbsurdSettledInstantIsRefused
|
|
it "refuses a settlement instant in the future, as a millisecond clock gives" testFutureSettledInstantIsRefused
|
|
describe "badge service poller" $ do
|
|
it "settles a payment with no webhook delivered anywhere" testSettlesWithNoWebhookAtAll
|
|
it "reads only the invoices it is waiting on, and lists on the stray cadence" testPassReadsWhatItAwaits
|
|
it "asks the provider nothing when it is waiting on nothing" testIdlePassAsksNothing
|
|
it "lists instead of reading once too many invoices are open" testManyOpenInvoicesList
|
|
it "sweeps nothing when no provider can account for the rows" testNoProviderAccountsForNothing
|
|
it "holds the sweep for one row a configured provider does not own" testMixedProvidersHoldTheSweep
|
|
it "sends one list for a bulk pass, and none for the next one that reads" testBulkListIsTheOnlyList
|
|
it "hands every signal the pass returned to settleOrder, unless the row answers it" testEverySignalSettles
|
|
it "passes over a listed invoice this service does not hold" testForeignRefIsPassedOver
|
|
it "changes nothing when the provider fails, and settles on the next pass" testProviderFailureLosesNothing
|
|
it "reads the cadence fresh from the waiters each pass" testCadenceFollowsTheWaiters
|
|
it "cuts an idle sleep short when a browser arrives during it" testWaiterCutsTheIdleSleepShort
|
|
it "serves a hint batch without postponing a pass that falls due" testHintsDoNotPostponeThePass
|
|
it "floors the cadence, so a zero in the ini is not a busy loop" testCadenceHasAFloor
|
|
it "wakes a request the listener is holding, from a poller pass" testPollerWakesAHeldRequest
|
|
it "expires an open invoice past the ten-minute grace, and reads before it does" testSweepExpiresPastTheGrace
|
|
it "writes status alone, so a later SigClosed still records what arrived" testSweepWritesStatusAlone
|
|
it "wakes a request held on an invoice it expires" testSweepWakesAHeldRequest
|
|
it "cancels at a provider that keeps its invoice payable, then expires it" testSweepCancelsBeforeExpiring
|
|
it "keeps an invoice open while its provider refuses the cancel" testSweepKeepsOpenWhenCancelFails
|
|
it "settles an invoice past the settle window whose cancel is refused" testSweepSettlesWhatItCannotCancel
|
|
it "expires an invoice whose cancel answer was lost, from the read that follows" testSweepExpiresWhatAReadShowsCancelled
|
|
it "expires an invoice past the settle window once its cancel has failed for an hour, and reports it" testSweepGivesUpPastTheWindow
|
|
it "cancels overdue invoices oldest first, keeping the failures of those left for later" testSweepKeepsFailuresBeyondTheCap
|
|
it "expires an old invoice whose provider is gone, without a call" testSweepExpiresWithoutItsProvider
|
|
it "warns once per order while a cancel keeps failing" testSweepWarnsOncePerOrder
|
|
it "cancels at most a pass-sized batch, leaving the rest for the next pass" testSweepCapsCancelsPerPass
|
|
it "reports a skipped invoice once, and again only after the interval" testSkipWarningsAreRateLimited
|
|
it "warns once for a provider that stays down, not once a pass" testOutageWarnsOnceNotEveryPass
|
|
it "holds the skip log under its cap when every reason is fresh" testSkipReasonsStayBounded
|
|
it "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 the rest of the pass around an invoice that throws" testOneBadInvoiceDoesNotStopThePass
|
|
it "pages past a hundred open invoices, a request per hundred" testListPaginates
|
|
it "stops paging at its ceiling rather than looping on a server that ignores take" testPagingStopsAtTheCeiling
|
|
describe "badge service webhook" $ do
|
|
it "verifies a real BTCPay signature over the bytes as received, and queues" testWebhookVerifiesARealSignature
|
|
it "hands the adapter the raw body, byte for byte" testWebhookPassesTheRawBytes
|
|
it "queues a read and answers 200 empty, reaching no provider" testWebhookQueuesARead
|
|
it "settles by the poller's own path, so there is one settlement lane" testWebhookSettlesByThePollerPath
|
|
it "answers at once even when a read at the provider takes a second" testWebhookDoesNotWaitOnTheProvider
|
|
it "answers 400 empty, with no detail, for a signature that does not verify" testWebhookRefusesASignature
|
|
it "answers 200 for an unhandled type, an unknown ref and the other lane's ref" testWebhookIgnoresWhatItCannotActOn
|
|
it "refuses a body over the 64 KB cap before parsing or verifying it" testWebhookRefusesAnOversizedBody
|
|
it "queues a read of an order once, however often it is hinted before being served" testReadHintQueuedOnce
|
|
it "drops a hint rather than blocking when the queue is full" testWebhookDropsAHintWhenFull
|
|
it "answers 200 rather than any 5xx when the adapter or the store throws" testWebhookNeverAnswers5xx
|
|
describe "badge service checkout" $ do
|
|
it "answers the checkout fields and writes the three rows" testCreateInvoice
|
|
it "carries no code and no code hash, over the raw bytes" testCreateCarriesNoCode
|
|
it "tells the provider xmr rather than the chain another request used" testXmrReachesTheProviderAsXmr
|
|
it "derives badgeType, months and amount from the catalog, never from the body" testCreateDerivesFromCatalog
|
|
it "refuses every catalog_changed condition before the provider" testCatalogRefusalCostsNothing
|
|
it "refuses a code_hash already sold before the provider" testCodeConflictCostsNothing
|
|
it "maps a code_hash unique violation that raced the check to 409, not 500" testRacingCodeHashIsConflict
|
|
it "answers 500 and names the abandoned invoice when the store is lost" testStoreLostAfterTheProviderCreated
|
|
it "refuses a malformed body, an unknown method and a malformed codeHash" testBadRequestCostsNothing
|
|
it "refuses a body over the size cap before reading it all" testOversizedBodyCostsNothing
|
|
it "answers method card with provider_unavailable when no Stripe provider is configured" testCardUnconfigured503
|
|
it "answers a provider that failed to create with provider_unavailable, writing nothing" testProviderFailureWritesNothing
|
|
it "refuses the sixth create in a minute, without reaching the provider" testCreateRateLimit
|
|
describe "badge service card" $ do
|
|
it "creates a Stripe PaymentIntent, carrying its clientSecret and a stripe invoice row" testCardCreatesSession
|
|
it "cancels an overdue card order's intent at Stripe before expiring it" testCardSweepCancelsTheIntent
|
|
it "derives the shown expiry from stripe.session_minutes, not the btcpay window" testCardExpiryFollowsSessionMinutes
|
|
it "settles a card invoice from a signed payment_intent.succeeded and a pass" testCardWebhookSettles
|
|
describe "badge service cancel" $ do
|
|
it "expires the invoice here and invalidates it at the provider" testCancelClosesTheInvoiceAtBothEnds
|
|
it "wakes a hold another tab is sitting on" testCancelWakesAHeldRequest
|
|
it "refuses to cancel an invoice that is no longer open" testCancelIsRefusedOnceItIsNotOpen
|
|
it "refuses to cancel an invoice awaiting confirmation" testCancelIsRefusedOnceItIsFunded
|
|
it "leaves the invoice open when the provider refuses" testCancelLeavesTheInvoiceOpenWhenTheProviderFails
|
|
it "expires an invoice a payment landed on while the provider was being told" testCancelExpiresAFundedInvoice
|
|
it "answers an unknown id with the same 404 the read does" testCancelIsOpaqueForAnUnknownInvoice
|
|
it "answers GET with 405 and Allow: POST" testCancelRefusesOtherMethods
|
|
describe "badge service scenarios" $ do
|
|
it "buys a code: create, pay at BTCPay, one pass, paid" scenarioPaidPurchase
|
|
it "wakes a wait held from before the settlement, within a second of it" scenarioHeldWaitWakes
|
|
it "reports a partial payment and leaves the invoice open" scenarioPartPaymentIsReported
|
|
it "reports what an expiry received, and sells no code for it" scenarioExpiryReportsWhatArrived
|
|
it "settles an expired invoice late, because confirmation after expiry is routine" scenarioLateSettlement
|
|
it "changes nothing when the same settlement is seen a second time" scenarioReplayChangesNothing
|
|
it "closes an invalid invoice as expired, on the same screen" scenarioInvalidClosesAsExpired
|
|
it "refuses a second invoice for one code hash, creating none at BTCPay" scenarioCodeConflictCreatesNothing
|
|
it "settles with no webhook delivered, by reading the invoice it is waiting on" scenarioNoWebhookAnywhere
|
|
|
|
testServiceColumns :: IO ()
|
|
testServiceColumns = withServiceStore $ \st -> do
|
|
columnsOf st "sx_badge_service_badge_code_invoices"
|
|
>>= (`shouldSatisfy` \cs -> all (`elem` cs) ["badge_code_id", "provider_ref"])
|
|
columnsOf st "sx_badge_service_payments" >>= (`shouldSatisfy` elem "crypto_paid")
|
|
columnsOf st "sx_badge_service_badge_codes"
|
|
>>= (`shouldSatisfy` \cs -> all (`elem` cs) ["expires_at", "revoked_at"])
|
|
|
|
testProviderRefUnique :: IO ()
|
|
testProviderRefUnique = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
seedInvoice st "inv1"
|
|
seedInvoice st "inv2"
|
|
insertBadgeCodeInvoice st "inv1" "price1" "same-provider-ref"
|
|
insertBadgeCodeInvoice st "inv2" "price1" "same-provider-ref"
|
|
`shouldThrow` anyException
|
|
|
|
seedInvoice :: DBStore -> Text -> IO ()
|
|
seedInvoice st invoiceId = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_invoices (invoice_id, provider, price, amount, currency, expires_at, status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
|
|
(invoiceId, "btcpay" :: Text, 500 :: Int, 500 :: Int, "usd" :: Text, "2030-01-01T00:00:00Z" :: Text, "open" :: Text, "2026-08-31T00:00:00Z" :: Text, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
seedBadgePrice :: DBStore -> Text -> IO ()
|
|
seedBadgePrice st priceId = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_prices (price_id, badge_type, month_price, currency, status, created_at) VALUES (?,?,?,?,?,?)"
|
|
(priceId, "supporter" :: Text, 500 :: Int, "usd" :: Text, "active" :: Text, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
insertBadgeCodeInvoice :: DBStore -> Text -> Text -> Text -> IO ()
|
|
insertBadgeCodeInvoice st invoiceId priceId providerRef = withConnection st $ \db -> do
|
|
let codeHash = DB.Binary (digestFixture (fromIntegral (sum (map fromEnum (T.unpack invoiceId)))))
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)"
|
|
(codeHash, "supporter" :: Text, 1 :: Int, "unpaid" :: Text, "2026-08-31T00:00:00Z" :: Text)
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_code_invoices (invoice_id, badge_code_id, price_id, created_at, provider_ref) SELECT ?, badge_code_id, ?, ?, ? FROM sx_badge_service_badge_codes WHERE code_hash = ?"
|
|
(invoiceId, priceId, "2026-08-31T00:00:00Z" :: Text, providerRef, codeHash)
|
|
|
|
someExpiry :: UTCTime
|
|
someExpiry = UTCTime (fromGregorian 2030 1 1) 0
|
|
|
|
someCreated :: UTCTime
|
|
someCreated = UTCTime (fromGregorian 2026 8 31) 0
|
|
|
|
-- | These 32 bytes are all above 0x7f, so the value is not valid UTF-8 and catches the
|
|
-- postgresql-simple bug where a plain ByteString is written as escaped text.
|
|
digestFixture :: Word8 -> ByteString
|
|
digestFixture n = BS.pack [0x80 + ((n * 7 + i) `mod` 0x80) | i <- [0 .. 31]]
|
|
|
|
sampleInvoice :: NewInvoice
|
|
sampleInvoice =
|
|
NewInvoice
|
|
{ niInvoiceId = InvoiceId "inv1",
|
|
niProviderRef = "provider-ref-1",
|
|
niCodeHash = digestFixture 1,
|
|
niPriceId = BadgePriceId "price1",
|
|
niOfferId = Nothing,
|
|
niBadgeType = BTSupporter,
|
|
niMonths = 1,
|
|
niPrice = CurrencyAmount 500,
|
|
niAmount = CurrencyAmount 500,
|
|
niCurrency = "usd",
|
|
niProvider = PPCrypto,
|
|
niDestination = SPDCrypto CCBtc "bc1qexampleaddress" "0.00050000",
|
|
niExpiresAt = someExpiry,
|
|
niCreatedAt = someCreated
|
|
}
|
|
|
|
codeInvoiceRow :: DBStore -> InvoiceId -> IO (Maybe Text)
|
|
codeInvoiceRow st (InvoiceId invId) = withConnection st $ \db -> do
|
|
rows <- DB.query db "SELECT invoice_id FROM sx_badge_service_badge_code_invoices WHERE invoice_id = ?" (Only invId) :: IO [Only Text]
|
|
pure $ case rows of
|
|
[] -> Nothing
|
|
(Only r : _) -> Just r
|
|
|
|
markPaid :: DBStore -> InvoiceId -> IO ()
|
|
markPaid st (InvoiceId invId) = withConnection st $ \db ->
|
|
DB.execute db "UPDATE sx_badge_service_invoices SET status = 'paid' WHERE invoice_id = ?" (Only invId)
|
|
|
|
insertPrice :: DBStore -> Text -> Text -> Int -> Text -> IO ()
|
|
insertPrice st priceId badgeType monthPrice status = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_prices (price_id, badge_type, month_price, currency, status, created_at) VALUES (?,?,?,?,?,?)"
|
|
(priceId, badgeType, monthPrice, "usd" :: Text, status, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
insertOffer :: DBStore -> Text -> Maybe Text -> Int -> Int -> Text -> IO ()
|
|
insertOffer st offerId priceId months discount status = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_offers (offer_id, price_id, months, discount, status, created_at) VALUES (?,?,?,?,?,?)"
|
|
(offerId, priceId, months, discount, status, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
testCreationIsAtomic :: IO ()
|
|
testCreationIsAtomic = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
let duplicateHash = digestFixture 9
|
|
planted = sampleInvoice {niInvoiceId = InvoiceId "other", niProviderRef = "p-other", niCodeHash = duplicateHash}
|
|
ni = sampleInvoice {niCodeHash = duplicateHash}
|
|
planted' <- createInvoiceRows st planted
|
|
planted' `shouldBe` Right ()
|
|
r <- createInvoiceRows st ni
|
|
r `shouldSatisfy` isLeft
|
|
r `shouldBe` Left CECodeConflict
|
|
getInvoice st (niInvoiceId ni) `shouldReturn` Nothing
|
|
codeInvoiceRow st (niInvoiceId ni) `shouldReturn` Nothing
|
|
|
|
testNewInvoiceIdRandom :: IO ()
|
|
testNewInvoiceIdRandom = do
|
|
InvoiceId a <- newInvoiceId
|
|
InvoiceId b <- newInvoiceId
|
|
a `shouldNotBe` b
|
|
T.length a `shouldBe` 22
|
|
T.any (== '=') a `shouldBe` False
|
|
|
|
testCodeHashExists :: IO ()
|
|
testCodeHashExists = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
createInvoiceRows st sampleInvoice `shouldReturn` Right ()
|
|
codeHashExists st (niCodeHash sampleInvoice) `shouldReturn` True
|
|
codeHashExists st "no-such-hash" `shouldReturn` False
|
|
|
|
testExpireOverdueMovesOnlyQualifying :: IO ()
|
|
testExpireOverdueMovesOnlyQualifying = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let pastExpiry = addUTCTime (-3600) now
|
|
futureExpiry = addUTCTime 3600 now
|
|
overdue = sampleInvoice {niExpiresAt = pastExpiry}
|
|
notYet = sampleInvoice {niInvoiceId = InvoiceId "inv-notyet", niProviderRef = "p-notyet", niCodeHash = digestFixture 13, niExpiresAt = futureExpiry}
|
|
alreadyPaid = sampleInvoice {niInvoiceId = InvoiceId "inv-paid", niProviderRef = "p-paid", niCodeHash = digestFixture 14, niExpiresAt = pastExpiry}
|
|
createInvoiceRows st overdue `shouldReturn` Right ()
|
|
createInvoiceRows st notYet `shouldReturn` Right ()
|
|
createInvoiceRows st alreadyPaid `shouldReturn` Right ()
|
|
markPaid st (niInvoiceId alreadyPaid)
|
|
map (\OverdueInvoice {oiInvoiceId, oiProviderRef} -> (oiInvoiceId, oiProviderRef)) <$> overdueInvoices st now `shouldReturn` [(niInvoiceId overdue, niProviderRef overdue)]
|
|
moved <- expireAllOverdue st now
|
|
moved `shouldBe` [niInvoiceId overdue]
|
|
Just overdueRow <- getInvoice st (niInvoiceId overdue)
|
|
irStatus overdueRow `shouldBe` ISExpired
|
|
Just notYetRow <- getInvoice st (niInvoiceId notYet)
|
|
irStatus notYetRow `shouldBe` ISOpen
|
|
Just paidRow <- getInvoice st (niInvoiceId alreadyPaid)
|
|
irStatus paidRow `shouldBe` ISPaid
|
|
|
|
testExpireOverdueMovesOnlyTheNamed :: IO ()
|
|
testExpireOverdueMovesOnlyTheNamed = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let pastExpiry = addUTCTime (-3600) now
|
|
named = sampleInvoice {niExpiresAt = pastExpiry}
|
|
unnamed = sampleInvoice {niInvoiceId = InvoiceId "inv-unnamed", niProviderRef = "p-unnamed", niCodeHash = digestFixture 13, niExpiresAt = pastExpiry}
|
|
createInvoiceRows st named `shouldReturn` Right ()
|
|
createInvoiceRows st unnamed `shouldReturn` Right ()
|
|
expireOverdue st now [niInvoiceId named] `shouldReturn` [niInvoiceId named]
|
|
invoiceStatus st (niInvoiceId named) `shouldReturn` ISExpired
|
|
invoiceStatus st (niInvoiceId unnamed) `shouldReturn` ISOpen
|
|
expireOverdue st now [niInvoiceId named] `shouldReturn` []
|
|
|
|
expireAllOverdue :: DBStore -> UTCTime -> IO [InvoiceId]
|
|
expireAllOverdue st now = overdueInvoices st now >>= expireOverdue st now . map oiInvoiceId
|
|
|
|
testRevokeAndRedeemExcludeEachOther :: IO ()
|
|
testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
(purchaseKey, masterKey) <- newPurchaseKeys
|
|
let newCode codeHash = withTransaction st $ \db -> do
|
|
insertBadgeCode db codeHash BTSupporter 1 CPSPaid now
|
|
maybe (error "the code was not written") (\IssuedCode {badgeCodeId} -> badgeCodeId) <$> getBadgeCode db codeHash
|
|
redeem badgeCodeId = withTransaction st $ \db -> createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now
|
|
revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
|
|
unredeemed codeHash =
|
|
withTransaction st (`getBadgeCode` codeHash) >>= \case
|
|
Just IssuedCode {redemption = CodeUnredeemed} -> pure True
|
|
_ -> pure False
|
|
revokedFirst <- newCode "revoked-first"
|
|
revoke "revoked-first" `shouldReturn` Revoked
|
|
redeem revokedFirst `shouldReturn` Nothing
|
|
unredeemed "revoked-first" `shouldReturn` True
|
|
redeemedFirst <- newCode "redeemed-first"
|
|
isJust <$> redeem redeemedFirst `shouldReturn` True
|
|
revoke "redeemed-first" `shouldReturn` AlreadyRedeemed
|
|
redeem redeemedFirst `shouldReturn` Nothing
|
|
|
|
testReadCatalogRowsDropsDisabled :: IO ()
|
|
testReadCatalogRowsDropsDisabled = withServiceStore $ \st -> do
|
|
insertPrice st "price-active" "supporter" 500 "active"
|
|
insertPrice st "price-disabled" "supporter" 500 "disabled"
|
|
insertOffer st "offer-active" (Just "price-active") 3 10 "active"
|
|
insertOffer st "offer-disabled" (Just "price-active") 3 10 "disabled"
|
|
(prices, offers) <- readCatalogRows st
|
|
map (\BadgePrice {priceId} -> priceId) prices `shouldBe` [BadgePriceId "price-active"]
|
|
map (\BadgeOffer {offerId} -> offerId) offers `shouldBe` [BadgeOfferId "offer-active"]
|
|
|
|
seedDefaultCatalog :: DBStore -> UTCTime -> IO (Int, Int)
|
|
seedDefaultCatalog st at = uncurry (seedCatalog st) (defaultCatalog at)
|
|
|
|
priceFacts :: BadgePrice -> (Text, Text, Word32, Text, BadgeItemStatus)
|
|
priceFacts BadgePrice {priceId = BadgePriceId pId, badgeType = bType, monthPrice = CurrencyAmount mPrice, currency = cur, status = pStatus} =
|
|
(pId, textEncode bType, mPrice, cur, pStatus)
|
|
|
|
offerFacts :: BadgeOffer -> (Text, Maybe Text, Word8, OfferDiscount, BadgeItemStatus)
|
|
offerFacts BadgeOffer {offerId = BadgeOfferId oId, priceId = oPriceId, months = oMonths, discount = oDiscount, status = oStatus} =
|
|
(oId, (\(BadgePriceId p) -> p) <$> oPriceId, oMonths, oDiscount, oStatus)
|
|
|
|
allPriceRows :: DBStore -> IO [(Text, Text, Word32, Text, Text, UTCTime)]
|
|
allPriceRows st = withConnection st $ \db ->
|
|
DB.query_ db "SELECT price_id, badge_type, month_price, currency, status, created_at FROM sx_badge_service_badge_prices ORDER BY price_id"
|
|
|
|
allOfferRows :: DBStore -> IO [(Text, Maybe Text, Word32, Maybe Word32, Maybe Word32, Text, UTCTime)]
|
|
allOfferRows st = withConnection st $ \db ->
|
|
DB.query_ db "SELECT offer_id, price_id, months, free_months, discount, status, created_at FROM sx_badge_service_badge_offers ORDER BY offer_id"
|
|
|
|
testSeedWritesTheCatalog :: IO ()
|
|
testSeedWritesTheCatalog = withServiceStore $ \st -> do
|
|
readCatalogRows st `shouldReturn'` (0, 0)
|
|
seedDefaultCatalog st someCreated `shouldReturn` (2, 4)
|
|
(prices, offers) <- readCatalogRows st
|
|
sortOn (\(i, _, _, _, _) -> i) (map priceFacts prices)
|
|
`shouldBe` [ ("price_legend", "legend", 7000, "usd", BISActive),
|
|
("price_supporter", "supporter", 700, "usd", BISActive)
|
|
]
|
|
sortOn (\(i, _, _, _, _) -> i) (map offerFacts offers)
|
|
`shouldBe` [ ("offer_12m", Just "price_legend", 12, ODDiscount 50, BISActive),
|
|
("offer_12m_s", Just "price_supporter", 12, ODDiscount 50, BISActive),
|
|
("offer_3m", Just "price_legend", 3, ODFreeMonths 1, BISActive),
|
|
("offer_3m_s", Just "price_supporter", 3, ODFreeMonths 1, BISActive)
|
|
]
|
|
where
|
|
shouldReturn' action expected = do
|
|
(ps, os) <- action
|
|
(length ps, length os) `shouldBe` expected
|
|
|
|
testSeedIsIdempotent :: IO ()
|
|
testSeedIsIdempotent = withServiceStore $ \st -> do
|
|
seedDefaultCatalog st someCreated `shouldReturn` (2, 4)
|
|
let restartedAt = addUTCTime 86400 someCreated
|
|
seedDefaultCatalog st restartedAt `shouldReturn` (0, 0)
|
|
priceRows <- allPriceRows st
|
|
offerRows <- allOfferRows st
|
|
map (\(i, _, _, _, _, _) -> i) priceRows `shouldBe` ["price_legend", "price_supporter"]
|
|
map (\(i, _, _, _, _, _, _) -> i) offerRows `shouldBe` ["offer_12m", "offer_12m_s", "offer_3m", "offer_3m_s"]
|
|
map (\(_, _, _, _, _, at) -> at) priceRows `shouldBe` replicate 2 someCreated
|
|
map (\(_, _, _, _, _, _, at) -> at) offerRows `shouldBe` replicate 4 someCreated
|
|
|
|
testSeedNeverResurrectsAWithdrawnRow :: IO ()
|
|
testSeedNeverResurrectsAWithdrawnRow = withServiceStore $ \st -> do
|
|
insertPrice st "price_supporter" "supporter" 900 "deprecated"
|
|
insertPrice st "price_legend" "legend" 9000 "disabled"
|
|
insertOffer st "offer_12m" (Just "price_legend") 12 25 "disabled"
|
|
seedDefaultCatalog st someCreated `shouldReturn` (0, 3)
|
|
priceRows <- allPriceRows st
|
|
map (\(i, _, mp, _, s, _) -> (i, mp, s)) priceRows
|
|
`shouldBe` [("price_legend", 9000, "disabled"), ("price_supporter", 900, "deprecated")]
|
|
offerRows <- allOfferRows st
|
|
map (\(i, _, m, _, d, s, _) -> (i, m, d, s)) offerRows
|
|
`shouldBe` [ ("offer_12m", 12, Just 25, "disabled"),
|
|
("offer_12m_s", 12, Just 50, "active"),
|
|
("offer_3m", 3, Nothing, "active"),
|
|
("offer_3m_s", 3, Nothing, "active")
|
|
]
|
|
(prices, offers) <- readCatalogRows st
|
|
sortOn (\(i, _, _, _, _) -> i) (map priceFacts prices)
|
|
`shouldBe` [("price_supporter", "supporter", 900, "usd", BISDeprecated)]
|
|
map (\(i, _, _, _, _) -> i) (sortOn (\(i, _, _, _, _) -> i) (map offerFacts offers))
|
|
`shouldBe` ["offer_12m_s", "offer_3m", "offer_3m_s"]
|
|
|
|
testSeedMatchesWebCatalog :: IO ()
|
|
testSeedMatchesWebCatalog = withServiceStore $ \st -> do
|
|
src <- T.readFile "apps/simplex-badge-service/web/src/catalog.ts"
|
|
(webPrices, webOffers) <- case parseCatalogSource src of
|
|
Nothing -> failWith "could not parse CATALOG out of web/src/catalog.ts -- its shape has changed"
|
|
Just parsed -> pure parsed
|
|
webPrices `shouldNotBe` []
|
|
webOffers `shouldNotBe` []
|
|
seedDefaultCatalog st someCreated `shouldReturn` (length webPrices, length webOffers)
|
|
(prices, offers) <- readCatalogRows st
|
|
sortOn (\(i, _, _, _) -> i) (map (\(i, t, mp, cur, _) -> (i, t, mp, cur)) (map priceFacts prices))
|
|
`shouldBe` sortOn (\(i, _, _, _) -> i) (map (\WebPrice {wpPriceId, wpBadgeType, wpMonthPrice, wpCurrency} -> (wpPriceId, wpBadgeType, wpMonthPrice, wpCurrency)) webPrices)
|
|
sortOn (\(i, _, _, _) -> i) (map (\(i, p, m, d, _) -> (i, p, m, d)) (map offerFacts offers))
|
|
`shouldBe` sortOn (\(i, _, _, _) -> i) (map (\WebOffer {woOfferId, woPriceId, woMonths, woDiscount} -> (woOfferId, Just woPriceId, woMonths, woDiscount)) webOffers)
|
|
|
|
testSeededCatalogSellsSomething :: IO ()
|
|
testSeededCatalogSellsSomething = bounded "seeded catalog sells" $ withSeededCheckout $ \client -> do
|
|
card <- postCreateAs client 1 (createBody "price_legend" (Just "offer_12m") "card" (codeHashText sampleCode))
|
|
statusOf card `shouldBe` 503
|
|
responseBody card `shouldBe` errorBody "provider_unavailable"
|
|
priced <- postCreateAs client 2 (createBody "price_legend" (Just "offer_12m") "btc" (codeHashText sampleCode))
|
|
statusOf priced `shouldBe` 200
|
|
o <- jsonObject priced
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "legend")
|
|
fieldOf o "months" `shouldBe` Just (J.Number 12)
|
|
fieldOf o "amount" `shouldBe` Just (J.Number 42000)
|
|
fieldOf o "currency" `shouldBe` Just (J.String catalogCurrency)
|
|
|
|
withSeededCheckout :: (WebClient -> IO a) -> IO a
|
|
withSeededCheckout action =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-seeded" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
_ <- seedDefaultCatalog st someCreated
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig}
|
|
withListener [stubProvider ref] True holdMicros st cfg (const action)
|
|
|
|
testTimestampRoundTrip :: IO ()
|
|
testTimestampRoundTrip = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
let subSecond = UTCTime (fromGregorian 2026 8 31) (picosecondsToDiffTime 12500000000000)
|
|
truncated = UTCTime (fromGregorian 2026 8 31) (picosecondsToDiffTime 12000000000000)
|
|
ni = sampleInvoice {niExpiresAt = subSecond, niCreatedAt = subSecond}
|
|
createInvoiceRows st ni `shouldReturn` Right ()
|
|
Just row <- getInvoice st (niInvoiceId ni)
|
|
irExpiresAt row `shouldBe` truncated
|
|
irCreatedAt row `shouldBe` truncated
|
|
|
|
data StubCall
|
|
= StubCreate ServicePaymentMethod OrderDraft
|
|
| StubRead Text
|
|
| StubCancel Text
|
|
| StubListOpen
|
|
deriving (Eq, Show)
|
|
|
|
data StubState = StubState
|
|
{ ssCalls :: [StubCall],
|
|
ssCreateResult :: Either ProviderError ProviderInvoice,
|
|
ssInvoices :: Map.Map Text PaymentSignal,
|
|
ssCancelError :: Maybe ProviderError,
|
|
-- The cancel reaches the provider, but its answer is lost.
|
|
ssCancelLost :: Bool,
|
|
ssListError :: Maybe ProviderError,
|
|
ssReadError :: Maybe ProviderError,
|
|
ssSkipped :: [(Maybe Text, Text)],
|
|
ssVerifyResult :: Either WebhookError (Maybe Text),
|
|
ssVerifyThrows :: Bool,
|
|
ssWebhooks :: [([Header], ByteString)],
|
|
ssReadDelay :: Int
|
|
}
|
|
|
|
newStubState :: Either ProviderError ProviderInvoice -> StubState
|
|
newStubState ssCreateResult =
|
|
StubState
|
|
{ ssCalls = [],
|
|
ssCreateResult,
|
|
ssInvoices = Map.empty,
|
|
ssCancelError = Nothing,
|
|
ssCancelLost = False,
|
|
ssListError = Nothing,
|
|
ssReadError = Nothing,
|
|
ssSkipped = [],
|
|
ssVerifyResult = Right Nothing,
|
|
ssVerifyThrows = False,
|
|
ssWebhooks = [],
|
|
ssReadDelay = 0
|
|
}
|
|
|
|
record :: IORef StubState -> StubCall -> IO ()
|
|
record ref call = atomicModifyIORef' ref $ \s -> (s {ssCalls = ssCalls s ++ [call]}, ())
|
|
|
|
stubProvider :: IORef StubState -> Provider
|
|
stubProvider ref =
|
|
Provider
|
|
{ pProvider = PPCrypto,
|
|
pCreateInvoice = \method draft -> do
|
|
record ref (StubCreate method draft)
|
|
ssCreateResult <$> readIORef ref,
|
|
pReadInvoice = \providerRef -> do
|
|
record ref (StubRead providerRef)
|
|
stub <- readIORef ref
|
|
threadDelay (ssReadDelay stub)
|
|
pure $ maybe (Right (Map.lookup providerRef (ssInvoices stub))) Left (ssReadError stub),
|
|
pCancelInvoice = \providerRef -> do
|
|
record ref (StubCancel providerRef)
|
|
lost <- ssCancelLost <$> readIORef ref
|
|
if lost
|
|
then do
|
|
atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert providerRef (SigClosed (rcv 0 Nothing)) (ssInvoices s)}, ())
|
|
pure (Left (ProviderError "the response was lost"))
|
|
else maybe (Right ()) Left . ssCancelError <$> readIORef ref,
|
|
pListOpen = do
|
|
record ref StubListOpen
|
|
stub <- readIORef ref
|
|
pure $ case ssListError stub of
|
|
Just e -> Left e
|
|
Nothing -> Right ListPass {lpMoved = Map.toList (ssInvoices stub), lpSkipped = ssSkipped stub},
|
|
pVerifyWebhook = const (verifyRecording ref)
|
|
}
|
|
|
|
-- | 'pVerifyWebhook' is pure by design, so recording its arguments needs 'unsafePerformIO',
|
|
-- and the NOINLINE effect is safe because every assertion checks an exact list of calls, so a
|
|
-- lost or repeated recording fails the test rather than passing it.
|
|
verifyRecording :: IORef StubState -> [Header] -> ByteString -> Either WebhookError (Maybe Text)
|
|
verifyRecording ref hdrs body = unsafePerformIO $ do
|
|
atomicModifyIORef' ref $ \s -> (s {ssWebhooks = ssWebhooks s ++ [(hdrs, body)]}, ())
|
|
stub <- readIORef ref
|
|
if ssVerifyThrows stub
|
|
then E.throwIO (userError "the adapter threw while verifying")
|
|
else pure (ssVerifyResult stub)
|
|
{-# NOINLINE verifyRecording #-}
|
|
|
|
stubCalls :: IORef StubState -> IO [StubCall]
|
|
stubCalls ref = ssCalls <$> readIORef ref
|
|
|
|
stubWebhooks :: IORef StubState -> IO [([Header], ByteString)]
|
|
stubWebhooks ref = ssWebhooks <$> readIORef ref
|
|
|
|
setVerifyResult :: IORef StubState -> Either WebhookError (Maybe Text) -> IO ()
|
|
setVerifyResult ref r = atomicModifyIORef' ref $ \s -> (s {ssVerifyResult = r}, ())
|
|
|
|
setReadDelay :: IORef StubState -> Int -> IO ()
|
|
setReadDelay ref micros = atomicModifyIORef' ref $ \s -> (s {ssReadDelay = micros}, ())
|
|
|
|
setVerifyThrows :: IORef StubState -> Bool -> IO ()
|
|
setVerifyThrows ref throws = atomicModifyIORef' ref $ \s -> (s {ssVerifyThrows = throws}, ())
|
|
|
|
sampleDraft :: OrderDraft
|
|
sampleDraft = OrderDraft {odAmount = CurrencyAmount 500, odCurrency = "usd"}
|
|
|
|
sampleProviderInvoice :: ProviderInvoice
|
|
sampleProviderInvoice = ProviderInvoice {piProviderRef = "pref-1", piDestination = SPDCrypto CCBtc "bc1qexampleaddress" "0.00050000"}
|
|
|
|
testStubProviderRecordsCalls :: IO ()
|
|
testStubProviderRecordsCalls = do
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
let provider = stubProvider ref
|
|
created <- pCreateInvoice provider (SPMCrypto CCBtc) sampleDraft
|
|
created `shouldBe` Right sampleProviderInvoice
|
|
let pref = piProviderRef sampleProviderInvoice
|
|
pReadInvoice provider pref `shouldReturn` Right Nothing
|
|
let signal = SigFunded (rcv 500 (Just "0.00050000")) PaidInPart
|
|
atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert pref signal (ssInvoices s)}, ())
|
|
pReadInvoice provider pref `shouldReturn` Right (Just signal)
|
|
pListOpen provider `shouldReturn` Right ListPass {lpMoved = [(pref, signal)], lpSkipped = []}
|
|
calls <- stubCalls ref
|
|
calls `shouldBe` [StubCreate (SPMCrypto CCBtc) sampleDraft, StubRead pref, StubRead pref, StubListOpen]
|
|
|
|
testStubProviderCreateFailsOnDemand :: IO ()
|
|
testStubProviderCreateFailsOnDemand = do
|
|
let err = ProviderError "connection refused"
|
|
ref <- newIORef (newStubState (Left err))
|
|
let provider = stubProvider ref
|
|
pCreateInvoice provider (SPMCrypto CCBtc) sampleDraft `shouldReturn` Left err
|
|
stubCalls ref `shouldReturn` [StubCreate (SPMCrypto CCBtc) sampleDraft]
|
|
|
|
testStubProviderNotCalledWhenSkipped :: IO ()
|
|
testStubProviderNotCalledWhenSkipped = do
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
-- | This ceiling is shorter than the 30s hold, so a test that waits when it should not fails
|
|
-- here instead of hanging.
|
|
exampleCeiling :: Int
|
|
exampleCeiling = 20 * 1000000
|
|
|
|
bounded :: HasCallStack => String -> IO a -> IO a
|
|
bounded label action =
|
|
timeout exampleCeiling action >>= maybe (failWith (label <> ": did not finish within 20s")) pure
|
|
|
|
clientTimeout :: Int
|
|
clientTimeout = 60 * 1000000
|
|
|
|
failWith :: HasCallStack => String -> IO a
|
|
failWith msg = expectationFailure msg >> error msg
|
|
|
|
outsideMarker :: LB.ByteString
|
|
outsideMarker = "SECRET-OUTSIDE-STATIC-DIR"
|
|
|
|
shellHtml :: LB.ByteString
|
|
shellHtml = "<!doctype html><title>SimpleX badges</title><meta id=\"stripe-publishable-key\" name=\"stripe-publishable-key\" content=\"\">"
|
|
|
|
assetJs :: LB.ByteString
|
|
assetJs = "export const build = \"d95503da54ee228f\";"
|
|
|
|
workerJs :: LB.ByteString
|
|
workerJs = "self.addEventListener(\"install\", () => {});"
|
|
|
|
buildHash :: FilePath
|
|
buildHash = "d95503da54ee228f"
|
|
|
|
notFoundBody :: LB.ByteString
|
|
notFoundBody = "{\"error\":\"not_found\"}"
|
|
|
|
prepareStaticDir :: FilePath -> IO FilePath
|
|
prepareStaticDir root = do
|
|
let staticDir = root </> "dist"
|
|
assetDir = staticDir </> "assets" </> buildHash
|
|
createDirectoryIfMissing True assetDir
|
|
LB.writeFile (root </> "secret.txt") outsideMarker
|
|
LB.writeFile (staticDir </> "index.html") shellHtml
|
|
LB.writeFile (staticDir </> "sw.js") workerJs
|
|
LB.writeFile (assetDir </> "main.js") assetJs
|
|
createFileLink (".." </> ".." </> "secret.txt") (staticDir </> "assets" </> "escape.txt")
|
|
pure staticDir
|
|
|
|
testServiceConfig :: FilePath -> Bool -> ServiceConfig
|
|
testServiceConfig staticDir trustForwarded =
|
|
ServiceConfig
|
|
{ listener = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = True, lWebappExportDir = Nothing, lTrustForwardedFor = trustForwarded},
|
|
btcpay = Nothing,
|
|
stripe = Nothing,
|
|
poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60},
|
|
issuer = Nothing,
|
|
devChatRedeem = False
|
|
}
|
|
|
|
testServeWebappOff :: IO ()
|
|
testServeWebappOff =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-static" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
let base = testServiceConfig staticDir False
|
|
cfg = base {listener = (listener base) {lServeWebapp = False}}
|
|
withListener [] True holdMicros st cfg $ \_env client -> do
|
|
(statusOf <$> webGet client "/") >>= (`shouldBe` 404)
|
|
(statusOf <$> webGet client "/sw.js") >>= (`shouldBe` 404)
|
|
(statusOf <$> webGet client ("/assets/" <> buildHash <> "/main.js")) >>= (`shouldBe` 404)
|
|
created <- webRequest client "POST" "/api/invoice" []
|
|
statusOf created `shouldSatisfy` (\s -> s /= 404 && s /= 405)
|
|
|
|
testExportWebapp :: IO ()
|
|
testExportWebapp = do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-export" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
let outDir = root </> "out"
|
|
lc = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = False, lWebappExportDir = Just outDir, lTrustForwardedFor = False}
|
|
stripeCfg = Just StripeConfig {sSecretKey = "rk_test_x", sPublishableKey = "pk_test_injected", sWebhookSecret = "whsec_x", sSessionMinutes = 60, sHost = "https://api.stripe.com"}
|
|
exportWebapp lc stripeCfg
|
|
idx <- LB.readFile (outDir </> "index.html")
|
|
LB.toStrict idx `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\""
|
|
LB.readFile (outDir </> "sw.js") >>= (`shouldBe` workerJs)
|
|
LB.readFile (outDir </> "assets" </> buildHash </> "main.js") >>= (`shouldBe` assetJs)
|
|
|
|
type WebClient = (Manager, String)
|
|
|
|
withWebApp :: (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebApp = withWebAppWith False True holdMicros
|
|
|
|
withWebAppForwarded :: Bool -> (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebAppForwarded trustForwarded = withWebAppWith trustForwarded True holdMicros
|
|
|
|
withWebAppHolding :: Int -> (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebAppHolding hold = withWebAppWith False True hold
|
|
|
|
withWebAppExpectingThrow :: (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebAppExpectingThrow = withWebAppWith False False holdMicros
|
|
|
|
withWebAppWith :: Bool -> Bool -> Int -> (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebAppWith trustForwarded rethrow hold action =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-static" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
withListener [] rethrow hold st (testServiceConfig staticDir trustForwarded) action
|
|
|
|
withListener :: [Provider] -> Bool -> Int -> DBStore -> ServiceConfig -> (WebEnv -> WebClient -> IO a) -> IO a
|
|
withListener providers rethrow hold st cfg action = do
|
|
let runner = if rethrow then Warp.testWithApplicationSettings else Warp.withApplicationSettings
|
|
waiters <- newWaiters
|
|
hints <- newReadHints
|
|
built <- newWebEnv st cfg waiters hints providers
|
|
let env = built {weHoldMicros = hold}
|
|
mgr <- newManager defaultManagerSettings
|
|
runner (webSettings (listener cfg)) (pure (webApp env)) $ \prt ->
|
|
action env (mgr, "http://127.0.0.1:" <> show prt)
|
|
|
|
webRequest :: WebClient -> ByteString -> String -> [Header] -> IO (Response LB.ByteString)
|
|
webRequest client verb target hdrs = webRequestBody client verb target hdrs ""
|
|
|
|
webRequestBody :: WebClient -> ByteString -> String -> [Header] -> LB.ByteString -> IO (Response LB.ByteString)
|
|
webRequestBody (mgr, base) verb target hdrs body = do
|
|
req <- parseRequest base
|
|
let (rawPath, rawQuery) = break (== '?') target
|
|
httpLbs
|
|
req
|
|
{ method = verb,
|
|
path = BC.pack rawPath,
|
|
queryString = BC.pack rawQuery,
|
|
requestHeaders = hdrs,
|
|
requestBody = RequestBodyLBS body,
|
|
responseTimeout = responseTimeoutMicro clientTimeout
|
|
}
|
|
mgr
|
|
|
|
webGet :: WebClient -> String -> IO (Response LB.ByteString)
|
|
webGet client target = webRequest client "GET" target []
|
|
|
|
statusOf :: Response LB.ByteString -> Int
|
|
statusOf = statusCode . responseStatus
|
|
|
|
headerOf :: Response LB.ByteString -> HeaderName -> Maybe ByteString
|
|
headerOf r name = lookup name (responseHeaders r)
|
|
|
|
jsonObject :: HasCallStack => Response LB.ByteString -> IO J.Object
|
|
jsonObject r = case J.decode (responseBody r) of
|
|
Just (J.Object o) -> pure o
|
|
_ -> failWith ("not a JSON object: " <> LB.unpack (responseBody r))
|
|
|
|
fieldOf :: J.Object -> Text -> Maybe J.Value
|
|
fieldOf o k = KM.lookup (K.fromText k) o
|
|
|
|
timedGet :: WebClient -> String -> IO (NominalDiffTime, Response LB.ByteString)
|
|
timedGet client target = do
|
|
started <- getCurrentTime
|
|
r <- webGet client target
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
pure (elapsed, r)
|
|
|
|
seedOpenInvoice :: HasCallStack => WebEnv -> IO InvoiceId
|
|
seedOpenInvoice WebEnv {weStore} = do
|
|
seedBadgePrice weStore "price1"
|
|
createInvoiceRows weStore sampleInvoice `shouldReturn` Right ()
|
|
pure (niInvoiceId sampleInvoice)
|
|
|
|
wokenBy :: HasCallStack => WebClient -> InvoiceId -> IO () -> Text -> IO J.Object
|
|
wokenBy client iid trigger expected = do
|
|
started <- getCurrentTime
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
threadDelay holdParkDelay
|
|
parked <- Async.poll held
|
|
parked `shouldSatisfy` isNothing
|
|
trigger
|
|
r <- wait held
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String expected)
|
|
elapsed `shouldSatisfy` (< 1)
|
|
pure o
|
|
|
|
-- | This delay is long enough for the request to reach the hold and short enough to keep the
|
|
-- whole check within the one second a woken answer is allowed.
|
|
holdParkDelay :: Int
|
|
holdParkDelay = 100000
|
|
|
|
invoicePath :: InvoiceId -> String
|
|
invoicePath (InvoiceId iid) = "/api/invoice/" <> T.unpack iid
|
|
|
|
markPaidAndPublish :: WebEnv -> InvoiceId -> IO ()
|
|
markPaidAndPublish WebEnv {weStore, weWaiters} iid = do
|
|
markPaid weStore iid
|
|
atomically $ publish weWaiters iid ISPaid
|
|
|
|
expireRow :: DBStore -> InvoiceId -> IO ()
|
|
expireRow st (InvoiceId iid) = withConnection st $ \db ->
|
|
DB.execute db "UPDATE sx_badge_service_invoices SET status = 'expired' WHERE invoice_id = ?" (Only iid)
|
|
|
|
breakStore :: DBStore -> IO ()
|
|
breakStore st = withConnection st $ \db ->
|
|
DB.execute_ db "DROP TABLE sx_badge_service_badge_code_invoices"
|
|
|
|
readsPerMinute :: Int
|
|
readsPerMinute = lmPerMinute readLimit
|
|
|
|
testCachingFollowsTheResolvedPath :: IO ()
|
|
testCachingFollowsTheResolvedPath = bounded "cache by resolved path" $ withWebApp $ \_ client -> do
|
|
asset <- webGet client ("/assets/" <> buildHash <> "/main.js")
|
|
headerOf asset hCacheControl `shouldBe` Just "public, max-age=31536000, immutable"
|
|
shell <- webGet client "/"
|
|
headerOf shell hCacheControl `shouldBe` Just "no-cache"
|
|
escaped <- webGet client ("/assets/" <> buildHash <> "/%2e%2e/%2e%2e/index.html")
|
|
statusOf escaped `shouldBe` 200
|
|
responseBody escaped `shouldBe` shellHtml
|
|
headerOf escaped hCacheControl `shouldBe` Just "no-cache"
|
|
|
|
testShellCarriesPublishableKey :: IO ()
|
|
testShellCarriesPublishableKey = bounded "shell carries the publishable key" $
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-static" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
let cfg = (testServiceConfig staticDir True) {stripe = Just publishTestStripe}
|
|
withListener [] True holdMicros st cfg $ \_ client -> do
|
|
shell <- webGet client "/"
|
|
statusOf shell `shouldBe` 200
|
|
LB.toStrict (responseBody shell) `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\""
|
|
|
|
publishTestStripe :: StripeConfig
|
|
publishTestStripe =
|
|
StripeConfig
|
|
{ sSecretKey = "rk_test_x",
|
|
sPublishableKey = "pk_test_injected",
|
|
sWebhookSecret = "whsec_x",
|
|
sSessionMinutes = 60,
|
|
sHost = "https://api.stripe.com"
|
|
}
|
|
|
|
testServesTheBuild :: IO ()
|
|
testServesTheBuild = bounded "serves the build" $ withWebApp $ \_ client -> do
|
|
shell <- webGet client "/"
|
|
statusOf shell `shouldBe` 200
|
|
responseBody shell `shouldBe` shellHtml
|
|
headerOf shell hContentType `shouldBe` Just "text/html; charset=utf-8"
|
|
asset <- webGet client ("/assets/" <> buildHash <> "/main.js")
|
|
statusOf asset `shouldBe` 200
|
|
responseBody asset `shouldBe` assetJs
|
|
headerOf asset hContentType `shouldBe` Just "text/javascript; charset=utf-8"
|
|
worker <- webGet client "/sw.js"
|
|
statusOf worker `shouldBe` 200
|
|
responseBody worker `shouldBe` workerJs
|
|
headerOf worker hContentType `shouldBe` Just "text/javascript; charset=utf-8"
|
|
headerOf worker hCacheControl `shouldBe` Just "no-cache"
|
|
missing <- webGet client ("/assets/" <> buildHash <> "/absent.js")
|
|
statusOf missing `shouldBe` 404
|
|
|
|
builtSiteDir :: FilePath
|
|
builtSiteDir = "apps" </> "simplex-badge-service" </> "web" </> "dist"
|
|
|
|
testServesBuiltWebApp :: IO ()
|
|
testServesBuiltWebApp = bounded "built web app" $ withServiceStore $ \st -> do
|
|
built <- doesFileExist (builtSiteDir </> "index.html")
|
|
if not built
|
|
then pendingWith ("no web build at " <> builtSiteDir <> ": run `npm run build` in apps/simplex-badge-service/web")
|
|
else withListener [] True holdMicros st (testServiceConfig builtSiteDir False) $ \_ client -> do
|
|
shell <- webGet client "/"
|
|
statusOf shell `shouldBe` 200
|
|
LB.map toLower (LB.take 9 (responseBody shell)) `shouldBe` "<!doctype"
|
|
hashes <- listDirectory (builtSiteDir </> "assets")
|
|
hashes `shouldSatisfy` not . null
|
|
assets <- concat <$> mapM (\h -> map (h </>) <$> listDirectory (builtSiteDir </> "assets" </> h)) hashes
|
|
assets `shouldSatisfy` not . null
|
|
served <- mapM (\a -> (a,) . statusOf <$> webGet client ("/assets/" <> a)) assets
|
|
served `shouldSatisfy` all ((== 200) . snd)
|
|
worker <- webGet client "/sw.js"
|
|
statusOf worker `shouldBe` 200
|
|
responseBody worker `shouldSatisfy` not . LB.null
|
|
|
|
traversalSpellings :: [String]
|
|
traversalSpellings =
|
|
[ "/assets/../secret.txt",
|
|
"/assets/%2e%2e/secret.txt",
|
|
"/assets/%2e%2e%2fsecret.txt",
|
|
"/assets/..%2fsecret.txt",
|
|
"/assets/./../secret.txt",
|
|
"/assets//../secret.txt",
|
|
"/assets/" <> buildHash <> "/../../../secret.txt",
|
|
"/assets/%2e%2e%2f%2e%2e%2fsecret.txt",
|
|
"/assets/%2fetc%2fpasswd",
|
|
"/assets/%00/../secret.txt",
|
|
"/assets/escape.txt",
|
|
"/%2e%2e%2fsecret.txt"
|
|
]
|
|
|
|
testTraversalRefused :: IO ()
|
|
testTraversalRefused = bounded "traversal" $ withWebApp $ \_ client -> do
|
|
control <- webGet client ("/assets/" <> buildHash <> "/main.js")
|
|
statusOf control `shouldBe` 200
|
|
mapM_
|
|
( \target -> do
|
|
r <- webGet client target
|
|
(target, statusOf r) `shouldBe` (target, 404)
|
|
(target, responseBody r) `shouldBe` (target, notFoundBody)
|
|
)
|
|
traversalSpellings
|
|
|
|
testInvoiceView :: IO ()
|
|
testInvoiceView = bounded "invoice view" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
r <- webGet client (invoicePath iid)
|
|
statusOf r `shouldBe` 200
|
|
headerOf r hContentType `shouldBe` Just "application/json"
|
|
o <- jsonObject r
|
|
sort (map K.toText (KM.keys o))
|
|
`shouldBe` sort ["status", "badgeType", "months", "amount", "currency", "expiresAt", "address", "cryptoAmount", "cryptoCurrency"]
|
|
fieldOf o "status" `shouldBe` Just (J.String "open")
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "supporter")
|
|
fieldOf o "months" `shouldBe` Just (J.Number 1)
|
|
fieldOf o "amount" `shouldBe` Just (J.Number 500)
|
|
fieldOf o "currency" `shouldBe` Just (J.String "usd")
|
|
fieldOf o "address" `shouldBe` Just (J.String "bc1qexampleaddress")
|
|
fieldOf o "cryptoAmount" `shouldBe` Just (J.String "0.00050000")
|
|
fieldOf o "cryptoCurrency" `shouldBe` Just (J.String "btc")
|
|
case fieldOf o "expiresAt" of
|
|
Just (J.String t) -> T.unpack t `shouldStartWith` "2030-01-01T00:00:00"
|
|
other -> expectationFailure ("expiresAt is " <> show other)
|
|
settle (weStore env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
settled <- webGet client (invoicePath iid)
|
|
po <- jsonObject settled
|
|
fieldOf po "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf po "settledAt" `shouldBe` Just (J.toJSON settleAt)
|
|
fieldOf po "amountPaid" `shouldBe` Just (J.Number 500)
|
|
fieldOf po "cryptoAmountPaid" `shouldBe` Just (J.String "0.00050000")
|
|
fieldOf po "clientSecret" `shouldBe` Nothing
|
|
|
|
testUnknownInvoiceIsOpaque :: IO ()
|
|
testUnknownInvoiceIsOpaque = bounded "unknown id" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
guessed <- webGet client "/api/invoice/no-such-invoice"
|
|
statusOf guessed `shouldBe` 404
|
|
responseBody guessed `shouldBe` notFoundBody
|
|
nearMiss <- webGet client (invoicePath iid <> "x")
|
|
statusOf nearMiss `shouldBe` 404
|
|
responseBody nearMiss `shouldBe` responseBody guessed
|
|
|
|
testApiIsNeverCached :: IO ()
|
|
testApiIsNeverCached = bounded "no-store" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
ok <- webGet client (invoicePath iid)
|
|
statusOf ok `shouldBe` 200
|
|
headerOf ok hCacheControl `shouldBe` Just "no-store"
|
|
missing <- webGet client "/api/invoice/no-such-invoice"
|
|
statusOf missing `shouldBe` 404
|
|
headerOf missing hCacheControl `shouldBe` Just "no-store"
|
|
refused <- exhaustReadLimit client "/api/invoice/no-such-invoice" []
|
|
statusOf refused `shouldBe` 429
|
|
headerOf refused hCacheControl `shouldBe` Just "no-store"
|
|
|
|
exhaustReadLimit :: HasCallStack => WebClient -> String -> [Header] -> IO (Response LB.ByteString)
|
|
exhaustReadLimit client target hdrs = go (readsPerMinute + 5)
|
|
where
|
|
go :: Int -> IO (Response LB.ByteString)
|
|
go 0 = failWith ("no read of " <> target <> " was refused within 65 requests")
|
|
go n = do
|
|
r <- webRequest client "GET" target hdrs
|
|
if statusOf r == 429 then pure r else go (n - 1)
|
|
|
|
testWrongMethodIs405 :: IO ()
|
|
testWrongMethodIs405 = bounded "wrong method" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
postShell <- webRequest client "POST" "/" []
|
|
statusOf postShell `shouldBe` 405
|
|
headerOf postShell "Allow" `shouldBe` Just "GET"
|
|
postWorker <- webRequest client "POST" "/sw.js" []
|
|
statusOf postWorker `shouldBe` 405
|
|
deleteInvoice <- webRequest client "DELETE" (invoicePath iid) []
|
|
statusOf deleteInvoice `shouldBe` 405
|
|
headerOf deleteInvoice hCacheControl `shouldBe` Just "no-store"
|
|
getCreate <- webRequest client "GET" "/api/invoice" []
|
|
statusOf getCreate `shouldBe` 405
|
|
headerOf getCreate "Allow" `shouldBe` Just "POST"
|
|
|
|
testUnroutedPathIs404 :: IO ()
|
|
testUnroutedPathIs404 = bounded "unrouted" $ withWebApp $ \_ client -> do
|
|
nowhere <- webGet client "/nowhere"
|
|
statusOf nowhere `shouldBe` 404
|
|
responseBody nowhere `shouldBe` notFoundBody
|
|
webhook <- webRequest client "POST" "/webhooks/btcpay" []
|
|
statusOf webhook `shouldBe` 400
|
|
responseBody webhook `shouldBe` ""
|
|
wrongMethod <- webGet client "/webhooks/btcpay"
|
|
statusOf wrongMethod `shouldBe` 405
|
|
headerOf wrongMethod "Allow" `shouldBe` Just "POST"
|
|
|
|
testWaitAnswersAtOnce :: IO ()
|
|
testWaitAnswersAtOnce = bounded "wait answers at once" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
(staleElapsed, stale) <- timedGet client (invoicePath iid <> "?wait=expired")
|
|
statusOf stale `shouldBe` 200
|
|
staleObject <- jsonObject stale
|
|
fieldOf staleObject "status" `shouldBe` Just (J.String "open")
|
|
staleElapsed `shouldSatisfy` (< 1)
|
|
(junkElapsed, junk) <- timedGet client (invoicePath iid <> "?wait=not-a-status")
|
|
junkObject <- jsonObject junk
|
|
fieldOf junkObject "status" `shouldBe` Just (J.String "open")
|
|
junkElapsed `shouldSatisfy` (< 1)
|
|
markPaid (weStore env) iid
|
|
(terminalElapsed, terminalR) <- timedGet client (invoicePath iid <> "?wait=paid")
|
|
terminalObject <- jsonObject terminalR
|
|
fieldOf terminalObject "status" `shouldBe` Just (J.String "paid")
|
|
terminalElapsed `shouldSatisfy` (< 1)
|
|
|
|
testHoldAnswersAPaymentThePageHasNotSeen :: IO ()
|
|
testHoldAnswersAPaymentThePageHasNotSeen = bounded "hold sees the payment" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settle (weStore env) iid (SigFunded (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISOpen
|
|
(staleElapsed, stale) <- timedGet client (invoicePath iid <> "?wait=open&seenPaid=")
|
|
statusOf stale `shouldBe` 200
|
|
staleElapsed `shouldSatisfy` (< 1)
|
|
staleObject <- jsonObject stale
|
|
fieldOf staleObject "cryptoAmountPaid" `shouldBe` Just (J.String "0.00020000")
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open&seenPaid=0.00020000")
|
|
threadDelay 100000
|
|
Async.poll held >>= (`shouldSatisfy` isNothing)
|
|
markPaidAndPublish env iid
|
|
statusOf <$> wait held `shouldReturn` 200
|
|
|
|
testHoldAnswersAVerdictWithNoFigure :: IO ()
|
|
testHoldAnswersAVerdictWithNoFigure = bounded "hold sees the verdict" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settle (weStore env) iid (SigFunded (rcv 0 Nothing) PaidInFull) settleAt `shouldReturn` Right ISOpen
|
|
(elapsed, r) <- timedGet client (invoicePath iid <> "?wait=open&seenPaid=&seenFull=0")
|
|
statusOf r `shouldBe` 200
|
|
elapsed `shouldSatisfy` (< 1)
|
|
o <- jsonObject r
|
|
fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Nothing
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open&seenPaid=&seenFull=1")
|
|
threadDelay 100000
|
|
Async.poll held >>= (`shouldSatisfy` isNothing)
|
|
markPaidAndPublish env iid
|
|
statusOf <$> wait held `shouldReturn` 200
|
|
|
|
testHoldIsWokenNotPolled :: IO ()
|
|
testHoldIsWokenNotPolled = bounded "hold is woken" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
_ <- wokenBy client iid (markPaidAndPublish env iid) "paid"
|
|
pure ()
|
|
|
|
testReadRateLimit :: IO ()
|
|
testReadRateLimit = bounded "read rate limit" $ withWebApp $ \_ client -> do
|
|
let target = "/api/invoice/no-such-invoice"
|
|
allowed <- mapM (\_ -> statusOf <$> webGet client target) [1 .. readsPerMinute]
|
|
allowed `shouldSatisfy` all (== 404)
|
|
refused <- webGet client target
|
|
statusOf refused `shouldBe` 429
|
|
responseBody refused `shouldBe` "{\"error\":\"rate_limited\"}"
|
|
case headerOf refused "Retry-After" >>= (readMaybe . BC.unpack) of
|
|
Just seconds -> seconds `shouldSatisfy` \s -> s >= (1 :: Int) && s <= 60
|
|
Nothing -> expectationFailure ("Retry-After is " <> show (headerOf refused "Retry-After"))
|
|
|
|
testForwardedForOnlyWhenTrusted :: IO ()
|
|
testForwardedForOnlyWhenTrusted = bounded "forwarded-for" $ do
|
|
let target = "/api/invoice/no-such-invoice"
|
|
forgedBy i = ("X-Forwarded-For", BC.pack ("203.0.113." <> show (i :: Int)) <> ", 10.0.0.1")
|
|
proxiedFor i = ("X-Forwarded-For", BC.pack ("10.0.0." <> show (i :: Int)))
|
|
withWebApp $ \_ client -> do
|
|
forged <- mapM (\i -> statusOf <$> webRequest client "GET" target [forgedBy i]) [1 .. readsPerMinute]
|
|
forged `shouldSatisfy` all (== 404)
|
|
refused <- webRequest client "GET" target [forgedBy (readsPerMinute + 1)]
|
|
statusOf refused `shouldBe` 429
|
|
withWebAppForwarded True $ \_ client -> do
|
|
forged <- mapM (\i -> statusOf <$> webRequest client "GET" target [forgedBy i]) [1 .. readsPerMinute]
|
|
forged `shouldSatisfy` all (== 404)
|
|
refused <- webRequest client "GET" target [forgedBy (readsPerMinute + 1)]
|
|
statusOf refused `shouldBe` 429
|
|
withWebAppForwarded True $ \_ client -> do
|
|
first' <- mapM (\_ -> statusOf <$> webRequest client "GET" target [proxiedFor 1]) [1 .. readsPerMinute]
|
|
first' `shouldSatisfy` all (== 404)
|
|
statusOf <$> webRequest client "GET" target [proxiedFor 1] `shouldReturn` 429
|
|
statusOf <$> webRequest client "GET" target [proxiedFor 2] `shouldReturn` 404
|
|
|
|
testForwardedForMustBeAnAddress :: IO ()
|
|
testForwardedForMustBeAnAddress = bounded "forwarded-for is an address" $ withWebAppForwarded True $ \_ client -> do
|
|
let target = "/api/invoice/no-such-invoice"
|
|
forged i = ("X-Forwarded-For", BC.pack ("not-an-address-" <> show (i :: Int)))
|
|
minted <- mapM (\i -> statusOf <$> webRequest client "GET" target [forged i]) [1 .. readsPerMinute]
|
|
minted `shouldSatisfy` all (== 404)
|
|
refused <- webRequest client "GET" target [forged (readsPerMinute + 1)]
|
|
statusOf refused `shouldBe` 429
|
|
mapM_
|
|
( \v -> do
|
|
r <- webRequest client "GET" target [("X-Forwarded-For", v)]
|
|
(v, statusOf r) `shouldBe` (v, 429)
|
|
)
|
|
["", "not-an-address", "010.0.0.1", "1.2.3.4.5", "256.1.1.1", "1.2.3", "::1%eth0", "1:2:3:4:5:6:7", "[2001:db8::1]", "1.2.3.4:5678", "gggg::1", "12345::1"]
|
|
mapM_
|
|
( \v -> do
|
|
r <- webRequest client "GET" target [("X-Forwarded-For", v)]
|
|
(v, statusOf r) `shouldBe` (v, 404)
|
|
)
|
|
["192.0.2.7", "2001:db8::1", "::1", "::", "::ffff:192.0.2.1", "1:2:3:4:5:6:7:8"]
|
|
|
|
testBucketsStayBounded :: IO ()
|
|
testBucketsStayBounded = bounded "bucket cap" $ withWebApp $ \env _ -> do
|
|
let clients = map (\i -> T.pack ("198.51." <> show (i `div` 256) <> "." <> show (i `mod` 256))) [1 .. maxBuckets * 2 + 100]
|
|
mapM_ (takeToken env readLimit) clients
|
|
held <- Map.size <$> readTVarIO (weBuckets env)
|
|
held `shouldSatisfy` \n -> n > 0 && n <= maxBuckets
|
|
answers <- mapM (\_ -> takeToken env readLimit "203.0.113.9") [1 .. readsPerMinute + 1]
|
|
length (filter isJust answers) `shouldBe` 1
|
|
|
|
let fill i = do
|
|
n <- Map.size <$> readTVarIO (weBuckets env)
|
|
when (n < maxBuckets) $ do
|
|
_ <- takeToken env readLimit (T.pack ("192.0." <> show (i `div` 256) <> "." <> show (i `mod` 256)))
|
|
fill (i + 1)
|
|
fill (1 :: Int)
|
|
atTheCap <- Map.size <$> readTVarIO (weBuckets env)
|
|
atTheCap `shouldBe` maxBuckets
|
|
refusedAgain <- takeToken env readLimit "203.0.113.9"
|
|
refusedAgain `shouldSatisfy` isJust
|
|
afterARefusal <- Map.size <$> readTVarIO (weBuckets env)
|
|
afterARefusal `shouldSatisfy` (<= atTheCap `div` 2 + 1)
|
|
|
|
testHoldReportsTheRowNotTheWake :: IO ()
|
|
testHoldReportsTheRowNotTheWake = bounded "hold reports the row" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
threadDelay 100000
|
|
markPaid (weStore env) iid
|
|
atomically $ publish (weWaiters env) iid ISExpired
|
|
r <- wait held
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
|
|
testHold :: Int
|
|
testHold = 2000000
|
|
|
|
testHoldTimeoutReportsAnUnpublishedChange :: IO ()
|
|
testHoldTimeoutReportsAnUnpublishedChange = bounded "hold timeout" $ withWebAppHolding testHold $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
started <- getCurrentTime
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
threadDelay 50000
|
|
expireRow (weStore env) iid
|
|
r <- wait held
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "expired")
|
|
elapsed `shouldSatisfy` (>= 1.95)
|
|
|
|
testHandlerExceptionIsContained :: IO ()
|
|
testHandlerExceptionIsContained = bounded "handler exception" $ withWebAppExpectingThrow $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
breakStore (weStore env)
|
|
r <- webGet client (invoicePath iid)
|
|
statusOf r `shouldBe` 500
|
|
responseBody r `shouldBe` "{\"error\":\"internal\"}"
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
shell <- webGet client "/"
|
|
statusOf shell `shouldBe` 200
|
|
responseBody shell `shouldBe` shellHtml
|
|
|
|
createsPerMinute :: Int
|
|
createsPerMinute = 5
|
|
|
|
testExpiryMinutes :: Int
|
|
testExpiryMinutes = 45
|
|
|
|
testBTCPayConfig :: BTCPayConfig
|
|
testBTCPayConfig =
|
|
BTCPayConfig
|
|
{ bHost = "https://btcpay.example",
|
|
bApiKey = "api-key",
|
|
bStoreId = "store-id",
|
|
bWebhookSecret = "webhook-secret",
|
|
bExpiryMinutes = testExpiryMinutes,
|
|
bSpeedPolicy = MediumSpeed,
|
|
bPaymentTolerance = 0.5
|
|
}
|
|
|
|
supporterPriceId, legendPriceId, disabledPriceId :: Text
|
|
supporterPriceId = "price-supporter"
|
|
legendPriceId = "price-legend"
|
|
disabledPriceId = "price-retired"
|
|
|
|
anyPriceOfferId, legendOnlyOfferId, disabledOfferId :: Text
|
|
anyPriceOfferId = "offer-3m"
|
|
legendOnlyOfferId = "offer-3m-legend"
|
|
disabledOfferId = "offer-retired"
|
|
|
|
seedCheckoutCatalog :: DBStore -> IO ()
|
|
seedCheckoutCatalog st = do
|
|
insertPrice st supporterPriceId "supporter" 500 "active"
|
|
insertPrice st legendPriceId "legend" 2000 "active"
|
|
insertPrice st disabledPriceId "supporter" 500 "disabled"
|
|
insertOffer st anyPriceOfferId Nothing 3 10 "active"
|
|
insertOffer st legendOnlyOfferId (Just legendPriceId) 3 10 "active"
|
|
insertOffer st disabledOfferId Nothing 3 10 "disabled"
|
|
|
|
codeDigest :: Text -> ByteString
|
|
codeDigest = C.sha256Hash . encodeUtf8
|
|
|
|
codeHashText :: Text -> Text
|
|
codeHashText = T.filter (/= '=') . safeDecodeUtf8 . B64U.encode . codeDigest
|
|
|
|
sampleCode :: Text
|
|
sampleCode = "YDC8AYGQTMPUYZ92TUXP"
|
|
|
|
createBody :: Text -> Maybe Text -> Text -> Text -> LB.ByteString
|
|
createBody priceId offerId method codeHash =
|
|
J.encode . J.object $
|
|
["priceId" .= priceId, "method" .= method, "codeHash" .= codeHash]
|
|
<> maybe [] (\o -> ["offerId" .= o]) offerId
|
|
|
|
postCreateAs :: WebClient -> Int -> LB.ByteString -> IO (Response LB.ByteString)
|
|
postCreateAs client i body =
|
|
webRequestBody
|
|
client
|
|
"POST"
|
|
"/api/invoice"
|
|
[(hContentType, "application/json"), ("X-Forwarded-For", BC.pack ("203.0.113." <> show i))]
|
|
body
|
|
|
|
withCheckout :: (IORef StubState -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withCheckout = withCheckoutProvider stubProvider
|
|
|
|
withCheckoutProvider :: (IORef StubState -> Provider) -> (IORef StubState -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withCheckoutProvider mkProvider action =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-checkout" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
seedCheckoutCatalog st
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig}
|
|
withListener [mkProvider ref] True holdMicros st cfg (action ref)
|
|
|
|
invoiceCount :: DBStore -> IO Int
|
|
invoiceCount st = withConnection st $ \db -> do
|
|
rows <- DB.query_ db "SELECT COUNT(*) FROM sx_badge_service_invoices" :: IO [Only Int]
|
|
pure $ case rows of
|
|
(Only n : _) -> n
|
|
[] -> 0
|
|
|
|
plantCodeHash :: DBStore -> Text -> IO ()
|
|
plantCodeHash st code = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)"
|
|
(DB.Binary (codeDigest code), "supporter" :: Text, 1 :: Int, "unpaid" :: Text, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
stringField :: HasCallStack => J.Object -> Text -> IO Text
|
|
stringField o k = case fieldOf o k of
|
|
Just (J.String t) -> pure t
|
|
other -> failWith (T.unpack k <> " is " <> show other)
|
|
|
|
errorBody :: Text -> LB.ByteString
|
|
errorBody code = "{\"error\":\"" <> LB.pack (T.unpack code) <> "\"}"
|
|
|
|
testCreateInvoice :: IO ()
|
|
testCreateInvoice = bounded "create invoice" $ withCheckout $ \ref env client -> do
|
|
started <- getCurrentTime
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
headerOf r hContentType `shouldBe` Just "application/json"
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
o <- jsonObject r
|
|
sort (map K.toText (KM.keys o))
|
|
`shouldBe` sort ["invoiceId", "badgeType", "months", "amount", "currency", "expiresAt", "address", "cryptoAmount", "cryptoCurrency"]
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "supporter")
|
|
fieldOf o "months" `shouldBe` Just (J.Number 1)
|
|
fieldOf o "amount" `shouldBe` Just (J.Number 500)
|
|
fieldOf o "currency" `shouldBe` Just (J.String "usd")
|
|
fieldOf o "address" `shouldBe` Just (J.String "bc1qexampleaddress")
|
|
fieldOf o "cryptoAmount" `shouldBe` Just (J.String "0.00050000")
|
|
fieldOf o "cryptoCurrency" `shouldBe` Just (J.String "btc")
|
|
invId <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) invId
|
|
irStatus row `shouldBe` ISOpen
|
|
irProvider row `shouldBe` PPCrypto
|
|
irProviderRef row `shouldBe` piProviderRef sampleProviderInvoice
|
|
irBadgeType row `shouldBe` BTSupporter
|
|
irMonths row `shouldBe` 1
|
|
irPrice row `shouldBe` CurrencyAmount 500
|
|
irAmount row `shouldBe` CurrencyAmount 500
|
|
irDestination row `shouldBe` piDestination sampleProviderInvoice
|
|
codeRow <- settledCode (weStore env) invId
|
|
bcPaymentStatus codeRow `shouldBe` CPSUnpaid
|
|
fieldOf o "expiresAt" `shouldBe` Just (J.toJSON (irExpiresAt row))
|
|
diffUTCTime (irExpiresAt row) started `shouldSatisfy` \d -> d > 44 * 60 && d <= 46 * 60
|
|
calls <- stubCalls ref
|
|
case calls of
|
|
[StubCreate method draft] -> do
|
|
method `shouldBe` SPMCrypto CCBtc
|
|
odAmount draft `shouldBe` CurrencyAmount 500
|
|
odCurrency draft `shouldBe` "usd"
|
|
other -> expectationFailure ("provider calls: " <> show other)
|
|
|
|
testXmrReachesTheProviderAsXmr :: IO ()
|
|
testXmrReachesTheProviderAsXmr = bounded "xmr is xmr" $ withCheckout $ \ref _ client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "xmr" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
stubCalls ref >>= \case
|
|
[StubCreate method _] -> method `shouldBe` SPMCrypto CCXmr
|
|
other -> expectationFailure ("provider calls: " <> show other)
|
|
|
|
testCreateCarriesNoCode :: IO ()
|
|
testCreateCarriesNoCode = bounded "no code in the response" $ withCheckout $ \_ env client -> do
|
|
let hashText = codeHashText sampleCode
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" hashText)
|
|
statusOf r `shouldBe` 200
|
|
let raw = LB.unpack (responseBody r)
|
|
raw `shouldNotContain` T.unpack sampleCode
|
|
raw `shouldNotContain` T.unpack hashText
|
|
raw `shouldNotContain` T.unpack supporterPriceId
|
|
raw `shouldContain` "invoiceId"
|
|
invoiceCount (weStore env) `shouldReturn` 1
|
|
|
|
testCreateDerivesFromCatalog :: IO ()
|
|
testCreateDerivesFromCatalog = bounded "derived from the catalog" $ withCheckout $ \_ env client -> do
|
|
let tampered =
|
|
J.encode $
|
|
J.object
|
|
[ "priceId" .= legendPriceId,
|
|
"offerId" .= anyPriceOfferId,
|
|
"method" .= ("btc" :: Text),
|
|
"codeHash" .= codeHashText sampleCode,
|
|
"badgeType" .= ("supporter" :: Text),
|
|
"months" .= (1 :: Int),
|
|
"amount" .= (500 :: Int)
|
|
]
|
|
r <- postCreateAs client 1 tampered
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "legend")
|
|
fieldOf o "months" `shouldBe` Just (J.Number 3)
|
|
fieldOf o "amount" `shouldBe` Just (J.Number 5400)
|
|
invId <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) invId
|
|
irBadgeType row `shouldBe` BTLegend
|
|
irMonths row `shouldBe` 3
|
|
irPrice row `shouldBe` CurrencyAmount 6000
|
|
irAmount row `shouldBe` CurrencyAmount 5400
|
|
|
|
testCatalogRefusalCostsNothing :: IO ()
|
|
testCatalogRefusalCostsNothing = bounded "catalog refusals" $ withCheckout $ \ref env client -> do
|
|
let cases :: [(String, Text, Maybe Text)]
|
|
cases =
|
|
[ ("an unknown price", "price-that-never-existed", Nothing),
|
|
("a disabled price", disabledPriceId, Nothing),
|
|
("an unknown offer", supporterPriceId, Just "offer-that-never-existed"),
|
|
("a disabled offer", supporterPriceId, Just disabledOfferId),
|
|
("an offer belonging to another price", supporterPriceId, Just legendOnlyOfferId)
|
|
]
|
|
mapM_
|
|
( \(i, (label, priceId, offerId)) -> do
|
|
r <- postCreateAs client i (createBody priceId offerId "btc" (codeHashText sampleCode))
|
|
(label, statusOf r) `shouldBe` (label, 400)
|
|
(label, responseBody r) `shouldBe` (label, errorBody "catalog_changed")
|
|
)
|
|
(zip [30 ..] cases)
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
testCodeConflictCostsNothing :: IO ()
|
|
testCodeConflictCostsNothing = bounded "code conflict" $ withCheckout $ \ref env client -> do
|
|
first <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf first `shouldBe` 200
|
|
sold <- stubCalls ref
|
|
length sold `shouldBe` 1
|
|
again <- postCreateAs client 2 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf again `shouldBe` 409
|
|
responseBody again `shouldBe` errorBody "code_conflict"
|
|
stubCalls ref `shouldReturn` sold
|
|
invoiceCount (weStore env) `shouldReturn` 1
|
|
|
|
testRacingCodeHashIsConflict :: IO ()
|
|
testRacingCodeHashIsConflict = bounded "racing code hash" $ do
|
|
planted <- newIORef (Nothing :: Maybe DBStore)
|
|
let racing ref =
|
|
let stub = stubProvider ref
|
|
in stub
|
|
{ pCreateInvoice = \method draft -> do
|
|
readIORef planted >>= mapM_ (`plantCodeHash` sampleCode)
|
|
pCreateInvoice stub method draft
|
|
}
|
|
withCheckoutProvider racing $ \ref env client -> do
|
|
atomicModifyIORef' planted (const (Just (weStore env), ()))
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 409
|
|
responseBody r `shouldBe` errorBody "code_conflict"
|
|
length <$> stubCalls ref `shouldReturn` 1
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
testStoreLostAfterTheProviderCreated :: IO ()
|
|
testStoreLostAfterTheProviderCreated = bounded "orphan at the provider" $ do
|
|
broken <- newIORef (Nothing :: Maybe DBStore)
|
|
let losing ref =
|
|
let stub = stubProvider ref
|
|
in stub
|
|
{ pCreateInvoice = \method draft -> do
|
|
readIORef broken >>= mapM_ breakStore
|
|
pCreateInvoice stub method draft
|
|
}
|
|
withCheckoutProvider losing $ \ref env client -> do
|
|
atomicModifyIORef' broken (const (Just (weStore env), ()))
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 500
|
|
responseBody r `shouldBe` errorBody "internal"
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
length <$> stubCalls ref `shouldReturn` 1
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
testBadRequestCostsNothing :: IO ()
|
|
testBadRequestCostsNothing = bounded "bad requests" $ withCheckout $ \ref env client -> do
|
|
let good = codeHashText sampleCode
|
|
bodies :: [(String, LB.ByteString)]
|
|
bodies =
|
|
[ ("not JSON at all", "priceId=price-supporter"),
|
|
("a JSON array", "[]"),
|
|
("no fields", "{}"),
|
|
("no method", J.encode (J.object ["priceId" .= supporterPriceId, "codeHash" .= good])),
|
|
("no codeHash", J.encode (J.object ["priceId" .= supporterPriceId, "method" .= ("btc" :: Text)])),
|
|
("no priceId", J.encode (J.object ["method" .= ("btc" :: Text), "codeHash" .= good])),
|
|
("an unknown method", createBody supporterPriceId Nothing "paypal" good),
|
|
("a mistyped method", J.encode (J.object ["priceId" .= supporterPriceId, "method" .= (7 :: Int), "codeHash" .= good])),
|
|
("a mistyped offerId", J.encode (J.object ["priceId" .= supporterPriceId, "offerId" .= (7 :: Int), "method" .= ("btc" :: Text), "codeHash" .= good])),
|
|
("an empty codeHash", createBody supporterPriceId Nothing "btc" ""),
|
|
("a hex codeHash", createBody supporterPriceId Nothing "btc" (T.replicate 64 "a")),
|
|
("a truncated codeHash", createBody supporterPriceId Nothing "btc" (T.dropEnd 1 good)),
|
|
("a padded codeHash", createBody supporterPriceId Nothing "btc" (good <> "=")),
|
|
("a codeHash outside base64url", createBody supporterPriceId Nothing "btc" (T.dropEnd 1 good <> "+")),
|
|
("a non-canonical codeHash", createBody supporterPriceId Nothing "btc" (T.dropEnd 1 good <> "B"))
|
|
]
|
|
mapM_
|
|
( \(i, (label, body)) -> do
|
|
r <- postCreateAs client i body
|
|
(label, statusOf r) `shouldBe` (label, 400)
|
|
(label, responseBody r) `shouldBe` (label, errorBody "bad_request")
|
|
)
|
|
(zip [10 ..] bodies)
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
testOversizedBodyCostsNothing :: IO ()
|
|
testOversizedBodyCostsNothing = bounded "oversized body" $ withCheckout $ \ref env client -> do
|
|
let padded =
|
|
J.encode $
|
|
J.object
|
|
[ "priceId" .= supporterPriceId,
|
|
"method" .= ("btc" :: Text),
|
|
"codeHash" .= codeHashText sampleCode,
|
|
"padding" .= T.replicate (64 * 1024) "x"
|
|
]
|
|
LB.length padded `shouldSatisfy` (> 64 * 1024)
|
|
r <- postCreateAs client 1 padded
|
|
statusOf r `shouldBe` 400
|
|
responseBody r `shouldBe` errorBody "bad_request"
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
small <- postCreateAs client 2 (J.encode (J.object ["priceId" .= supporterPriceId, "method" .= ("btc" :: Text), "codeHash" .= codeHashText sampleCode, "padding" .= T.replicate 16 "x"]))
|
|
statusOf small `shouldBe` 200
|
|
|
|
testCardUnconfigured503 :: IO ()
|
|
testCardUnconfigured503 = bounded "card is unavailable" $ withCheckout $ \ref env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 503
|
|
responseBody r `shouldBe` errorBody "provider_unavailable"
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
stripeWebhookPath :: String
|
|
stripeWebhookPath = "/webhooks/stripe"
|
|
|
|
postStripeWebhook :: WebClient -> [Header] -> LB.ByteString -> IO (Response LB.ByteString)
|
|
postStripeWebhook client hdrs = webRequestBody client "POST" stripeWebhookPath hdrs
|
|
|
|
signedStripeEvent :: FakeStripe -> Text -> Text -> IO ([Header], LB.ByteString)
|
|
signedStripeEvent fake eventType sid = do
|
|
t <- round . utcTimeToPOSIXSeconds <$> getCurrentTime :: IO Int
|
|
let body = stripeEvent eventType sid
|
|
pure (stripeSigHeader (sWebhookSecret (fsConfig fake)) t body, body)
|
|
|
|
withFakeStripePoller :: (FakeStripe -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withFakeStripePoller action =
|
|
withFakeStripe $ \fake ->
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-stripe-fake" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
seedCheckoutCatalog st
|
|
provider <- stripeProvider (fsConfig fake)
|
|
let cfg = (testServiceConfig staticDir True) {stripe = Just (fsConfig fake)}
|
|
withListener [provider] True holdMicros st cfg $ \env client -> do
|
|
poller <- pollerFor env
|
|
action fake poller env client
|
|
|
|
testCardCreatesSession :: IO ()
|
|
testCardCreatesSession = bounded "card creates a session" $ withFakeStripePoller $ \_ _ env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
headerOf r hContentType `shouldBe` Just "application/json"
|
|
o <- jsonObject r
|
|
fieldOf o "clientSecret" `shouldSatisfy` isJust
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "supporter")
|
|
invId <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) invId
|
|
irProvider row `shouldBe` PPStripe
|
|
irStatus row `shouldBe` ISOpen
|
|
bcPaymentStatus <$> settledCode (weStore env) invId `shouldReturn` CPSUnpaid
|
|
|
|
testCardSweepCancelsTheIntent :: IO ()
|
|
testCardSweepCancelsTheIntent = bounded "card sweep cancels" $ withFakeStripePoller $ \fake poller env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
invId@(InvoiceId iid) <- InvoiceId <$> stringField o "invoiceId"
|
|
Just InvoiceRow {irProviderRef = pid} <- getInvoice (weStore env) invId
|
|
past <- addUTCTime (negate (expiryGrace + 60)) <$> getCurrentTime
|
|
withConnection (weStore env) $ \db ->
|
|
DB.execute db "UPDATE sx_badge_service_invoices SET expires_at = ? WHERE invoice_id = ?" (truncateToSecond past, iid)
|
|
runOnePass poller
|
|
fakeIntentStatus fake pid `shouldReturn` Just "canceled"
|
|
invoiceStatus (weStore env) invId `shouldReturn` ISExpired
|
|
|
|
-- | This value differs from the default 60 and the btcpay window 45, so a card expiry read from
|
|
-- the wrong key would show up as one of those instead.
|
|
cardSessionMinutes :: Int
|
|
cardSessionMinutes = 90
|
|
|
|
testCardExpiryFollowsSessionMinutes :: IO ()
|
|
testCardExpiryFollowsSessionMinutes = bounded "card expiry from session_minutes" $
|
|
withFakeStripe $ \fake ->
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-stripe-expiry" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
seedCheckoutCatalog st
|
|
let stripeCfg = (fsConfig fake) {sSessionMinutes = cardSessionMinutes}
|
|
cfg = (testServiceConfig staticDir True) {stripe = Just stripeCfg, btcpay = Just testBTCPayConfig}
|
|
provider <- stripeProvider stripeCfg
|
|
withListener [provider] True holdMicros st cfg $ \env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
invId <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) invId
|
|
fieldOf o "expiresAt" `shouldBe` Just (J.toJSON (irExpiresAt row))
|
|
diffUTCTime (irExpiresAt row) (irCreatedAt row) `shouldBe` fromIntegral (cardSessionMinutes * 60)
|
|
diffUTCTime (irExpiresAt row) (irCreatedAt row) `shouldNotBe` fromIntegral (testExpiryMinutes * 60)
|
|
|
|
testCardWebhookSettles :: IO ()
|
|
testCardWebhookSettles = bounded "card webhook settles" $ withFakeStripePoller $ \fake poller env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
iid <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) iid
|
|
let pid = irProviderRef row
|
|
setIntentState fake pid ["status" .= ("succeeded" :: Text)]
|
|
(hdrs, body) <- signedStripeEvent fake "payment_intent.succeeded" pid
|
|
delivered <- postStripeWebhook client hdrs body
|
|
statusOf delivered `shouldBe` 200
|
|
responseBody delivered `shouldBe` ""
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
drainHints poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
|
|
ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "settled"
|
|
|
|
testProviderFailureWritesNothing :: IO ()
|
|
testProviderFailureWritesNothing = bounded "provider failure" $ withCheckout $ \ref env client -> do
|
|
atomicModifyIORef' ref $ \s -> (s {ssCreateResult = Left (ProviderError "connection refused")}, ())
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 503
|
|
responseBody r `shouldBe` errorBody "provider_unavailable"
|
|
length <$> stubCalls ref `shouldReturn` 1
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
codeHashExists (weStore env) (codeDigest sampleCode) `shouldReturn` False
|
|
|
|
-- | provider_ref is unique, so a test that creates several invoices must vary it as a real
|
|
-- provider would.
|
|
distinctProviderRefs :: IORef StubState -> Provider
|
|
distinctProviderRefs ref =
|
|
let stub = stubProvider ref
|
|
in stub
|
|
{ pCreateInvoice = \method draft -> do
|
|
created <- pCreateInvoice stub method draft
|
|
n <- length <$> stubCalls ref
|
|
pure (fmap (\inv -> inv {piProviderRef = piProviderRef inv <> "-" <> T.pack (show n)}) created)
|
|
}
|
|
|
|
testCreateRateLimit :: IO ()
|
|
testCreateRateLimit = bounded "create rate limit" $ withCheckoutProvider distinctProviderRefs $ \ref env client -> do
|
|
let attempt n = postCreateAs client 20 (createBody supporterPriceId Nothing "btc" (codeHashText (sampleCode <> T.pack (show (n :: Int)))))
|
|
allowed <- mapM (fmap statusOf . attempt) [1 .. createsPerMinute]
|
|
allowed `shouldSatisfy` all (== 200)
|
|
refused <- attempt (createsPerMinute + 1)
|
|
statusOf refused `shouldBe` 429
|
|
responseBody refused `shouldBe` errorBody "rate_limited"
|
|
headerOf refused hCacheControl `shouldBe` Just "no-store"
|
|
case headerOf refused "Retry-After" >>= (readMaybe . BC.unpack) of
|
|
Just seconds -> seconds `shouldSatisfy` \s -> s >= (1 :: Int) && s <= 60
|
|
Nothing -> expectationFailure ("Retry-After is " <> show (headerOf refused "Retry-After"))
|
|
length <$> stubCalls ref `shouldReturn` createsPerMinute
|
|
invoiceCount (weStore env) `shouldReturn` createsPerMinute
|
|
|
|
settleAt :: UTCTime
|
|
settleAt = UTCTime (fromGregorian 2026 9 2) (secondsToDiffTime (12 * 3600 + 34 * 60 + 56))
|
|
|
|
replayAt :: UTCTime
|
|
replayAt = addUTCTime 3600 settleAt
|
|
|
|
-- | The service always learns of settlement later than it happened, so this differs from
|
|
-- settleAt, and using one value for both would let a build that wrote the wrong one still pass.
|
|
detectedAt :: UTCTime
|
|
detectedAt = addUTCTime 300 settleAt
|
|
|
|
rcv :: Word32 -> Maybe Text -> Received
|
|
rcv amount crypto = Received {rcvAmount = CurrencyAmount amount, rcvCrypto = crypto, rcvDue = Nothing}
|
|
|
|
settle :: DBStore -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus)
|
|
settle st iid signal at = newWaiters >>= \waiters -> settleOrder st waiters iid signal at
|
|
|
|
seedOpen :: HasCallStack => DBStore -> IO InvoiceId
|
|
seedOpen st = do
|
|
seedBadgePrice st "price1"
|
|
createInvoiceRows st sampleInvoice `shouldReturn` Right ()
|
|
pure (niInvoiceId sampleInvoice)
|
|
|
|
invoiceStatus :: HasCallStack => DBStore -> InvoiceId -> IO InvoiceStatus
|
|
invoiceStatus st iid = getInvoice st iid >>= maybe (failWith "no invoice row") (pure . irStatus)
|
|
|
|
paymentRow :: HasCallStack => DBStore -> InvoiceId -> IO InvoicePayment
|
|
paymentRow st iid =
|
|
getInvoice st iid >>= \case
|
|
Just InvoiceRow {irPayment = Just p} -> pure p
|
|
_ -> failWith "no payment row"
|
|
|
|
data CodeRow = CodeRow {bcPaymentStatus :: BadgeCodePaymentStatus, bcExpiresAt :: Maybe UTCTime, bcRevokedAt :: Maybe UTCTime}
|
|
deriving (Eq, Show)
|
|
|
|
settledCode :: HasCallStack => DBStore -> InvoiceId -> IO CodeRow
|
|
settledCode st (InvoiceId iid) = withConnection st $ \db -> do
|
|
rows <-
|
|
DB.query
|
|
db
|
|
"SELECT c.code_payment_status, c.expires_at, c.revoked_at FROM sx_badge_service_badge_codes c JOIN sx_badge_service_badge_code_invoices ci ON ci.badge_code_id = c.badge_code_id WHERE ci.invoice_id = ?"
|
|
(Only iid)
|
|
case rows of
|
|
(status, expiresAt, revokedAt) : _ -> pure CodeRow {bcPaymentStatus = fromMaybe CPSUnpaid (textDecode status), bcExpiresAt = expiresAt, bcRevokedAt = revokedAt}
|
|
[] -> failWith "no badge_codes row"
|
|
|
|
paymentIdentity :: DBStore -> InvoiceId -> IO [(Text, Text, Maybe Text, Maybe Text)]
|
|
paymentIdentity st (InvoiceId iid) = withConnection st $ \db ->
|
|
DB.query db "SELECT payment_id, provider, provider_ref, currency FROM sx_badge_service_payments WHERE invoice_id = ?" (Only iid)
|
|
|
|
touchInvoice :: DBStore -> InvoiceId -> UTCTime -> IO ()
|
|
touchInvoice st (InvoiceId iid) at = withConnection st $ \db ->
|
|
DB.execute db "UPDATE sx_badge_service_invoices SET updated_at = ? WHERE invoice_id = ?" (at, iid)
|
|
|
|
-- | On SQLite the DBStore serialises access behind one connection, so a read taken through it
|
|
-- during a transaction would block rather than see uncommitted state; testPublishIsAfterCommit
|
|
-- needs this read to open its own connection instead.
|
|
independentStatus :: DBStore -> InvoiceId -> IO (Maybe Text)
|
|
#if defined(dbPostgres)
|
|
independentStatus st (InvoiceId iid) = withConnection st $ \db -> do
|
|
rows <- DB.query db "SELECT status FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only iid)
|
|
pure $ case rows of
|
|
(Only s : _) -> Just s
|
|
[] -> Nothing
|
|
#else
|
|
independentStatus DBStore {dbFilePath} (InvoiceId iid) = E.bracket (SQL.open dbFilePath) SQL.close reader `E.catch` locked
|
|
where
|
|
reader c = do
|
|
rows <- SQL.query c "SELECT status FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only iid)
|
|
pure $ case rows of
|
|
(Only s : _) -> Just s
|
|
[] -> Nothing
|
|
locked :: SQL.SQLError -> IO (Maybe Text)
|
|
locked _ = pure Nothing
|
|
#endif
|
|
|
|
-- | This trigger expires the invoice from inside the settling transaction, and it is a trigger
|
|
-- rather than a concurrent thread because the SQLite store puts every access behind one
|
|
-- connection and so cannot have a concurrent writer.
|
|
expireOnNextPayment :: DBStore -> IO ()
|
|
#if defined(dbPostgres)
|
|
expireOnNextPayment st = withConnection st $ \db -> do
|
|
DB.execute_
|
|
db
|
|
"CREATE FUNCTION sx_badge_service_test_expire() RETURNS trigger AS $$ BEGIN UPDATE sx_badge_service_invoices SET status = 'expired' WHERE invoice_id = NEW.invoice_id; RETURN NEW; END; $$ LANGUAGE plpgsql"
|
|
DB.execute_
|
|
db
|
|
"CREATE TRIGGER sx_badge_service_test_expire_trg AFTER INSERT ON sx_badge_service_payments FOR EACH ROW EXECUTE FUNCTION sx_badge_service_test_expire()"
|
|
#else
|
|
expireOnNextPayment st = withConnection st $ \db ->
|
|
DB.execute_
|
|
db
|
|
"CREATE TRIGGER sx_badge_service_test_expire AFTER INSERT ON sx_badge_service_payments BEGIN UPDATE sx_badge_service_invoices SET status = 'expired' WHERE invoice_id = NEW.invoice_id; END"
|
|
#endif
|
|
|
|
testSettlesAnOpenInvoice :: IO ()
|
|
testSettlesAnOpenInvoice = bounded "settles an open invoice" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
invoiceStatus st iid `shouldReturn` ISPaid
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 500)
|
|
ipCryptoPaid p `shouldBe` Just "0.00050000"
|
|
ipStatus p `shouldBe` "settled"
|
|
ipUpdatedAt p `shouldBe` settleAt
|
|
ipUpdatedAt p `shouldNotBe` detectedAt
|
|
paymentIdentity st iid `shouldReturn` [("inv1", "crypto", Just (niProviderRef sampleInvoice), Just "usd")]
|
|
code <- settledCode st iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime settleAt)
|
|
bcExpiresAt code `shouldNotBe` Just (addUTCTime codeLifetime detectedAt)
|
|
bcRevokedAt code `shouldBe` Nothing
|
|
|
|
testLateSettlementIsLegal :: IO ()
|
|
testLateSettlementIsLegal = bounded "late settlement" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
expireRow st iid
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
settle st iid (SigSettled (rcv 500 Nothing) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
invoiceStatus st iid `shouldReturn` ISPaid
|
|
ipStatus <$> paymentRow st iid `shouldReturn` "settled"
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSPaid
|
|
|
|
testFundedRecordsWithoutMoving :: IO ()
|
|
testFundedRecordsWithoutMoving = bounded "funded records only" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigFunded (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISOpen
|
|
invoiceStatus st iid `shouldReturn` ISOpen
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 200)
|
|
ipStatus p `shouldBe` "pending"
|
|
code <- settledCode st iid
|
|
bcPaymentStatus code `shouldBe` CPSUnpaid
|
|
bcExpiresAt code `shouldBe` Nothing
|
|
expireRow st iid
|
|
settle st iid (SigFunded (rcv 300 (Just "0.00030000")) PaidInPart) replayAt `shouldReturn` Right ISExpired
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
ipAmount <$> paymentRow st iid `shouldReturn` Just (CurrencyAmount 300)
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSUnpaid
|
|
|
|
testClosedExpiresAnOpenInvoice :: IO ()
|
|
testClosedExpiresAnOpenInvoice = bounded "closed expires" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) settleAt `shouldReturn` Right ISExpired
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 200)
|
|
ipStatus p `shouldBe` "pending"
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSUnpaid
|
|
|
|
testClosedWithNothingWritesNoPayment :: IO ()
|
|
testClosedWithNothingWritesNoPayment = bounded "closed on nothing" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigClosed (rcv 0 Nothing)) settleAt `shouldReturn` Right ISExpired
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
Just row <- getInvoice st iid
|
|
irPayment row `shouldBe` Nothing
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSUnpaid
|
|
|
|
testClosedReplayIsIdempotent :: IO ()
|
|
testClosedReplayIsIdempotent = bounded "closed replay" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) settleAt `shouldReturn` Right ISExpired
|
|
settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) replayAt `shouldReturn` Right ISExpired
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 200)
|
|
ipCryptoPaid p `shouldBe` Just "0.00020000"
|
|
ipStatus p `shouldBe` "pending"
|
|
length <$> paymentIdentity st iid `shouldReturn` 1
|
|
|
|
testPaidRefusesEverySignal :: IO ()
|
|
testPaidRefusesEverySignal = bounded "paid refuses" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
settled <- paymentRow st iid
|
|
deadline <- bcExpiresAt <$> settledCode st iid
|
|
mapM_
|
|
( \signal -> do
|
|
settle st iid signal replayAt `shouldReturn` Right ISPaid
|
|
(signal, ) <$> paymentRow st iid `shouldReturn` (signal, settled)
|
|
)
|
|
[ SigSettled (rcv 900 (Just "0.00090000")) replayAt,
|
|
SigFunded (rcv 900 (Just "0.00090000")) PaidInPart,
|
|
SigClosed (rcv 900 (Just "0.00090000"))
|
|
]
|
|
invoiceStatus st iid `shouldReturn` ISPaid
|
|
bcExpiresAt <$> settledCode st iid `shouldReturn` deadline
|
|
|
|
testAmountIsMonotonic :: IO ()
|
|
testAmountIsMonotonic = bounded "monotonic amount" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigFunded (rcv 40000 (Just "0.734")) PaidInPart) settleAt `shouldReturn` Right ISOpen
|
|
settle st iid (SigFunded (rcv 10000 (Just "0.180")) PaidInPart) replayAt `shouldReturn` Right ISOpen
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 40000)
|
|
ipCryptoPaid p `shouldBe` Just "0.734"
|
|
settle st iid (SigFunded (rcv 40000 (Just "0.734")) PaidInPart) replayAt `shouldReturn` Right ISOpen
|
|
settle st iid (SigFunded (rcv 40000 (Just "0.734")) PaidInPart) replayAt `shouldReturn` Right ISOpen
|
|
ipAmount <$> paymentRow st iid `shouldReturn` Just (CurrencyAmount 40000)
|
|
settle st iid (SigFunded (rcv 50000 (Just "0.900")) PaidInPart) replayAt `shouldReturn` Right ISOpen
|
|
p' <- paymentRow st iid
|
|
ipAmount p' `shouldBe` Just (CurrencyAmount 50000)
|
|
ipCryptoPaid p' `shouldBe` Just "0.900"
|
|
|
|
testDeadlineIsFromTheFirstSettlement :: IO ()
|
|
testDeadlineIsFromTheFirstSettlement = bounded "deadline from the first settlement" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigSettled (rcv 500 Nothing) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
let firstDeadline = addUTCTime codeLifetime settleAt
|
|
bcExpiresAt <$> settledCode st iid `shouldReturn` Just firstDeadline
|
|
withTransaction st $ \db -> markCodePaid db (niCodeHash sampleInvoice) (addUTCTime codeLifetime replayAt)
|
|
bcExpiresAt <$> settledCode st iid `shouldReturn` Just firstDeadline
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSPaid
|
|
|
|
testStatusGuardRefusesAStaleObservation :: IO ()
|
|
testStatusGuardRefusesAStaleObservation = bounded "stale observation" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
markPaid st iid
|
|
stale <- withTransaction st $ \db -> updateInvoiceStatus db iid ISOpen ISExpired settleAt
|
|
stale `shouldBe` False
|
|
invoiceStatus st iid `shouldReturn` ISPaid
|
|
let second' = sampleInvoice {niInvoiceId = InvoiceId "inv-2", niProviderRef = "p-2", niCodeHash = digestFixture 15}
|
|
createInvoiceRows st second' `shouldReturn` Right ()
|
|
moved <- withTransaction st $ \db -> updateInvoiceStatus db (niInvoiceId second') ISOpen ISExpired settleAt
|
|
moved `shouldBe` True
|
|
invoiceStatus st (niInvoiceId second') `shouldReturn` ISExpired
|
|
|
|
testUnknownInvoiceSettlesNothing :: IO ()
|
|
testUnknownInvoiceSettlesNothing = bounded "unknown invoice" $ withServiceStore $ \st -> do
|
|
_ <- seedOpen st
|
|
r <- settle st (InvoiceId "no-such-invoice") (SigSettled (rcv 500 Nothing) settleAt) settleAt
|
|
r `shouldSatisfy` isLeft
|
|
paymentIdentity st (InvoiceId "no-such-invoice") `shouldReturn` []
|
|
|
|
testPublishIsAfterCommit :: IO ()
|
|
testPublishIsAfterCommit = bounded "publish after commit" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
waiters <- newWaiters
|
|
seen <- newEmptyMVar
|
|
_ <- forkIO $ do
|
|
woken <- awaitStatus waiters iid ((\s -> (s, ("", False))) <$> invoiceStatus st iid) (ISOpen, ("", False)) waitCeiling
|
|
visible <- independentStatus st iid
|
|
putMVar seen (woken, visible)
|
|
threadDelay 100000
|
|
settleOrder st waiters iid (SigSettled (rcv 500 Nothing) settleAt) settleAt `shouldReturn` Right ISPaid
|
|
takeMVar seen `shouldReturn` (ISPaid, Just "paid")
|
|
|
|
waitCeiling :: Int
|
|
waitCeiling = 10 * 1000000
|
|
|
|
testSettlementWakesAHeldRequest :: IO ()
|
|
testSettlementWakesAHeldRequest = bounded "settlement wakes a hold" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let settled =
|
|
settleOrder (weStore env) (weWaiters env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) settleAt
|
|
`shouldReturn` Right ISPaid
|
|
o <- wokenBy client iid settled "paid"
|
|
fieldOf o "amountPaid" `shouldBe` Just (J.Number 500)
|
|
|
|
testFutureSettledInstantIsRefused :: IO ()
|
|
testFutureSettledInstantIsRefused = bounded "future settled instant" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let inMilliseconds = posixSecondsToUTCTime (1000 * utcTimeToPOSIXSeconds detectedAt)
|
|
settle (weStore env) iid (SigSettled (rcv 500 (Just "0.00050000")) inMilliseconds) detectedAt
|
|
`shouldReturn` Right ISPaid
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime detectedAt)
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "settledAt" `shouldBe` Just (J.toJSON detectedAt)
|
|
|
|
testAbsurdSettledInstantIsRefused :: IO ()
|
|
testAbsurdSettledInstantIsRefused = bounded "absurd settled instant" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let epochZero = posixSecondsToUTCTime 0
|
|
settle (weStore env) iid (SigSettled (rcv 500 (Just "0.00050000")) epochZero) detectedAt
|
|
`shouldReturn` Right ISPaid
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldSatisfy` maybe False (> detectedAt)
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf o "settledAt" `shouldBe` Just (J.toJSON detectedAt)
|
|
|
|
testSettledAtIsThePaymentRow :: IO ()
|
|
testSettledAtIsThePaymentRow = bounded "settledAt" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settle (weStore env) iid (SigSettled (rcv 500 Nothing) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf o "settledAt" `shouldBe` Just (J.toJSON settleAt)
|
|
fieldOf o "settledAt" `shouldNotBe` Just (J.toJSON someCreated)
|
|
fieldOf o "settledAt" `shouldNotBe` Just (J.toJSON detectedAt)
|
|
touchInvoice (weStore env) iid replayAt
|
|
o' <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o' "settledAt" `shouldBe` Just (J.toJSON settleAt)
|
|
|
|
testLosingTheStatusGuardStillWakesTheHold :: IO ()
|
|
testLosingTheStatusGuardStillWakesTheHold = bounded "losing the guard" $ withWebAppHolding raceHold $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
expireOnNextPayment (weStore env)
|
|
_ <- wokenBy client iid (settledIntoAnExpiredRow env iid) "expired"
|
|
pure ()
|
|
|
|
settledIntoAnExpiredRow :: HasCallStack => WebEnv -> InvoiceId -> IO ()
|
|
settledIntoAnExpiredRow env iid = do
|
|
settleOrder (weStore env) (weWaiters env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) settleAt
|
|
`shouldReturn` Right ISExpired
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSUnpaid
|
|
bcExpiresAt code `shouldBe` Nothing
|
|
ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "settled"
|
|
|
|
raceHold :: Int
|
|
raceHold = 3 * 1000000
|
|
|
|
testSettledPaymentIsNotDowngraded :: IO ()
|
|
testSettledPaymentIsNotDowngraded = bounded "settled is not downgraded" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
row <- getInvoice st iid >>= maybe (failWith "no invoice row") pure
|
|
withTransaction st $ \db -> upsertPayment db row PSSettled (CurrencyAmount 500) (Just "0.00050000") Nothing False settleAt
|
|
withTransaction st $ \db -> upsertPayment db row PSPending (CurrencyAmount 200) (Just "0.00020000") Nothing False replayAt
|
|
p <- paymentRow st iid
|
|
ipStatus p `shouldBe` "settled"
|
|
ipUpdatedAt p `shouldBe` settleAt
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 500)
|
|
ipCryptoPaid p `shouldBe` Just "0.00050000"
|
|
let second' = sampleInvoice {niInvoiceId = InvoiceId "inv-pending", niProviderRef = "p-pending", niCodeHash = digestFixture 16}
|
|
createInvoiceRows st second' `shouldReturn` Right ()
|
|
row' <- getInvoice st (niInvoiceId second') >>= maybe (failWith "no invoice row") pure
|
|
withTransaction st $ \db -> upsertPayment db row' PSPending (CurrencyAmount 100) Nothing Nothing False settleAt
|
|
withTransaction st $ \db -> upsertPayment db row' PSSettled (CurrencyAmount 500) (Just "0.00050000") Nothing False replayAt
|
|
p' <- paymentRow st (niInvoiceId second')
|
|
ipStatus p' `shouldBe` "settled"
|
|
ipUpdatedAt p' `shouldBe` replayAt
|
|
|
|
testCryptoAmountFillsInFromNull :: IO ()
|
|
testCryptoAmountFillsInFromNull = bounded "crypto fills in" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigFunded (rcv 500 Nothing) PaidInPart) settleAt `shouldReturn` Right ISOpen
|
|
ipCryptoPaid <$> paymentRow st iid `shouldReturn` Nothing
|
|
settle st iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
ipCryptoPaid <$> paymentRow st iid `shouldReturn` Just "0.00050000"
|
|
ipAmount <$> paymentRow st iid `shouldReturn` Just (CurrencyAmount 500)
|
|
|
|
pollerFor :: WebEnv -> IO PollerEnv
|
|
pollerFor WebEnv {weStore, weConfig, weWaiters, weHints, weProviders} =
|
|
newPollerEnv weStore weWaiters weHints weProviders (poll weConfig)
|
|
|
|
withStubPoller :: Int -> (IORef StubState -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withStubPoller = withStubPollerOf stubProvider
|
|
|
|
withStubPollerOf :: (IORef StubState -> Provider) -> Int -> (IORef StubState -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withStubPollerOf mkProvider hold action =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-poller" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig}
|
|
withListener [mkProvider ref] True hold st cfg $ \env client -> do
|
|
poller <- pollerFor env
|
|
action ref poller env client
|
|
|
|
withFakePoller :: (FakeBTCPay -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withFakePoller = withFakePollerHolding holdMicros
|
|
|
|
withFakePollerHolding :: Int -> (FakeBTCPay -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withFakePollerHolding hold action =
|
|
withFakeBTCPay $ \fake ->
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-poller-fake" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
seedCheckoutCatalog st
|
|
provider <- btcpayProvider (fbConfig fake)
|
|
let cfg = (testServiceConfig staticDir True) {btcpay = Just (fbConfig fake)}
|
|
withListener [provider] True hold st cfg $ \env client -> do
|
|
poller <- pollerFor env
|
|
action fake poller env client
|
|
|
|
withFakeProvider :: (FakeBTCPay -> Provider -> IO a) -> IO a
|
|
withFakeProvider action = withFakeBTCPay $ \fake -> btcpayProvider (fbConfig fake) >>= action fake
|
|
|
|
setSignals :: IORef StubState -> [(Text, PaymentSignal)] -> IO ()
|
|
setSignals ref signals = atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.fromList signals}, ())
|
|
|
|
clearCalls :: IORef StubState -> IO ()
|
|
clearCalls ref = atomicModifyIORef' ref $ \s -> (s {ssCalls = []}, ())
|
|
|
|
setSkipped :: IORef StubState -> [(Maybe Text, Text)] -> IO ()
|
|
setSkipped ref reasons = atomicModifyIORef' ref $ \s -> (s {ssSkipped = reasons}, ())
|
|
|
|
failList :: IORef StubState -> Maybe ProviderError -> IO ()
|
|
failList ref e = atomicModifyIORef' ref $ \s -> (s {ssListError = e}, ())
|
|
|
|
failRead :: IORef StubState -> Maybe ProviderError -> IO ()
|
|
failRead ref e = atomicModifyIORef' ref $ \s -> (s {ssReadError = e}, ())
|
|
|
|
seedOpenRef :: HasCallStack => DBStore -> Int -> Text -> UTCTime -> IO InvoiceId
|
|
seedOpenRef = seedOpenRefOf PPCrypto
|
|
|
|
seedOpenRefOf :: HasCallStack => PaymentProvider -> DBStore -> Int -> Text -> UTCTime -> IO InvoiceId
|
|
seedOpenRefOf provider st i providerRef expiresAt = do
|
|
-- The row is created at the current time because the poller reads only invoices inside its
|
|
-- recent settle window and sweeps anything older.
|
|
createdAt <- truncateToSecond <$> getCurrentTime
|
|
let n = T.pack (show i)
|
|
iid = InvoiceId ("inv-poll-" <> n)
|
|
ni =
|
|
sampleInvoice
|
|
{ niInvoiceId = iid,
|
|
niProviderRef = providerRef,
|
|
niCodeHash = digestFixture (fromIntegral i + 20),
|
|
niExpiresAt = expiresAt,
|
|
niCreatedAt = createdAt,
|
|
niProvider = provider
|
|
}
|
|
createInvoiceRows st ni `shouldReturn` Right ()
|
|
pure iid
|
|
|
|
seedOtherProvider :: HasCallStack => DBStore -> Int -> Text -> IO InvoiceId
|
|
seedOtherProvider st i providerRef = do
|
|
createdAt <- truncateToSecond <$> getCurrentTime
|
|
let n = T.pack (show i)
|
|
iid = InvoiceId ("inv-poll-" <> n)
|
|
ni =
|
|
sampleInvoice
|
|
{ niInvoiceId = iid,
|
|
niProviderRef = providerRef,
|
|
niCodeHash = digestFixture (fromIntegral i + 40),
|
|
niProvider = PPStripe,
|
|
niCreatedAt = createdAt
|
|
}
|
|
createInvoiceRows st ni `shouldReturn` Right ()
|
|
pure iid
|
|
|
|
settledSignal :: PaymentSignal
|
|
settledSignal = SigSettled (rcv 500 (Just "0.00050000")) settleAt
|
|
|
|
testSettlesWithNoWebhookAtAll :: IO ()
|
|
testSettlesWithNoWebhookAtAll = bounded "no webhook at all" $ withFakePoller $ \fake poller env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "xmr" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
iid <- InvoiceId <$> stringField o "invoiceId"
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
|
|
Just row <- getInvoice (weStore env) iid
|
|
setInvoiceState fake (irProviderRef row) ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.32095000" :: Text)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldSatisfy` isJust
|
|
p <- paymentRow (weStore env) iid
|
|
ipStatus p `shouldBe` "settled"
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 5400)
|
|
ipCryptoPaid p `shouldBe` Just "0.32095000"
|
|
|
|
testPassReadsWhatItAwaits :: IO ()
|
|
testPassReadsWhatItAwaits = bounded "reads what it awaits" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
a <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
b <- seedOpenRef (weStore env) 2 "p-2" someExpiry
|
|
c <- seedOpenRef (weStore env) 3 "p-3" someExpiry
|
|
setSignals ref [("p-1", settledSignal), ("p-2", settledSignal), ("p-3", settledSignal)]
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` [StubRead "p-1", StubRead "p-2", StubRead "p-3", StubListOpen]
|
|
mapM (invoiceStatus (weStore env)) [a, b, c] `shouldReturn` [ISPaid, ISPaid, ISPaid]
|
|
|
|
testIdlePassAsksNothing :: IO ()
|
|
testIdlePassAsksNothing = bounded "idle pass" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
setSignals ref [("p-1", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
clearCalls ref
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
testManyOpenInvoicesList :: IO ()
|
|
testManyOpenInvoicesList = bounded "many open" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
mapM_ (\i -> seedOpenRef (weStore env) i ("p-many-" <> tshow i) someExpiry) [1 .. readsPerPass + 1]
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` [StubListOpen]
|
|
|
|
testNoProviderAccountsForNothing :: HasCallStack => IO ()
|
|
testNoProviderAccountsForNothing = bounded "no provider" $ withStubPoller raceHold $ \_ poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
let overdue i = seedOpenRef (weStore env) i ("p-none-" <> tshow i) (addUTCTime (negate (expiryGrace + 60)) now)
|
|
few <- mapM overdue [1 .. 3]
|
|
let blind = poller {peProviders = []}
|
|
runOnePass blind
|
|
mapM (invoiceStatus (weStore env)) few `shouldReturn` replicate 3 ISOpen
|
|
many <- mapM overdue [4 .. readsPerPass + 4]
|
|
runOnePass blind
|
|
mapM (invoiceStatus (weStore env)) (few <> many) `shouldReturn` replicate (length few + length many) ISOpen
|
|
|
|
testBulkListIsTheOnlyList :: HasCallStack => IO ()
|
|
testBulkListIsTheOnlyList = bounded "bulk lists once" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
mapM_ (\i -> seedOpenRef (weStore env) i ("p-cadence-" <> tshow i) someExpiry) [1 .. readsPerPass + 1]
|
|
setSignals ref [("p-cadence-" <> tshow i, settledSignal) | i <- [1 .. readsPerPass]]
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` [StubListOpen]
|
|
clearCalls ref
|
|
runOnePass poller
|
|
calls <- stubCalls ref
|
|
filter (== StubListOpen) calls `shouldBe` []
|
|
|
|
testMixedProvidersHoldTheSweep :: HasCallStack => IO ()
|
|
testMixedProvidersHoldTheSweep = bounded "mixed providers" $ withStubPoller raceHold $ \_ poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
mapM_ (\i -> seedOpenRef (weStore env) i ("p-mixed-" <> tshow i) someExpiry) [1 .. readsPerPass + 1]
|
|
createdAt <- truncateToSecond <$> getCurrentTime
|
|
let iid = InvoiceId "inv-poll-stripe"
|
|
stripeRow =
|
|
sampleInvoice
|
|
{ niInvoiceId = iid,
|
|
niProviderRef = "p-stripe-mixed",
|
|
niCodeHash = digestFixture 99,
|
|
niProvider = PPStripe,
|
|
niExpiresAt = addUTCTime (negate (expiryGrace + 60)) now,
|
|
niCreatedAt = createdAt
|
|
}
|
|
createInvoiceRows (weStore env) stripeRow `shouldReturn` Right ()
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
|
|
testEverySignalSettles :: IO ()
|
|
testEverySignalSettles = bounded "every signal settles" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
paid <- seedOpenRef (weStore env) 1 "p-settled" someExpiry
|
|
funded <- seedOpenRef (weStore env) 2 "p-funded" someExpiry
|
|
closed <- seedOpenRef (weStore env) 3 "p-closed" someExpiry
|
|
setSignals
|
|
ref
|
|
[ ("p-settled", settledSignal),
|
|
("p-funded", SigFunded (rcv 200 (Just "0.00020000")) PaidInPart),
|
|
("p-closed", SigClosed (rcv 100 (Just "0.00010000")))
|
|
]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) paid `shouldReturn` ISPaid
|
|
invoiceStatus (weStore env) funded `shouldReturn` ISOpen
|
|
ipAmount <$> paymentRow (weStore env) funded `shouldReturn` Just (CurrencyAmount 200)
|
|
invoiceStatus (weStore env) closed `shouldReturn` ISExpired
|
|
ipCryptoPaid <$> paymentRow (weStore env) closed `shouldReturn` Just "0.00010000"
|
|
bcPaymentStatus <$> settledCode (weStore env) paid `shouldReturn` CPSPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) funded `shouldReturn` CPSUnpaid
|
|
bcPaymentStatus <$> settledCode (weStore env) closed `shouldReturn` CPSUnpaid
|
|
|
|
testForeignRefIsPassedOver :: IO ()
|
|
testForeignRefIsPassedOver = bounded "foreign ref" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
ours <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
otherLane <- seedOtherProvider (weStore env) 2 "p-stripe"
|
|
setSignals ref [("p-1", settledSignal), ("someone-elses-invoice", settledSignal), ("p-stripe", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) ours `shouldReturn` ISPaid
|
|
invoiceStatus (weStore env) otherLane `shouldReturn` ISOpen
|
|
invoiceCount (weStore env) `shouldReturn` 2
|
|
|
|
testProviderFailureLosesNothing :: IO ()
|
|
testProviderFailureLosesNothing = bounded "provider outage" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
setSignals ref [("p-1", settledSignal)]
|
|
failList ref (Just (ProviderError "connection refused"))
|
|
failRead ref (Just (ProviderError "connection refused"))
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
Just row <- getInvoice (weStore env) iid
|
|
irPayment row `shouldBe` Nothing
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
|
|
failList ref Nothing
|
|
failRead ref Nothing
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
stubCalls ref `shouldReturn` [StubRead "p-1", StubListOpen, StubRead "p-1"]
|
|
|
|
testCadenceFollowsTheWaiters :: IO ()
|
|
testCadenceFollowsTheWaiters = bounded "cadence" $ withStubPoller raceHold $ \_ poller env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let PollConfig {pWaitingSeconds, pIdleSeconds} = poll (weConfig env)
|
|
pWaitingSeconds `shouldNotBe` pIdleSeconds
|
|
waitingCount (weWaiters env) `shouldReturn` 0
|
|
passDelayNow poller `shouldReturn` (pIdleSeconds * 1000000)
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
threadDelay 100000
|
|
passDelayNow poller `shouldReturn` (pWaitingSeconds * 1000000)
|
|
waitingCount (weWaiters env) `shouldReturn` 1
|
|
markPaidAndPublish env iid
|
|
_ <- wait held
|
|
passDelayNow poller `shouldReturn` (pIdleSeconds * 1000000)
|
|
|
|
passDelayNow :: PollerEnv -> IO Int
|
|
passDelayNow PollerEnv {peWaiters, pePoll} = passDelay pePoll <$> waitingCount peWaiters
|
|
|
|
testHintsDoNotPostponeThePass :: IO ()
|
|
testHintsDoNotPostponeThePass = bounded "hints do not postpone the pass" $ withStubPoller raceHold $ \ref _ env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
mapM_ (\i -> seedOpenRef (weStore env) i (burstRef i) someExpiry) burstRefs
|
|
built <- newPollerEnv (weStore env) (weWaiters env) (weHints env) (weProviders env) PollConfig {pWaitingSeconds = 1, pIdleSeconds = 1}
|
|
let poller = built {peStrayEvery = 0}
|
|
setSignals ref [(burstRef i, settledSignal) | i <- burstRefs]
|
|
runOnePass poller
|
|
clearCalls ref
|
|
setReadDelay ref slowHintRead
|
|
mapM_ (\i -> queueReadHint (weHints env) (burstRef i) `shouldReturn` True) burstRefs
|
|
Async.withAsync (runPoller poller) $ \_ -> do
|
|
calls <- awaitCalls ref (\cs -> length (filter (== StubListOpen) cs) >= 2)
|
|
length (filter isRead calls) `shouldSatisfy` (< length burstRefs)
|
|
where
|
|
isRead = \case
|
|
StubRead _ -> True
|
|
_ -> False
|
|
|
|
burstRefs :: [Int]
|
|
burstRefs = [1 .. 10]
|
|
|
|
burstRef :: Int -> Text
|
|
burstRef i = "p-burst-" <> T.pack (show i)
|
|
|
|
slowHintRead :: Int
|
|
slowHintRead = 300000
|
|
|
|
awaitCalls :: IORef StubState -> ([StubCall] -> Bool) -> IO [StubCall]
|
|
awaitCalls ref p = do
|
|
calls <- stubCalls ref
|
|
if p calls then pure calls else threadDelay 10000 >> awaitCalls ref p
|
|
|
|
testWaiterCutsTheIdleSleepShort :: IO ()
|
|
testWaiterCutsTheIdleSleepShort = bounded "waiter cuts the sleep" $ withStubPoller raceHold $ \_ _ env client -> do
|
|
iid <- seedOpenInvoice env
|
|
poller <- newPollerEnv (weStore env) (weWaiters env) (weHints env) (weProviders env) PollConfig {pWaitingSeconds = 1, pIdleSeconds = 10}
|
|
started <- getCurrentTime
|
|
slept <- async (passDue poller >>= atomically)
|
|
threadDelay 200000
|
|
Async.poll slept >>= (`shouldSatisfy` isNothing)
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
wait slept
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
elapsed `shouldSatisfy` (< 5)
|
|
elapsed `shouldSatisfy` (>= 0.9)
|
|
markPaidAndPublish env iid
|
|
_ <- wait held
|
|
pure ()
|
|
|
|
testCadenceHasAFloor :: IO ()
|
|
testCadenceHasAFloor = do
|
|
let zeroed = PollConfig {pWaitingSeconds = 0, pIdleSeconds = 0}
|
|
negated = PollConfig {pWaitingSeconds = -5, pIdleSeconds = -60}
|
|
map (passDelay zeroed) [1, 0] `shouldBe` [1000000, 1000000]
|
|
map (passDelay negated) [1, 0] `shouldBe` [1000000, 1000000]
|
|
map (passDelay PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60}) [1, 0] `shouldBe` [3000000, 60000000]
|
|
|
|
testPollerWakesAHeldRequest :: IO ()
|
|
testPollerWakesAHeldRequest = bounded "poller wakes a hold" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
iid <- seedOpenInvoice env
|
|
setSignals ref [(niProviderRef sampleInvoice, settledSignal)]
|
|
_ <- wokenBy client iid (runOnePass poller) "paid"
|
|
pure ()
|
|
|
|
testSweepExpiresPastTheGrace :: IO ()
|
|
testSweepExpiresPastTheGrace = bounded "expiry sweep" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
overdue <- seedOpenRef (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
inGrace <- seedOpenRef (weStore env) 2 "p-ingrace" (addUTCTime (negate (expiryGrace - 60)) now)
|
|
ahead <- seedOpenRef (weStore env) 3 "p-ahead" (addUTCTime 3600 now)
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISExpired
|
|
invoiceStatus (weStore env) inGrace `shouldReturn` ISOpen
|
|
invoiceStatus (weStore env) ahead `shouldReturn` ISOpen
|
|
stubCalls ref `shouldReturn` [StubRead "p-overdue", StubRead "p-ingrace", StubRead "p-ahead", StubListOpen]
|
|
|
|
testSweepWritesStatusAlone :: IO ()
|
|
testSweepWritesStatusAlone = bounded "sweep writes status alone" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-1" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
Just row <- getInvoice (weStore env) iid
|
|
irPayment row `shouldBe` Nothing
|
|
setSignals ref [("p-1", SigClosed (rcv 200 (Just "0.00020000")))]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
p <- paymentRow (weStore env) iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 200)
|
|
ipCryptoPaid p `shouldBe` Just "0.00020000"
|
|
|
|
testSweepWakesAHeldRequest :: IO ()
|
|
testSweepWakesAHeldRequest = bounded "sweep wakes a hold" $ withStubPoller raceHold $ \_ poller env client -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
_ <- wokenBy client iid (runOnePass poller) "expired"
|
|
pure ()
|
|
|
|
withPayableStubPoller :: Int -> (IORef StubState -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withPayableStubPoller = withStubPollerOf (\ref -> (stubProvider ref) {pProvider = PPStripe})
|
|
|
|
-- | Creates an order older than 72 hours, which only the expiry sweep still looks at. A higher i is newer.
|
|
seedPastWindow :: HasCallStack => DBStore -> Int -> Text -> PaymentProvider -> IO InvoiceId
|
|
seedPastWindow st i providerRef provider = do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
let createdAt = addUTCTime (negate (settleWindow + 3600) + fromIntegral i) now
|
|
iid = InvoiceId ("inv-old-" <> T.pack (show i))
|
|
ni = sampleInvoice {niInvoiceId = iid, niProviderRef = providerRef, niProvider = provider, niCodeHash = digestFixture (fromIntegral i + 60), niCreatedAt = createdAt, niExpiresAt = addUTCTime 3600 createdAt}
|
|
createInvoiceRows st ni `shouldReturn` Right ()
|
|
pure iid
|
|
|
|
-- | Runs one pass to get the list call out of the way, so the next pass only does the expiry sweep.
|
|
passListing :: IORef StubState -> PollerEnv -> IO ()
|
|
passListing ref poller = runOnePass poller >> clearCalls ref
|
|
|
|
-- hDuplicateTo changes stderr's buffering, so put the original setting back.
|
|
capturingStderr :: IO () -> IO Text
|
|
capturingStderr action = do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-stderr" $ \dir -> do
|
|
let path = dir </> "stderr.log"
|
|
withFile path WriteMode $ \h -> do
|
|
buffering <- hGetBuffering stderr
|
|
saved <- hDuplicate stderr
|
|
(hDuplicateTo h stderr >> action) `E.finally` (hDuplicateTo saved stderr >> hClose saved >> hSetBuffering stderr buffering)
|
|
T.readFile path
|
|
|
|
loggedError :: Text -> Text -> Bool
|
|
loggedError message = any (\l -> "[ERROR " `T.isPrefixOf` l && message `T.isInfixOf` l) . T.lines
|
|
|
|
failCancels :: IORef StubState -> IO ()
|
|
failCancels ref = atomicModifyIORef' ref $ \s -> (s {ssCancelError = Just (ProviderError "refused")}, ())
|
|
|
|
testSweepCancelsBeforeExpiring :: IO ()
|
|
testSweepCancelsBeforeExpiring = bounded "sweep cancels" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
overdue <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
ahead <- seedOpenRefOf PPStripe (weStore env) 2 "p-ahead" (addUTCTime 3600 now)
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISExpired
|
|
invoiceStatus (weStore env) ahead `shouldReturn` ISOpen
|
|
stubCalls ref `shouldReturn` [StubRead "p-overdue", StubRead "p-ahead", StubListOpen, StubCancel "p-overdue"]
|
|
|
|
testSweepKeepsOpenWhenCancelFails :: IO ()
|
|
testSweepKeepsOpenWhenCancelFails = bounded "sweep cancel fails" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
failCancels ref
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
atomicModifyIORef' ref $ \s -> (s {ssCancelError = Nothing}, ())
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
filter (== StubCancel "p-overdue") <$> stubCalls ref `shouldReturn` [StubCancel "p-overdue", StubCancel "p-overdue"]
|
|
|
|
testSweepSettlesWhatItCannotCancel :: IO ()
|
|
testSweepSettlesWhatItCannotCancel = bounded "sweep settles uncancelled" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
passListing ref poller
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedPastWindow (weStore env) 1 "p-old" PPStripe
|
|
failCancels ref
|
|
setSignals ref [("p-old", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
stubCalls ref `shouldReturn` [StubCancel "p-old", StubRead "p-old"]
|
|
|
|
testSweepExpiresWhatAReadShowsCancelled :: IO ()
|
|
testSweepExpiresWhatAReadShowsCancelled = bounded "sweep reads a cancel" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
atomicModifyIORef' ref $ \s -> (s {ssCancelLost = True}, ())
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
stubCalls ref `shouldReturn` [StubRead "p-overdue", StubListOpen, StubCancel "p-overdue", StubRead "p-overdue"]
|
|
|
|
testSweepGivesUpPastTheWindow :: IO ()
|
|
testSweepGivesUpPastTheWindow = bounded "sweep gives up" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
passListing ref poller
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedPastWindow (weStore env) 1 "p-old" PPStripe
|
|
failCancels ref
|
|
firstLog <- capturingStderr (runOnePass poller >> runOnePass poller)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
firstLog `shouldNotSatisfy` T.isInfixOf "expired here only"
|
|
failedAnHourAgo poller "p-old"
|
|
lastLog <- capturingStderr (runOnePass poller)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
loggedError "invoice p-old could not be cancelled at the provider, so it was expired here only" lastLog `shouldBe` True
|
|
let attempt = [StubCancel "p-old", StubRead "p-old"]
|
|
stubCalls ref `shouldReturn` concat (replicate 3 attempt)
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` concat (replicate 3 attempt)
|
|
|
|
testSweepExpiresWithoutItsProvider :: IO ()
|
|
testSweepExpiresWithoutItsProvider = bounded "sweep without provider" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
passListing ref poller
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedPastWindow (weStore env) 1 "p-old" PPStripe
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
failedAnHourAgo poller "p-old"
|
|
logged <- capturingStderr (runOnePass poller)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
loggedError "no provider is configured for it" logged `shouldBe` True
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
testSweepKeepsFailuresBeyondTheCap :: IO ()
|
|
testSweepKeepsFailuresBeyondTheCap = bounded "sweep keeps failures past the cap" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
passListing ref poller
|
|
seedBadgePrice (weStore env) "price1"
|
|
let count = readsPerPass + 1
|
|
newest = "p-" <> T.pack (show count)
|
|
mapM_ (\i -> seedPastWindow (weStore env) i ("p-" <> T.pack (show i)) PPStripe) [1 .. count]
|
|
failCancels ref
|
|
failedAnHourAgo poller newest
|
|
runOnePass poller
|
|
stubCalls ref >>= (`shouldNotSatisfy` elem (StubCancel newest))
|
|
Map.member newest <$> readTVarIO (peCancelFailed poller) `shouldReturn` True
|
|
|
|
-- | Pretends the first cancel failure was an hour ago, so the test doesn't have to wait.
|
|
failedAnHourAgo :: PollerEnv -> Text -> IO ()
|
|
failedAnHourAgo PollerEnv {peCancelFailed} ref = do
|
|
now <- getCurrentTime
|
|
atomically $ modifyTVar' peCancelFailed (Map.insert ref (addUTCTime (negate cancelGiveUpDelay) now))
|
|
|
|
testSweepWarnsOncePerOrder :: IO ()
|
|
testSweepWarnsOncePerOrder = bounded "sweep warns once" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
failCancels ref
|
|
let warnings = Map.filterWithKey (\k _ -> "p-overdue" `T.isInfixOf` k) <$> readTVarIO (peSkipped poller)
|
|
runOnePass poller
|
|
first <- warnings
|
|
Map.size first `shouldBe` 1
|
|
runOnePass poller
|
|
warnings `shouldReturn` first
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
|
|
testSweepCapsCancelsPerPass :: IO ()
|
|
testSweepCapsCancelsPerPass = bounded "sweep caps cancels" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
let count = readsPerPass + 1
|
|
iids <- mapM (\i -> seedOpenRefOf PPStripe (weStore env) i ("p-" <> T.pack (show i)) (addUTCTime (negate (expiryGrace + 60)) now)) [1 .. count]
|
|
let cancels = length . filter isCancel <$> stubCalls ref
|
|
isCancel = \case
|
|
StubCancel _ -> True
|
|
_ -> False
|
|
expiredCount = length . filter (== ISExpired) <$> mapM (invoiceStatus (weStore env)) iids
|
|
runOnePass poller
|
|
cancels `shouldReturn` readsPerPass
|
|
expiredCount `shouldReturn` readsPerPass
|
|
runOnePass poller
|
|
cancels `shouldReturn` count
|
|
expiredCount `shouldReturn` count
|
|
|
|
testSkipWarningsAreRateLimited :: IO ()
|
|
testSkipWarningsAreRateLimited = bounded "skip warnings" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
let reason = "btcpay invoice SOMEONEELSESINVOICE: unknown status Frobnicated"
|
|
onwards t = addUTCTime t settleAt
|
|
dueToWarn poller settleAt reason `shouldReturn` True
|
|
dueToWarn poller (onwards 3) reason `shouldReturn` False
|
|
dueToWarn poller (onwards (skipWarnInterval - 1)) reason `shouldReturn` False
|
|
dueToWarn poller (onwards skipWarnInterval) reason `shouldReturn` True
|
|
dueToWarn poller (onwards skipWarnInterval) "btcpay invoice OTHER: unknown status Frobnicated" `shouldReturn` True
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
setSkipped ref [(Just "SOMEONEELSESINVOICE", reason)]
|
|
setSignals ref [("p-1", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
|
|
testSkipNamingOurInvoiceIsRaised :: IO ()
|
|
testSkipNamingOurInvoiceIsRaised = bounded "skip ownership" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 "p-ours" someExpiry
|
|
skipOwner poller PPCrypto (Just "p-ours") `shouldReturn` SkipOurs
|
|
skipOwner poller PPCrypto (Just "SOMEONEELSESINVOICE") `shouldReturn` SkipStranger
|
|
skipOwner poller PPCrypto Nothing `shouldReturn` SkipUnaccounted
|
|
_ <- seedOtherProvider (weStore env) 3 "p-stripe-skip"
|
|
skipOwner poller PPCrypto (Just "p-stripe-skip") `shouldReturn` SkipStranger
|
|
iid <- seedOpenRef (weStore env) 2 "p-2" someExpiry
|
|
setSkipped
|
|
ref
|
|
[ (Just "p-ours", "btcpay invoice p-ours: unknown status Frobnicated"),
|
|
(Just "SOMEONEELSESINVOICE", "btcpay invoice SOMEONEELSESINVOICE: unknown status Frobnicated")
|
|
]
|
|
setSignals ref [("p-2", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
|
|
testSkipReasonsStayBounded :: IO ()
|
|
testSkipReasonsStayBounded = bounded "skip reasons bounded" $ withStubPoller raceHold $ \_ 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
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISOpen
|
|
|
|
setSignals ref []
|
|
setSkipped ref [(Just "p-bad", "some reason the provider gave")]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISOpen
|
|
|
|
testSweepWaitsForAPassThatSawEverything :: IO ()
|
|
testSweepWaitsForAPassThatSawEverything = bounded "sweep guards" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
overdue <- seedOpenRef (weStore env) 1 "p-overdue" (addUTCTime (-3600) now)
|
|
let stillOpen :: Text -> IO ()
|
|
stillOpen why = do
|
|
runOnePass poller
|
|
(why, ) <$> invoiceStatus (weStore env) overdue `shouldReturn` (why, ISOpen)
|
|
failRead ref (Just (ProviderError "connection refused"))
|
|
stillOpen "the reads never answered"
|
|
failRead ref Nothing
|
|
mapM_ (\i -> seedOpenRef (weStore env) i ("p-bulk-" <> tshow i) someExpiry) [2 .. readsPerPass + 2]
|
|
setSkipped ref [(Just "p-overdue", "btcpay invoice p-overdue: unknown status Frobnicated")]
|
|
stillOpen "it answered and left one of ours unread"
|
|
setSkipped ref [(Nothing, "btcpay: the list stopped at 50 pages")]
|
|
stillOpen "it stopped early without saying whose invoices it missed"
|
|
setSkipped ref []
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISExpired
|
|
|
|
testListPaginates :: IO ()
|
|
testListPaginates = bounded "paging" $ withFakeProvider $ \fake p -> do
|
|
refs <- replicateM (listPageSize + 1) (piProviderRef <$> createdAtFake p)
|
|
case reverse refs of
|
|
[] -> failWith "no invoices were created"
|
|
(onSecondPage : _) -> do
|
|
setInvoiceState fake onSecondPage ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)]
|
|
pListOpen p >>= \case
|
|
Left e -> failWith ("expected a list, got " <> show e)
|
|
Right ListPass {lpMoved} -> map fst lpMoved `shouldSatisfy` elem onSecondPage
|
|
gets <- apiRequests fake "GET" ["invoices"]
|
|
let pageOf FakeRequest {frQuery} = (join (lookup "take" frQuery), join (lookup "skip" frQuery))
|
|
size = BC.pack (show listPageSize)
|
|
map pageOf gets `shouldBe` [(Just size, Just "0"), (Just size, Just size)]
|
|
|
|
testPagingStopsAtTheCeiling :: IO ()
|
|
testPagingStopsAtTheCeiling = bounded "paging ceiling" $ withFakeProvider $ \fake p -> do
|
|
ignoreListPaging fake
|
|
replicateM_ listPageSize (void (createdAtFake p))
|
|
r <- pListOpen p
|
|
gets <- apiRequests fake "GET" ["invoices"]
|
|
length gets `shouldBe` maxListPages
|
|
case r of
|
|
Left e -> failWith ("expected a list, got " <> show e)
|
|
Right ListPass {lpSkipped} -> do
|
|
map snd lpSkipped `shouldSatisfy` any (T.isInfixOf "stopped at")
|
|
map snd lpSkipped `shouldSatisfy` any (T.isInfixOf (T.pack (show (maxListPages * listPageSize))))
|
|
map fst lpSkipped `shouldSatisfy` all isNothing
|
|
|
|
createdAtFake :: HasCallStack => Provider -> IO ProviderInvoice
|
|
createdAtFake p =
|
|
pCreateInvoice p (SPMCrypto CCBtc) sampleDraft >>= \case
|
|
Right inv -> pure inv
|
|
Left e -> failWith ("expected an invoice at the fake, got " <> show e)
|
|
|
|
webhookPath :: String
|
|
webhookPath = "/webhooks/btcpay"
|
|
|
|
hookRef :: Text
|
|
hookRef = "p-hooked"
|
|
|
|
hookedEvent :: LB.ByteString
|
|
hookedEvent = webhookEvent "InvoiceSettled" hookRef
|
|
|
|
someSig :: [Header]
|
|
someSig = webhookSigHeader "not-the-secret" hookedEvent
|
|
|
|
postWebhook :: WebClient -> [Header] -> LB.ByteString -> IO (Response LB.ByteString)
|
|
postWebhook client hdrs = webRequestBody client "POST" webhookPath hdrs
|
|
|
|
slowProviderRead :: Int
|
|
slowProviderRead = 1000000
|
|
|
|
testWebhookVerifiesARealSignature :: IO ()
|
|
testWebhookVerifiesARealSignature = bounded "real signature" $ withFakePoller $ \fake poller env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "xmr" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
iid <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) iid
|
|
let secret = bWebhookSecret (fbConfig fake)
|
|
body = webhookEvent "InvoiceSettled" (irProviderRef row)
|
|
delivered <- postWebhook client (webhookSigHeader secret body) body
|
|
statusOf delivered `shouldBe` 200
|
|
responseBody delivered `shouldBe` ""
|
|
tampered <- postWebhook client (webhookSigHeader secret body) (body <> " ")
|
|
statusOf tampered `shouldBe` 400
|
|
responseBody tampered `shouldBe` ""
|
|
unsigned <- postWebhook client [] body
|
|
statusOf unsigned `shouldBe` 400
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
setInvoiceState fake (irProviderRef row) ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.32095000" :: Text)]
|
|
drainHints poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
|
|
|
|
testWebhookPassesTheRawBytes :: IO ()
|
|
testWebhookPassesTheRawBytes = bounded "raw bytes" $ withStubPoller raceHold $ \ref _ env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
let hdrs = webhookSigHeader "any-secret" hookedEvent
|
|
r <- postWebhook client hdrs hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
stubWebhooks ref >>= \case
|
|
[(seenHdrs, seenBody)] -> do
|
|
seenBody `shouldBe` LB.toStrict hookedEvent
|
|
lookup "BTCPay-Sig" seenHdrs `shouldBe` lookup "BTCPay-Sig" hdrs
|
|
other -> failWith ("expected one verify call, got " <> show (length other))
|
|
case J.decode hookedEvent :: Maybe J.Value of
|
|
Nothing -> failWith "the event body is not JSON"
|
|
Just parsed -> J.encode parsed `shouldSatisfy` (/= hookedEvent)
|
|
|
|
testWebhookQueuesARead :: IO ()
|
|
testWebhookQueuesARead = bounded "webhook queues" $ withStubPoller raceHold $ \ref _ env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
responseBody r `shouldBe` ""
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
Just row <- getInvoice (weStore env) iid
|
|
irPayment row `shouldBe` Nothing
|
|
|
|
testWebhookSettlesByThePollerPath :: IO ()
|
|
testWebhookSettlesByThePollerPath = bounded "one settlement lane" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
hinted <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
listed <- seedOpenRef (weStore env) 2 "p-listed" someExpiry
|
|
setSignals ref [(hookRef, settledSignal), ("p-listed", settledSignal)]
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
invoiceStatus (weStore env) hinted `shouldReturn` ISOpen
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` [StubRead hookRef]
|
|
invoiceStatus (weStore env) hinted `shouldReturn` ISPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) hinted `shouldReturn` CPSPaid
|
|
ipStatus <$> paymentRow (weStore env) hinted `shouldReturn` "settled"
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) listed `shouldReturn` ISPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) listed `shouldReturn` CPSPaid
|
|
ipStatus <$> paymentRow (weStore env) listed `shouldReturn` "settled"
|
|
|
|
testWebhookDoesNotWaitOnTheProvider :: IO ()
|
|
testWebhookDoesNotWaitOnTheProvider = bounded "webhook does not wait" $ withStubPoller raceHold $ \ref _ env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setSignals ref [(hookRef, settledSignal)]
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
setReadDelay ref slowProviderRead
|
|
started <- getCurrentTime
|
|
r <- postWebhook client someSig hookedEvent
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
statusOf r `shouldBe` 200
|
|
elapsed `shouldSatisfy` (< 0.5)
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
testWebhookRefusesASignature :: IO ()
|
|
testWebhookRefusesASignature = bounded "webhook refuses" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setSignals ref [(hookRef, settledSignal)]
|
|
setVerifyResult ref (Left (WebhookError "BTCPay-Sig does not verify"))
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 400
|
|
responseBody r `shouldBe` ""
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
|
|
testWebhookIgnoresWhatItCannotActOn :: IO ()
|
|
testWebhookIgnoresWhatItCannotActOn = bounded "webhook ignores" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
ours <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
otherLane <- seedOtherProvider (weStore env) 2 "p-stripe"
|
|
setSignals ref [(hookRef, settledSignal), ("p-stripe", settledSignal)]
|
|
setVerifyResult ref (Right Nothing)
|
|
unhandled <- postWebhook client someSig (webhookEvent "InvoiceReceivedPayment" hookRef)
|
|
statusOf unhandled `shouldBe` 200
|
|
responseBody unhandled `shouldBe` ""
|
|
setVerifyResult ref (Right (Just "p-no-such-invoice"))
|
|
unknown <- postWebhook client someSig (webhookEvent "InvoiceSettled" "p-no-such-invoice")
|
|
statusOf unknown `shouldBe` 200
|
|
responseBody unknown `shouldBe` ""
|
|
setVerifyResult ref (Right (Just "p-stripe"))
|
|
crossed <- postWebhook client someSig (webhookEvent "InvoiceSettled" "p-stripe")
|
|
statusOf crossed `shouldBe` 200
|
|
responseBody crossed `shouldBe` ""
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceStatus (weStore env) ours `shouldReturn` ISOpen
|
|
invoiceStatus (weStore env) otherLane `shouldReturn` ISOpen
|
|
|
|
testWebhookRefusesAnOversizedBody :: IO ()
|
|
testWebhookRefusesAnOversizedBody = bounded "webhook body cap" $ withStubPoller raceHold $ \ref _ _ client -> do
|
|
setVerifyResult ref (Left (WebhookError "BTCPay-Sig does not verify"))
|
|
atCap <- postWebhook client someSig (LB.replicate (fromIntegral maxWebhookBytes) 'x')
|
|
statusOf atCap `shouldBe` 400
|
|
length <$> stubWebhooks ref `shouldReturn` 1
|
|
over <- postWebhook client someSig (LB.replicate (fromIntegral maxWebhookBytes + 1) 'x')
|
|
statusOf over `shouldBe` 413
|
|
responseBody over `shouldBe` ""
|
|
length <$> stubWebhooks ref `shouldReturn` 1
|
|
|
|
testReadHintQueuedOnce :: IO ()
|
|
testReadHintQueuedOnce = bounded "hint queued once" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
replicateM_ 5 (queueReadHint (weHints env) hookRef `shouldReturn` True)
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` [StubRead hookRef]
|
|
queueReadHint (weHints env) hookRef `shouldReturn` True
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` [StubRead hookRef, StubRead hookRef]
|
|
|
|
testWebhookDropsAHintWhenFull :: IO ()
|
|
testWebhookDropsAHintWhenFull = bounded "full hint queue" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setSignals ref [(hookRef, settledSignal)]
|
|
let fillers = ["p-filler-" <> T.pack (show i) | i <- [1 .. hintQueueSize]]
|
|
mapM (queueReadHint (weHints env)) fillers `shouldReturn` map (const True) fillers
|
|
queueReadHint (weHints env) "p-one-more" `shouldReturn` False
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
responseBody r `shouldBe` ""
|
|
drainHints poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
|
|
testWebhookNeverAnswers5xx :: IO ()
|
|
testWebhookNeverAnswers5xx = bounded "webhook never 5xx" $ withStubPoller raceHold $ \ref _ env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setVerifyThrows ref True
|
|
threw <- postWebhook client someSig hookedEvent
|
|
statusOf threw `shouldBe` 200
|
|
responseBody threw `shouldBe` ""
|
|
setVerifyThrows ref False
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
breakStore (weStore env)
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
responseBody r `shouldBe` ""
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
paidInFull, paidInPart :: Text
|
|
paidInFull = "0.00050000"
|
|
paidInPart = "0.00020000"
|
|
|
|
fullyPaid, partlyPaid :: J.Value
|
|
fullyPaid = J.Number 5400
|
|
partlyPaid = J.Number 2160
|
|
|
|
buyBadge :: HasCallStack => WebEnv -> WebClient -> Int -> Text -> IO (InvoiceId, Text)
|
|
buyBadge env client i code = do
|
|
r <- postCreateAs client i (createBody supporterPriceId Nothing "btc" (codeHashText code))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
iid <- InvoiceId <$> stringField o "invoiceId"
|
|
getInvoice (weStore env) iid >>= \case
|
|
Just InvoiceRow {irProviderRef} -> pure (iid, irProviderRef)
|
|
Nothing -> failWith "the create answered 200 and wrote no invoice row"
|
|
|
|
atProvider :: FakeBTCPay -> Text -> Text -> Text -> Text -> IO ()
|
|
atProvider fake ref status additional paid =
|
|
atProviderDue fake ref status additional paid (if paid == paidInFull then "0.00000000" else dueAfterPart)
|
|
|
|
atProviderDue :: FakeBTCPay -> Text -> Text -> Text -> Text -> Text -> IO ()
|
|
atProviderDue fake ref status additional paid due =
|
|
setInvoiceState fake ref ["status" .= status, "additionalStatus" .= additional, "paymentMethodPaid" .= paid, "due" .= due]
|
|
|
|
dueAfterPart :: Text
|
|
dueAfterPart = "0.00030500"
|
|
|
|
viewInvoice :: HasCallStack => WebClient -> InvoiceId -> IO J.Object
|
|
viewInvoice client iid = do
|
|
r <- webGet client (invoicePath iid)
|
|
statusOf r `shouldBe` 200
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
jsonObject r
|
|
|
|
scenarioPaidPurchase :: IO ()
|
|
scenarioPaidPurchase = bounded "scenario: paid purchase" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
unpaid <- viewInvoice client iid
|
|
fieldOf unpaid "status" `shouldBe` Just (J.String "open")
|
|
fieldOf unpaid "amountPaid" `shouldBe` Nothing
|
|
fieldOf unpaid "cryptoAmountPaid" `shouldBe` Nothing
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
runOnePass poller
|
|
paid <- viewInvoice client iid
|
|
fieldOf paid "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf paid "amountPaid" `shouldBe` Just fullyPaid
|
|
fieldOf paid "cryptoAmountPaid" `shouldBe` Just (J.String paidInFull)
|
|
fieldOf paid "settledAt" `shouldSatisfy` isJust
|
|
p <- paymentRow (weStore env) iid
|
|
ipStatus p `shouldBe` "settled"
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime (ipUpdatedAt p))
|
|
|
|
scenarioHeldWaitWakes :: IO ()
|
|
scenarioHeldWaitWakes = bounded "scenario: held wait" $ withFakePollerHolding raceHold $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
threadDelay 100000
|
|
Async.poll held >>= \parked -> parked `shouldSatisfy` isNothing
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
settling <- getCurrentTime
|
|
runOnePass poller
|
|
r <- wait held
|
|
elapsed <- (`diffUTCTime` settling) <$> getCurrentTime
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf o "amountPaid" `shouldBe` Just fullyPaid
|
|
elapsed `shouldSatisfy` (< 1)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
|
|
scenarioPartPaymentIsReported :: IO ()
|
|
scenarioPartPaymentIsReported = bounded "scenario: part paid" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "New" "PaidPartial" paidInPart
|
|
runOnePass poller
|
|
o <- viewInvoice client iid
|
|
fieldOf o "status" `shouldBe` Just (J.String "open")
|
|
fieldOf o "amountPaid" `shouldBe` Just partlyPaid
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String paidInPart)
|
|
-- The due figure is the provider's own, which includes the network fee a partial payment adds,
|
|
-- so it is 0.00030500 rather than the 0.00030000 a subtraction would give.
|
|
fieldOf o "cryptoAmountDue" `shouldBe` Just (J.String dueAfterPart)
|
|
fieldOf o "settledAt" `shouldBe` Nothing
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "pending"
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSUnpaid
|
|
bcExpiresAt code `shouldBe` Nothing
|
|
|
|
scenarioExpiryReportsWhatArrived :: IO ()
|
|
scenarioExpiryReportsWhatArrived = bounded "scenario: expired part paid" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Expired" "PaidPartial" paidInPart
|
|
runOnePass poller
|
|
o <- viewInvoice client iid
|
|
fieldOf o "status" `shouldBe` Just (J.String "expired")
|
|
fieldOf o "amountPaid" `shouldBe` Just partlyPaid
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String paidInPart)
|
|
fieldOf o "settledAt" `shouldBe` Nothing
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "pending"
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSUnpaid
|
|
bcExpiresAt code `shouldBe` Nothing
|
|
|
|
scenarioLateSettlement :: IO ()
|
|
scenarioLateSettlement = bounded "scenario: late settlement" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Expired" "PaidPartial" paidInPart
|
|
runOnePass poller
|
|
expired <- viewInvoice client iid
|
|
fieldOf expired "status" `shouldBe` Just (J.String "expired")
|
|
fieldOf expired "amountPaid" `shouldBe` Just partlyPaid
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
|
|
atProvider fake ref "Settled" "PaidLate" paidInFull
|
|
runOnePass poller
|
|
paid <- viewInvoice client iid
|
|
fieldOf paid "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf paid "amountPaid" `shouldBe` Just fullyPaid
|
|
fieldOf paid "cryptoAmountPaid" `shouldBe` Just (J.String paidInFull)
|
|
fieldOf paid "settledAt" `shouldSatisfy` isJust
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
p <- paymentRow (weStore env) iid
|
|
ipStatus p `shouldBe` "settled"
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime (ipUpdatedAt p))
|
|
|
|
scenarioReplayChangesNothing :: IO ()
|
|
scenarioReplayChangesNothing = bounded "scenario: replay" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
runOnePass poller
|
|
settled <- viewInvoice client iid
|
|
fieldOf settled "status" `shouldBe` Just (J.String "paid")
|
|
firstPayment <- paymentRow (weStore env) iid
|
|
firstCode <- settledCode (weStore env) iid
|
|
length <$> paymentIdentity (weStore env) iid `shouldReturn` 1
|
|
runOnePass poller
|
|
length <$> apiRequests fake "GET" ["invoices"] `shouldReturn` 1
|
|
length <$> paymentIdentity (weStore env) iid `shouldReturn` 1
|
|
paymentRow (weStore env) iid `shouldReturn` firstPayment
|
|
settledCode (weStore env) iid `shouldReturn` firstCode
|
|
viewInvoice client iid `shouldReturn` settled
|
|
|
|
scenarioInvalidClosesAsExpired :: IO ()
|
|
scenarioInvalidClosesAsExpired = bounded "scenario: invoice invalid" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Invalid" "None" paidInPart
|
|
let body = webhookEvent "InvoiceInvalid" ref
|
|
delivered <- postWebhook client (webhookSigHeader (bWebhookSecret (fbConfig fake)) body) body
|
|
statusOf delivered `shouldBe` 200
|
|
responseBody delivered `shouldBe` ""
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
drainHints poller
|
|
o <- viewInvoice client iid
|
|
fieldOf o "status" `shouldBe` Just (J.String "expired")
|
|
fieldOf o "amountPaid" `shouldBe` Just partlyPaid
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String paidInPart)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
|
|
detailReads <- apiRequests fake "GET" ["invoices", ref]
|
|
length detailReads `shouldBe` 1
|
|
|
|
scenarioCodeConflictCreatesNothing :: IO ()
|
|
scenarioCodeConflictCreatesNothing = bounded "scenario: code conflict" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
fakeInvoiceIds fake `shouldReturn` [ref]
|
|
again <- postCreateAs client 2 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf again `shouldBe` 409
|
|
responseBody again `shouldBe` errorBody "code_conflict"
|
|
fakeInvoiceIds fake `shouldReturn` [ref]
|
|
invoiceCount (weStore env) `shouldReturn` 1
|
|
(_, otherRef) <- buyBadge env client 3 (sampleCode <> "2")
|
|
otherRef `shouldSatisfy` (/= ref)
|
|
fakeInvoiceIds fake `shouldReturn` sort [ref, otherRef]
|
|
invoiceCount (weStore env) `shouldReturn` 2
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
runOnePass poller
|
|
paid <- viewInvoice client iid
|
|
fieldOf paid "status" `shouldBe` Just (J.String "paid")
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
|
|
|
|
scenarioNoWebhookAnywhere :: IO ()
|
|
scenarioNoWebhookAnywhere = bounded "scenario: no webhook" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
drainHints poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
runOnePass poller
|
|
paid <- viewInvoice client iid
|
|
fieldOf paid "status" `shouldBe` Just (J.String "paid")
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
|
|
byId <- apiRequests fake "GET" ["invoices", ref]
|
|
byId `shouldSatisfy` (not . null)
|
|
|
|
cancelPath :: InvoiceId -> String
|
|
cancelPath iid = invoicePath iid <> "/cancel"
|
|
|
|
webPost :: WebClient -> String -> IO (Response LB.ByteString)
|
|
webPost client target = webRequest client "POST" target []
|
|
|
|
withCancel :: (IORef StubState -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withCancel action = withCheckout $ \ref env client -> do
|
|
_ <- seedOpenInvoice env
|
|
action ref env client
|
|
|
|
testCancelClosesTheInvoiceAtBothEnds :: IO ()
|
|
testCancelClosesTheInvoiceAtBothEnds = bounded "cancel" $ withCancel $ \ref _ client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
r <- webPost client (cancelPath iid)
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "expired")
|
|
stubCalls ref `shouldReturn` [StubCancel (niProviderRef sampleInvoice)]
|
|
reread <- webGet client (invoicePath iid)
|
|
ao <- jsonObject reread
|
|
fieldOf ao "status" `shouldBe` Just (J.String "expired")
|
|
|
|
testCancelWakesAHeldRequest :: IO ()
|
|
testCancelWakesAHeldRequest = bounded "cancel wakes a hold" $ withCancel $ \_ _ client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
_ <- wokenBy client iid (void (webPost client (cancelPath iid))) "expired"
|
|
pure ()
|
|
|
|
testCancelIsRefusedOnceItIsNotOpen :: IO ()
|
|
testCancelIsRefusedOnceItIsNotOpen = bounded "cancel not open" $ withCancel $ \ref env client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
markPaid (weStore env) iid
|
|
r <- webPost client (cancelPath iid)
|
|
statusOf r `shouldBe` 409
|
|
responseBody r `shouldBe` errorBody "not_open"
|
|
stubCalls ref `shouldReturn` []
|
|
reread <- webGet client (invoicePath iid)
|
|
ao <- jsonObject reread
|
|
fieldOf ao "status" `shouldBe` Just (J.String "paid")
|
|
|
|
testCancelLeavesTheInvoiceOpenWhenTheProviderFails :: IO ()
|
|
testCancelLeavesTheInvoiceOpenWhenTheProviderFails = bounded "cancel provider down" $ withCancel $ \ref _ client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
atomicModifyIORef' ref $ \s -> (s {ssCancelError = Just (ProviderError "boom")}, ())
|
|
r <- webPost client (cancelPath iid)
|
|
statusOf r `shouldBe` 503
|
|
reread <- webGet client (invoicePath iid)
|
|
ao <- jsonObject reread
|
|
fieldOf ao "status" `shouldBe` Just (J.String "open")
|
|
|
|
testCancelIsOpaqueForAnUnknownInvoice :: IO ()
|
|
testCancelIsOpaqueForAnUnknownInvoice = bounded "cancel unknown" $ withCancel $ \ref _ client -> do
|
|
r <- webPost client "/api/invoice/no-such-invoice/cancel"
|
|
statusOf r `shouldBe` 404
|
|
responseBody r `shouldBe` notFoundBody
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
testCancelRefusesOtherMethods :: IO ()
|
|
testCancelRefusesOtherMethods = bounded "cancel verb" $ withCancel $ \_ _ client -> do
|
|
r <- webGet client (cancelPath (niInvoiceId sampleInvoice))
|
|
statusOf r `shouldBe` 405
|
|
headerOf r "Allow" `shouldBe` Just "POST"
|
|
|
|
testExpireOverdueSparesAFundedInvoice :: IO ()
|
|
testExpireOverdueSparesAFundedInvoice = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let pastExpiry = addUTCTime (-3600) now
|
|
funded = sampleInvoice {niExpiresAt = pastExpiry}
|
|
empty' = sampleInvoice {niInvoiceId = InvoiceId "inv-empty", niProviderRef = "p-empty", niCodeHash = digestFixture 15, niExpiresAt = pastExpiry}
|
|
createInvoiceRows st funded `shouldReturn` Right ()
|
|
createInvoiceRows st empty' `shouldReturn` Right ()
|
|
settle st (niInvoiceId funded) (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) now `shouldReturn` Right ISOpen
|
|
moved <- expireAllOverdue st now
|
|
moved `shouldBe` [niInvoiceId empty']
|
|
Just fundedRow <- getInvoice st (niInvoiceId funded)
|
|
irStatus fundedRow `shouldBe` ISOpen
|
|
settle st (niInvoiceId funded) (SigSettled (rcv 500 (Just "0.00050000")) now) now `shouldReturn` Right ISPaid
|
|
|
|
testCancelExpiresAFundedInvoice :: IO ()
|
|
testCancelExpiresAFundedInvoice = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let iid = niInvoiceId sampleInvoice
|
|
createInvoiceRows st sampleInvoice `shouldReturn` Right ()
|
|
settle st iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) now `shouldReturn` Right ISOpen
|
|
cancelOpenInvoice st iid now `shouldReturn` True
|
|
Just row <- getInvoice st iid
|
|
irStatus row `shouldBe` ISExpired
|
|
(ipCryptoPaid <$> irPayment row) `shouldBe` Just (Just "0.00050000")
|
|
|
|
testCancelIsRefusedOnceItIsFunded :: IO ()
|
|
testCancelIsRefusedOnceItIsFunded = bounded "cancel funded" $ withCancel $ \ref env client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
settle (weStore env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated `shouldReturn` Right ISOpen
|
|
r <- webPost client (cancelPath iid)
|
|
statusOf r `shouldBe` 409
|
|
responseBody r `shouldBe` errorBody "funded"
|
|
stubCalls ref `shouldReturn` []
|
|
reread <- webGet client (invoicePath iid)
|
|
ao <- jsonObject reread
|
|
fieldOf ao "status" `shouldBe` Just (J.String "open")
|
|
|
|
testViewNamesTheConfirmationsSettlementNeeds :: IO ()
|
|
testViewNamesTheConfirmationsSettlementNeeds = bounded "required confirmations" $ withCancel $ \_ _ client -> do
|
|
r <- webGet client (invoicePath (niInvoiceId sampleInvoice))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
-- MediumSpeed is BTCPay's one-confirmation policy, so settlement needs one confirmation.
|
|
fieldOf o "requiredConfirmations" `shouldBe` Just (J.Number 1)
|
|
|
|
testViewOmitsConfirmationsWithoutBTCPay :: IO ()
|
|
testViewOmitsConfirmationsWithoutBTCPay = bounded "no confirmations" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
r <- webGet client (invoicePath iid)
|
|
o <- jsonObject r
|
|
fieldOf o "requiredConfirmations" `shouldBe` Nothing
|
|
|
|
testHeldWaitWakesOnAPaymentThatDoesNotSettle :: IO ()
|
|
testHeldWaitWakesOnAPaymentThatDoesNotSettle = bounded "funded wakes a hold" $ withCheckout $ \_ env client -> do
|
|
iid <- seedOpenInvoice env
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
threadDelay 100000
|
|
waitingCount (weWaiters env) `shouldReturn` 1
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated
|
|
`shouldReturn` Right ISOpen
|
|
r <- wait held
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "open")
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String "0.00050000")
|
|
|
|
testARepeatedSignalDoesNotWakeAHold :: IO ()
|
|
testARepeatedSignalDoesNotWakeAHold = bounded "repeat signal" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let funded = SigFunded (rcv 500 (Just "0.00050000")) PaidInPart
|
|
settleOrder (weStore env) (weWaiters env) iid funded settleAt `shouldReturn` Right ISOpen
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open&seenPaid=0.00050000&seenFull=0")
|
|
threadDelay holdParkDelay
|
|
Async.poll held >>= (`shouldSatisfy` isNothing)
|
|
|
|
settleOrder (weStore env) (weWaiters env) iid funded settleAt `shouldReturn` Right ISOpen
|
|
threadDelay holdParkDelay
|
|
stillParked <- Async.poll held
|
|
stillParked `shouldSatisfy` isNothing
|
|
|
|
settleOrder (weStore env) (weWaiters env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) settleAt
|
|
`shouldReturn` Right ISPaid
|
|
r <- wait held
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
|
|
testHeldWaitIsNotWokenByAPassThatWroteNothing :: IO ()
|
|
testHeldWaitIsNotWokenByAPassThatWroteNothing = bounded "no churn" $ withCheckout $ \_ env _ -> do
|
|
iid <- seedOpenInvoice env
|
|
markPaid (weStore env) iid
|
|
waitingBefore <- waitingCount (weWaiters env)
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated
|
|
`shouldReturn` Right ISPaid
|
|
waitingAfter <- waitingCount (weWaiters env)
|
|
waitingAfter `shouldBe` waitingBefore
|
|
|
|
testViewCarriesTheProvidersPaidVerdict :: IO ()
|
|
testViewCarriesTheProvidersPaidVerdict = bounded "paid in full" $ withCheckout $ \_ env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 400 (Just "0.00040000")) PaidInFull) someCreated
|
|
`shouldReturn` Right ISOpen
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "status" `shouldBe` Just (J.String "open")
|
|
fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)
|
|
fieldOf o "amountPaid" `shouldBe` Just (J.Number 400)
|
|
|
|
testPaidVerdictIsNotWithdrawnByALaterRead :: IO ()
|
|
testPaidVerdictIsNotWithdrawnByALaterRead = bounded "verdict sticks" $ withCheckout $ \_ env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInFull) someCreated
|
|
`shouldReturn` Right ISOpen
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated
|
|
`shouldReturn` Right ISOpen
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)
|
|
|
|
testExpireOverdueSparesAZeroAmount :: IO ()
|
|
testExpireOverdueSparesAZeroAmount = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let pastExpiry = addUTCTime (-3600) now
|
|
dust = sampleInvoice {niExpiresAt = pastExpiry}
|
|
verdict = sampleInvoice {niInvoiceId = InvoiceId "inv-verdict", niProviderRef = "p-verdict", niCodeHash = digestFixture 16, niExpiresAt = pastExpiry}
|
|
createInvoiceRows st dust `shouldReturn` Right ()
|
|
createInvoiceRows st verdict `shouldReturn` Right ()
|
|
settle st (niInvoiceId dust) (SigFunded (rcv 0 (Just "0.00000001")) PaidInPart) now `shouldReturn` Right ISOpen
|
|
settle st (niInvoiceId verdict) (SigFunded (rcv 0 Nothing) PaidInFull) now `shouldReturn` Right ISOpen
|
|
expireAllOverdue st now `shouldReturn` []
|
|
mapM_ (\iid ->
|
|
getInvoice st iid >>= \case
|
|
Just InvoiceRow {irStatus, irPayment} -> do
|
|
irStatus `shouldBe` ISOpen
|
|
maybe False paymentHolds irPayment `shouldBe` True
|
|
Nothing -> failWith "the invoice went missing") [niInvoiceId dust, niInvoiceId verdict]
|