From 14ac945fb975b5cc4ec075b592aa5c47d0e86ad7 Mon Sep 17 00:00:00 2001 From: shum Date: Tue, 27 Oct 2026 08:58:08 +0000 Subject: [PATCH] store: clamp due and report closed paidInFull --- apps/simplex-store-service/README.md | 5 + .../src/StoreService/Orders.hs | 4 +- .../src/StoreService/Poller.hs | 2 +- .../src/StoreService/Providers.hs | 3 +- .../src/StoreService/Providers/BTCPay.hs | 35 ++++--- .../src/StoreService/Providers/Stripe.hs | 3 +- tests/Bots/StoreService/BTCPayTests.hs | 54 +++++++++-- tests/Bots/StoreService/NamesBalancesTests.hs | 4 +- .../Bots/StoreService/NamesLateCreditTests.hs | 94 +++++++++---------- tests/Bots/StoreService/NamesOrdersTests.hs | 10 +- tests/Bots/StoreService/StripeTests.hs | 9 +- tests/Bots/StoreService/WebTests.hs | 28 ++++-- 12 files changed, 159 insertions(+), 92 deletions(-) diff --git a/apps/simplex-store-service/README.md b/apps/simplex-store-service/README.md index 2d9a9400f5..2a61f95efd 100644 --- a/apps/simplex-store-service/README.md +++ b/apps/simplex-store-service/README.md @@ -166,6 +166,11 @@ that arrived under `HighSpeed`. With `MediumSpeed` (the template's value) or a s bitcoin is credited to the order's balance once confirmed, at the lower of the invoice's rate and the rate when it is credited. +BTCPay keeps an invoice it has closed `Expired` (or `Invalid` after a cancel) when money arrives late. +The invoice view reports `paidInFull` on such an invoice once BTCPay reads it `PaidLate` or +`PaidOver`, or its due is 0 or less, and reports an overpaid invoice's `cryptoAmountDue` as `0`, +never below. + **Set the Monero plugin's settled-confirmation threshold (`InvoiceSettledConfirmationThreshold`) to at least 1.** BTCPay's API does not show how many confirmations a Monero payment has, only that threshold, so late Monero is credited only on an invoice made while it was 1 or more; it is then diff --git a/apps/simplex-store-service/src/StoreService/Orders.hs b/apps/simplex-store-service/src/StoreService/Orders.hs index 9b38468d58..452202599c 100644 --- a/apps/simplex-store-service/src/StoreService/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Orders.hs @@ -61,13 +61,13 @@ paidInFull :: PaymentSignal -> Bool paidInFull = \case SigFunded _ f -> f == PaidInFull SigSettled {} -> True - SigClosed {} -> False + SigClosed _ f -> f == PaidInFull received :: PaymentSignal -> Received received = \case SigFunded r _ -> r SigSettled r _ -> r - SigClosed r -> r + SigClosed r _ -> r -- | Uses the provider's settlement instant, not now, so an outage does not push deadlines out; -- an implausible value (zero, milliseconds, negative) falls back to now. diff --git a/apps/simplex-store-service/src/StoreService/Poller.hs b/apps/simplex-store-service/src/StoreService/Poller.hs index e76e6b0733..f447e1e87a 100644 --- a/apps/simplex-store-service/src/StoreService/Poller.hs +++ b/apps/simplex-store-service/src/StoreService/Poller.hs @@ -252,7 +252,7 @@ settleMoved env@PollerEnv {peStore, peWaiters, pePhases, peProviders} provider n reportSettled sold before after -- checked before the no-change case, so a refund still alerts when money lands after expiry; -- a name order's late payment is credited to its balance instead - | IPBadge {} <- sold, after == ISExpired, SigClosed Received {rcvCrypto = Just paid} <- signal = do + | IPBadge {} <- sold, after == ISExpired, SigClosed Received {rcvCrypto = Just paid} _ <- signal = do let alert = "badge poller: order " <> ref <> " expired holding " <> paid <> ", which needs a refund" due <- dueToWarn env now alert when due $ logError alert diff --git a/apps/simplex-store-service/src/StoreService/Providers.hs b/apps/simplex-store-service/src/StoreService/Providers.hs index 0d533c7d73..d7f5183d1c 100644 --- a/apps/simplex-store-service/src/StoreService/Providers.hs +++ b/apps/simplex-store-service/src/StoreService/Providers.hs @@ -78,10 +78,11 @@ unitName = \case data Funded = PaidInFull | PaidInPart deriving (Eq, Show) +-- | A closed invoice's Funded says whether the whole amount reached it, late or not. data PaymentSignal = SigFunded Received Funded | SigSettled Received UTCTime - | SigClosed Received + | SigClosed Received Funded deriving (Eq, Show) data ProviderInvoice = ProviderInvoice diff --git a/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs b/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs index e0bf1273a3..5ae3cbb07f 100644 --- a/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs +++ b/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs @@ -107,6 +107,10 @@ knownMethodIds = map fst methodCurrencies confirmingPolicies :: [SpeedPolicy] confirmingPolicies = [MediumSpeed, LowMediumSpeed, LowSpeed] +-- | BTCPay's additional statuses of a closed invoice that the whole amount reached, late or above it. +closedInFullStatuses :: [Text] +closedInFullStatuses = ["PaidLate", "PaidOver"] + -- The last two are the only events a payment into a closed invoice sends. actedOnEventTypes :: [Text] actedOnEventTypes = ["InvoiceProcessing", "InvoiceSettled", "InvoiceExpired", "InvoiceInvalid", "InvoiceReceivedPayment", "InvoicePaymentSettled"] @@ -357,7 +361,7 @@ readInvoice env ref = do logAdditionalStatus ref giAdditionalStatus ms <- greenfield env what methodGet ["invoices", ref, "payment-methods"] [] Nothing now <- getCurrentTime - pure (ms >>= paymentMethodsSignal now ref giStatus giSpeedPolicy) + pure (ms >>= paymentMethodsSignal now ref giStatus giAdditionalStatus giSpeedPolicy) where what = "read invoice" @@ -404,11 +408,11 @@ invoicesPass now invs = foldr add (Right ListPass {lpMoved = [], lpSkipped = []} add v (Right pass) = case J.fromJSON v of J.Error e -> Right pass {lpSkipped = (invoiceIdOf v, T.pack e) : lpSkipped pass} J.Success gi -> addInvoice gi pass - addInvoice GInvoice {giId, giStatus, giSpeedPolicy, giPaymentMethods} pass = case giPaymentMethods of + addInvoice GInvoice {giId, giStatus, giAdditionalStatus, giSpeedPolicy, giPaymentMethods} pass = case giPaymentMethods of Nothing -> Left . ProviderError $ listWhat <> ": invoice " <> giId <> " carries no paymentMethods, so includePaymentMethods was not honoured" - Just ms -> case invoiceSignal now giId giStatus giSpeedPolicy ms of + Just ms -> case invoiceSignal now giId giStatus giAdditionalStatus giSpeedPolicy ms of Left (ProviderError e) -> Right pass {lpSkipped = (Just giId, e) : lpSkipped pass} Right Nothing -> Right pass Right (Just sig) -> Right pass {lpMoved = (giId, sig) : lpMoved pass} @@ -425,14 +429,14 @@ logAdditionalStatus ref = \case Just s | s /= "None" -> logInfo ("btcpay: invoice " <> ref <> " additionalStatus " <> s) _ -> pure () --- | The status and speed policy are the invoice's, the body its payment methods. -paymentMethodsSignal :: UTCTime -> Text -> Text -> Maybe Text -> LB.ByteString -> Either ProviderError (Maybe PaymentSignal) -paymentMethodsSignal now ref status policy body = - decodeGreenfield "read invoice" body >>= invoiceSignal now ref status policy +-- | The status, additional status and speed policy are the invoice's, the body its payment methods. +paymentMethodsSignal :: UTCTime -> Text -> Text -> Maybe Text -> Maybe Text -> LB.ByteString -> Either ProviderError (Maybe PaymentSignal) +paymentMethodsSignal now ref status additional policy body = + decodeGreenfield "read invoice" body >>= invoiceSignal now ref status additional policy -- Complete is the old API's status name and never matches, so it has no case here. -invoiceSignal :: UTCTime -> Text -> Text -> Maybe Text -> [GPaymentMethod] -> Either ProviderError (Maybe PaymentSignal) -invoiceSignal now ref status policy ms = do +invoiceSignal :: UTCTime -> Text -> Text -> Maybe Text -> Maybe Text -> [GPaymentMethod] -> Either ProviderError (Maybe PaymentSignal) +invoiceSignal now ref status additional policy ms = do (m@GPaymentMethod {gpmRate, gpmPaid, gpmDue, gpmPayments, gpmSettledThreshold}, cc) <- chooseMethod ref ms rate <- priced "rate" gpmRate paid <- priced "paymentMethodPaid" gpmPaid @@ -440,11 +444,16 @@ invoiceSignal now ref status policy ms = do confirming = maybe False (`elem` map speedPolicyName confirmingPolicies) policy shown = cc /= CCXmr || maybe False (>= 1) gpmSettledThreshold received = receivedOf decimals confirming shown (status == "Settled") rate paid gpmDue gpmPayments + -- BTCPay never settles an invoice it has closed, so only these tell that the whole amount reached it + closedFunded + | maybe False (`elem` closedInFullStatuses) additional = PaidInFull + | wnValue paid > 0 && maybe False ((<= 0) . wnValue) gpmDue = PaidInFull + | otherwise = PaidInPart case status of "Settled" -> Right (Just (SigSettled received (fromMaybe now (latestSettledAt m)))) "Processing" -> Right (Just (SigFunded received PaidInFull)) - "Expired" -> Right (Just (SigClosed received)) - "Invalid" -> Right (Just (SigClosed received)) + "Expired" -> Right (Just (SigClosed received closedFunded)) + "Invalid" -> Right (Just (SigClosed received closedFunded)) "New" -> Right (SigFunded received PaidInPart <$ rcvCrypto received) other -> Left (ProviderError ("btcpay invoice " <> ref <> ": unknown status " <> other)) where @@ -486,7 +495,7 @@ receivedOf decimals confirming shown invoiceSettled rate paid due payments = Received { rcvAmount = toMinorUnits (wnValue paid * wnValue rate), rcvCrypto = if wnValue paid > 0 then Just (wnText paid) else Nothing, - rcvDue = wnText <$> due, + rcvDue = nonNegative <$> due, rcvUnits = fst <$> counted, rcvRate = Just (wnText rate), rcvConfirmed = case uncreditable of @@ -495,6 +504,8 @@ receivedOf decimals confirming shown invoiceSettled rate paid due payments = rcvUncreditable = uncreditable } where + -- an overpaid invoice's due is below 0, and nothing is owed on it + nonNegative WireNum {wnText, wnValue} = if wnValue < 0 then "0" else wnText settled = filter ((== "Settled") . gpStatus) payments allSettled = invoiceSettled || (not (null payments) && length settled == length payments) counted = do diff --git a/apps/simplex-store-service/src/StoreService/Providers/Stripe.hs b/apps/simplex-store-service/src/StoreService/Providers/Stripe.hs index 562ba52fe7..4295b919e5 100644 --- a/apps/simplex-store-service/src/StoreService/Providers/Stripe.hs +++ b/apps/simplex-store-service/src/StoreService/Providers/Stripe.hs @@ -13,6 +13,7 @@ where import StoreService.Config (StripeConfig (..)) import StoreService.Providers ( Confirmed (..), + Funded (..), ListPass (..), OrderDraft (..), PaymentSignal (..), @@ -266,7 +267,7 @@ signalOf :: UTCTime -> IntentRead -> Either ProviderError (Maybe PaymentSignal) signalOf now IntentRead {irStatus, irAmountReceived, irChargeCreated} = case irStatus of "succeeded" -> Right (Just (SigSettled (received irAmountReceived irAmountReceived) settledAt)) - "canceled" -> Right (Just (SigClosed (received 0 0))) + "canceled" -> Right (Just (SigClosed (received 0 0) PaidInPart)) s | s `elem` openStatuses -> Right Nothing | otherwise -> Left (ProviderError ("stripe payment_intent: unknown status " <> s)) where diff --git a/tests/Bots/StoreService/BTCPayTests.hs b/tests/Bots/StoreService/BTCPayTests.hs index 5db1ed7c47..63b2056143 100644 --- a/tests/Bots/StoreService/BTCPayTests.hs +++ b/tests/Bots/StoreService/BTCPayTests.hs @@ -61,6 +61,8 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do it "falls back to the read time when a Settled invoice was marked by hand" testSettledManuallyMarked it "funds on Processing" testProcessing it "closes on Expired and on Invalid" testClosed + it "reports a closed invoice paid in full on PaidLate, PaidOver or a due at 0 or less, and in part otherwise" testClosedPaidInFull + it "reads an overpaid invoice's negative due as 0" testOverpaidDueIsZero it "funds on New with something received" testNewWithPayment it "funds on New with a payment worth less than a minor unit" testNewWithDust it "reports no change on New with nothing received" testNewWithNothing @@ -93,6 +95,7 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do it "fails the pass when the payment methods are absent, rather than reporting health" testListFailsWithoutPaymentMethods it "skips an invoice it cannot even name, unaccounted for" testListSkipsWithoutId it "fails the pass on a response it cannot read" testListFailsOnUnreadableBody + it "reports a listed closed invoice paid in full from its PaidLate" testListClosedPaidLate describe "BTCPay-Sig" $ do it "accepts the indented bytes as received, for each acted-on type" testWebhookAccepts it "finds the header whatever its case" testWebhookHeaderCase @@ -109,7 +112,7 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do it "is refused when the api key is wrong, rather than passing silently" testFakeWrongApiKey it "sends the documented create body, and no redirectURL" testFakeCreateBody it "walks New to Processing to Settled, two calls per read" testFakeLifecycle - it "closes on Expired and on Invalid" testFakeClosed + it "closes on Expired and on Invalid, in full once the whole amount or BTCPay's PaidLate says so" testFakeClosed it "names a status the provider invented" testFakeUnknownStatus it "reads paymentMethodPaid over the wire, never totalPaid" testFakePaymentMethodPaid it "makes a 500 at checkout a ProviderError" testFakeCreate500 @@ -200,7 +203,7 @@ rcvUnitsOf :: PaymentSignal -> Maybe Int64 rcvUnitsOf = \case SigFunded r _ -> rcvUnits r SigSettled r _ -> rcvUnits r - SigClosed r -> rcvUnits r + SigClosed r _ -> rcvUnits r testHighSpeedConfirmsNothing :: IO () testHighSpeedConfirmsNothing = do @@ -254,6 +257,7 @@ btcPaid paid payments = dueAfter :: Text -> Text dueAfter = \case "0.00050000" -> "0.00000000" + "0.00080000" -> "-0.00030000" "0.00000001" -> "0.00050499" _ -> "0.00050000" @@ -275,7 +279,11 @@ signalOf = signalUnder (Just "MediumSpeed") -- | Read from an invoice made under the speed policy given, or none. signalUnder :: Maybe Text -> Text -> [J.Value] -> Either ProviderError (Maybe PaymentSignal) -signalUnder policy status methods = paymentMethodsSignal readTime ref status policy (methodsBody methods) +signalUnder policy status methods = paymentMethodsSignal readTime ref status Nothing policy (methodsBody methods) + +-- | Read from an invoice with the additional status given. +signalWith :: Text -> Text -> [J.Value] -> Either ProviderError (Maybe PaymentSignal) +signalWith additional status methods = paymentMethodsSignal readTime ref status (Just additional) (Just "MediumSpeed") (methodsBody methods) -- | BTC at the rate the bodies carry: the cents, crypto and due received, and the satoshi received and confirmed, with the confirmed cents. btcReceived :: Word32 -> Maybe Text -> Text -> Int64 -> Int64 -> Word32 -> Received @@ -317,9 +325,27 @@ testProcessing = testClosed :: IO () testClosed = do signalOf "Expired" [btcPaid "0.00050000" [payment "Processing" 1700000000]] - `shouldBe` Right (Just (SigClosed halfMilliBtcUnconfirmed)) + `shouldBe` Right (Just (SigClosed halfMilliBtcUnconfirmed PaidInFull)) signalOf "Invalid" [btcPaid "0.00000000" []] - `shouldBe` Right (Just (SigClosed (nothingReceived "0.00050000"))) + `shouldBe` Right (Just (SigClosed (nothingReceived "0.00050000") PaidInPart)) + +-- | BTCPay keeps a late-paid invoice Expired, or Invalid after a cancel, and says the whole amount arrived only by these. +testClosedPaidInFull :: IO () +testClosedPaidInFull = do + let verdict additional status paid = (\case Right (Just (SigClosed _ f)) -> Just f; _ -> Nothing) (signalWith additional status [btcPaid paid [payment "Settled" 1700000000]]) + verdict "PaidLate" "Expired" "0.00025000" `shouldBe` Just PaidInFull + verdict "PaidOver" "Invalid" "0.00025000" `shouldBe` Just PaidInFull + verdict "None" "Expired" "0.00050000" `shouldBe` Just PaidInFull + verdict "Marked" "Invalid" "0.00080000" `shouldBe` Just PaidInFull + verdict "PaidPartial" "Expired" "0.00025000" `shouldBe` Just PaidInPart + verdict "None" "Invalid" "0.00025000" `shouldBe` Just PaidInPart + verdict "None" "Expired" "0.00000000" `shouldBe` Just PaidInPart + +testOverpaidDueIsZero :: IO () +testOverpaidDueIsZero = do + let overpaid = btcReceived 8640 (Just "0.00080000") "0" 80000 80000 8640 + signalOf "Settled" [btcPaid "0.00080000" []] `shouldBe` Right (Just (SigSettled overpaid readTime)) + signalWith "PaidOver" "Expired" [btcPaid "0.00080000" []] `shouldBe` Right (Just (SigClosed overpaid {rcvConfirmed = Confirmed {cfCents = CurrencyAmount 0, cfUnits = Just 0}} PaidInFull)) testNewWithPayment :: IO () testNewWithPayment = @@ -399,7 +425,7 @@ testUnknownPaymentMethod = do testUnreadableResponse :: IO () testUnreadableResponse = - paymentMethodsSignal readTime ref "Settled" (Just "MediumSpeed") "502 Bad Gateway" `shouldSatisfy` namesInError "could not read the response" + paymentMethodsSignal readTime ref "Settled" Nothing (Just "MediumSpeed") "502 Bad Gateway" `shouldSatisfy` namesInError "could not read the response" namesInError :: Text -> Either ProviderError a -> Bool namesInError what = \case @@ -498,6 +524,14 @@ testListFailsOnUnreadableBody :: IO () testListFailsOnUnreadableBody = listSignals readTime "502 Bad Gateway" `shouldSatisfy` namesInError "could not read the response" +testListClosedPaidLate :: IO () +testListClosedPaidLate = do + let paidLate = case listEntry ref "Expired" (Just [btcPaid "0.00025000" []]) of + J.Object o -> J.Object (KM.insert "additionalStatus" (J.String "PaidLate") o) + other -> other + quarter = btcReceived 2700 (Just "0.00025000") "0.00050000" 25000 0 0 + lpMoved <$> listSignals readTime (J.encode [paidLate]) `shouldBe` Right [(ref, SigClosed quarter PaidInFull)] + testReadsPaymentMethodPaid :: IO () testReadsPaymentMethodPaid = do signalOf "Settled" [btcPaid "0.00050000" [payment "Settled" 1700000000]] @@ -547,7 +581,7 @@ testNumberAsWellAsString = do let asNumbers = "[{\"paymentMethodId\":\"BTC-CHAIN\",\"rate\":108000.12,\"paymentMethodPaid\":0.00050000,\ \\"payments\":[{\"status\":\"Settled\",\"receivedDate\":1700000000}]}]" - case paymentMethodsSignal readTime ref "Settled" (Just "MediumSpeed") asNumbers of + case paymentMethodsSignal readTime ref "Settled" Nothing (Just "MediumSpeed") asNumbers of Right (Just (SigSettled r t)) -> do rcvAmount r `shouldBe` CurrencyAmount 5400 rcvCrypto r `shouldBe` Just "0.00050000" @@ -755,9 +789,11 @@ testFakeClosed :: IO () testFakeClosed = withProvider $ \fake p -> do ProviderInvoice {piProviderRef = invRef} <- createdInvoice p (SPMCrypto CCBtc) setInvoiceState fake invRef ["status" .= ("Expired" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)] - pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed halfMilliBtcUnconfirmed)) + pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed halfMilliBtcUnconfirmed PaidInFull)) setInvoiceState fake invRef ["status" .= ("Invalid" :: Text), "paymentMethodPaid" .= ("0.00000000" :: Text)] - pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed (nothingReceived "0.00050000"))) + pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed (nothingReceived "0.00050000") PaidInPart)) + setInvoiceState fake invRef ["status" .= ("Expired" :: Text), "additionalStatus" .= ("PaidLate" :: Text), "paymentMethodPaid" .= ("0.00025000" :: Text), "due" .= ("0.00025000" :: Text)] + pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed (btcReceived 2700 (Just "0.00025000") "0.00025000" 25000 0 0) PaidInFull)) testFakeUnknownStatus :: IO () testFakeUnknownStatus = withProvider $ \fake p -> do diff --git a/tests/Bots/StoreService/NamesBalancesTests.hs b/tests/Bots/StoreService/NamesBalancesTests.hs index 82f6380e7c..14c114d773 100644 --- a/tests/Bots/StoreService/NamesBalancesTests.hs +++ b/tests/Bots/StoreService/NamesBalancesTests.hs @@ -36,7 +36,7 @@ import StoreService.Names.Store import StoreService.Names.Turns (balanceTurnCount, newTurns, turnsCount, withBalanceTurn, withLabelTurn) import StoreService.Orders (cancelOpenInvoice, expireOverdue, settleOrder) import StoreService.Poller (cleanupUnpaid, newPollerEnv, unpaidRetention) -import StoreService.Providers (PaymentSignal (..)) +import StoreService.Providers (Funded (..), PaymentSignal (..)) import StoreService.Waiters (newWaiters) import StoreService.Web.Server (WebEnv (..)) import System.Timeout (timeout) @@ -477,7 +477,7 @@ testClosesRelease = withServiceStore $ \st -> do holder st ("h-" <> c) ("s-" <> c) 10000 (at 60) `shouldReturn` Right () cancelOpenInvoice st waiters Nothing (InvoiceId "inv-h-cancel") (at 2) `shouldReturn` True expireOverdue st waiters Nothing (at 61) (at 61) [InvoiceId "inv-h-sweep"] `shouldReturn` [InvoiceId "inv-h-sweep"] - settleOrder st waiters Nothing (InvoiceId "inv-h-settled") (SigClosed (rcv 0 Nothing)) (at 2) `shouldReturn` Right ISExpired + settleOrder st waiters Nothing (InvoiceId "inv-h-settled") (SigClosed (rcv 0 Nothing) PaidInPart) (at 2) `shouldReturn` Right ISExpired next <- reg st "h-next" withTransaction st (\db -> closeOverdue db next (at 61)) `shouldReturn` Just (nrVersion next + 1) forM_ closes $ \c -> do diff --git a/tests/Bots/StoreService/NamesLateCreditTests.hs b/tests/Bots/StoreService/NamesLateCreditTests.hs index f5bc09e446..d376912c79 100644 --- a/tests/Bots/StoreService/NamesLateCreditTests.hs +++ b/tests/Bots/StoreService/NamesLateCreditTests.hs @@ -174,7 +174,7 @@ stubRate = rateOf "60000.5" 60000.5 closedOrder :: Late -> Text -> Bool -> IO () closedOrder l@Late {lStore} r card = do placeOrderRow lStore r card 20000 (at 60) - settleAt l r (SigClosed nothingPaid) (at 61) `shouldReturn` Right ISExpired + settleAt l r (SigClosed nothingPaid PaidInPart) (at 61) `shouldReturn` Right ISExpired NameRegistration {nrPhase, nrLive} <- reg lStore r (nrPhase, nrLive) `shouldBe` (PUnpaid, False) @@ -306,9 +306,9 @@ testLateCredited :: IO () testLateCredited = withLate $ \l@Late {lStore = st} -> do source st "paid" 10000 holder st "credited" "paid" 10000 (at 60) `shouldReturn` Right () - settleAt l "credited" (SigClosed nothingPaid) (at 61) `shouldReturn` Right ISExpired + settleAt l "credited" (SigClosed nothingPaid PaidInPart) (at 61) `shouldReturn` Right ISExpired figures st "paid" t0 `shouldReturn` Just (10000, 10000, 0, Nothing) - logs <- readSignal l "credited" (SigClosed (btcPaid lateUnits lateUnits)) + logs <- readSignal l "credited" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) logs `shouldSatisfy` logged "INFO" "invoice inv-credited credited 19200 cents to the balance of registration credited for 320000 units at 60000.5 (invoice 62500, current 60000.5)" logs `shouldNotSatisfy` logged "ERROR" "inv-credited" balanceOf st "credited" `shouldReturn` Just (19200, 19200, 0) @@ -319,18 +319,18 @@ testRisingPrice :: IO () testRisingPrice = withLate $ \l@Late {lStore = st} -> do closedOrder l "x" False setRate l (Right $ rateOf "70000" 70000) - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) creditsOf st "x" `shouldReturn` [(Just lateUnits, Just "62500", Just "70000", Just "62500", 20000)] balanceOf st "x" `shouldReturn` Just (20000, 20000, 0) testGrowingReports :: IO () testGrowingReports = withLate $ \l@Late {lStore = st} -> do closedOrder l "x" False - void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000) PaidInPart) balanceOf st "x" `shouldReturn` Just (9600, 9600, 0) - void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000)) - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000) PaidInPart) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) map (\(units, _, _, _, cents) -> (units, cents)) <$> creditsOf st "x" `shouldReturn` [(Just 160000, 9600), (Just 160000, 9600)] balanceOf st "x" `shouldReturn` Just (19200, 19200, 0) @@ -338,7 +338,7 @@ testCloseAndCancel :: IO () testCloseAndCancel = withLate $ \l@Late {lStore = st, lWaiters} -> do placeOrderRow st "p" False 20000 (at 60) settleAt l "p" (SigFunded (btcPaid lateUnits 160000) PaidInPart) (at 10) `shouldReturn` Right ISOpen - void $ readSignal l "p" (SigClosed (btcPaid lateUnits 160000)) + void $ readSignal l "p" (SigClosed (btcPaid lateUnits 160000) PaidInPart) nrLive <$> reg st "p" `shouldReturn` False balanceOf st "p" `shouldReturn` Just (9600, 9600, 0) placeOrderRow st "c" False 20000 (at 60) @@ -353,11 +353,11 @@ testCloseAndCancel = withLate $ \l@Late {lStore = st, lWaiters} -> do testUnconfirmedThenSettled :: IO () testUnconfirmedThenSettled = withLate $ \l@Late {lStore = st} -> do closedOrder l "x" False - logs <- readSignal l "x" (SigClosed (btcPaid lateUnits 0)) + logs <- readSignal l "x" (SigClosed (btcPaid lateUnits 0) PaidInPart) logs `shouldSatisfy` logged "INFO" "invoice inv-x holds money of its closed order not yet confirmed" balanceOf st "x" `shouldReturn` Nothing - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) length <$> creditsOf st "x" `shouldReturn` 1 balanceOf st "x" `shouldReturn` Just (19200, 19200, 0) @@ -367,7 +367,7 @@ testNeverConfirmed = withLate $ \l@Late {lStore = st} -> do closedOrder l "never" False let seenAt = at (60 * 24 * 5) alert = "invoice inv-never of order never: 320000 satoshi received, 0 satoshi confirmed, 0 satoshi credited; refund by hand only a transaction confirmed on chain that BTCPay no longer monitors; one still Processing there waits" - settleAt l "never" (SigClosed (btcPaid lateUnits 0)) seenAt `shouldReturn` Right ISExpired + settleAt l "never" (SigClosed (btcPaid lateUnits 0) PaidInPart) seenAt `shouldReturn` Right ISExpired alertsAt l (Right stubRate) (pastWindow seenAt (-60)) >>= (`shouldNotSatisfy` T.isInfixOf "invoice inv-never of order never") lateWaitOf st "never" `shouldReturn` Just LWConfirming logs <- alertsAt l (Right stubRate) (pastWindow seenAt 60) @@ -379,7 +379,7 @@ testNeverConfirmed = withLate $ \l@Late {lStore = st} -> do testPartCreditAlerted :: IO () testPartCreditAlerted = withLate $ \l@Late {lStore = st} -> do closedOrder l "part" False - settleAt l "part" (SigClosed (btcPaid lateUnits 160000)) (at 100) `shouldReturn` Right ISExpired + settleAt l "part" (SigClosed (btcPaid lateUnits 160000) PaidInPart) (at 100) `shouldReturn` Right ISExpired void $ passAt l (at 101) balanceOf st "part" `shouldReturn` Just (9600, 9600, 0) logs <- alertsAt l (Right stubRate) (pastWindow (at 100) 60) @@ -401,8 +401,8 @@ testRateFails = withLate $ \l@Late {lStore = st} -> do closedOrder l "fail1" False closedOrder l "fail2" False setRate l (Left $ ProviderError "rates down for fail1") - logs <- readSignal l "fail1" (SigClosed (btcPaid lateUnits lateUnits)) - settleAt l "fail2" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired + logs <- readSignal l "fail1" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) + settleAt l "fail2" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired more <- passAt l (at 71) count "late credits wait, as the current rate cannot be read; each pass tries again: rates down for fail1" (logs <> more) `shouldBe` 1 lateWaitOf st "fail1" `shouldReturn` Just LWCrediting @@ -417,7 +417,7 @@ testRateFloor = withLate $ \l@Late {lStore = st} -> do closedOrder l "floored" False let floored = rateOf "31000" 31000 setRate l (Right floored) - settleAt l "floored" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired + settleAt l "floored" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired logs <- passAt l (at 71) logs `shouldSatisfy` logged "ERROR" "invoice inv-floored is not credited: the current rate 31000 is below half its rate 62500" balanceOf st "floored" `shouldReturn` Nothing @@ -433,7 +433,7 @@ testRateFloor = withLate $ \l@Late {lStore = st} -> do testFloorLoggedOnce :: IO () testFloorLoggedOnce = withLate $ \l -> do closedOrder l "floorlog" False - settleAt l "floorlog" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired + settleAt l "floorlog" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired setRate l (Right $ rateOf "31000" 31000) first <- passAt l (at 71) setRate l (Right $ rateOf "30000" 30000) @@ -445,24 +445,24 @@ testWaitingOutranksStoredReason :: IO () testWaitingOutranksStoredReason = withLate $ \l@Late {lStore = st} -> do closedOrder l "outranked" False withTransaction st $ \db -> setLateSupport db (invOf "outranked") LSHighSpeed - settleAt l "outranked" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired + settleAt l "outranked" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired alertsAt l (Left $ ProviderError "rates down for outranked") (pastWindow (at 70) 60) >>= (`shouldSatisfy` logged "ERROR" "invoice inv-outranked of order outranked: 320000 satoshi received, 320000 satoshi confirmed, 0 satoshi credited; confirmed, the credit waits on the rate read; do not refund; fix the rate read") testRateProblemsNamed :: IO () testRateProblemsNamed = withLate $ \l@Late {lStore = st} -> do closedOrder l "noprovider" False - settleAt l "noprovider" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired + settleAt l "noprovider" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired withTransaction st $ \db -> DB.execute_ db "UPDATE sx_badge_service_invoices SET provider = 'apple' WHERE invoice_id = 'inv-noprovider'" closedOrder l "norate" False - settleAt l "norate" (SigClosed (btcPaid lateUnits lateUnits) {rcvRate = Nothing}) (at 70) `shouldReturn` Right ISExpired + settleAt l "norate" (SigClosed (btcPaid lateUnits lateUnits) {rcvRate = Nothing} PaidInPart) (at 70) `shouldReturn` Right ISExpired logs <- (<>) <$> passAt l (at 71) <*> passAt l (at 72) count "invoice inv-noprovider has late money to credit, but no provider" logs `shouldBe` 1 logs `shouldSatisfy` logged "ERROR" "invoice inv-norate has confirmed late money, but no invoice rate was recorded to credit it at" testOneRateReadPerPass :: IO () testOneRateReadPerPass = withLate $ \l@Late {lStore = st} -> do - mapM_ (\r -> closedOrder l r False >> settleAt l r (SigClosed (btcPaid lateUnits lateUnits)) (at 70)) ["x", "y", "z"] + mapM_ (\r -> closedOrder l r False >> settleAt l r (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70)) ["x", "y", "z"] closedOrder l "card" True settleAt l "card" (SigSettled (cardPaid 20000 20000) (at 70)) (at 70) `shouldReturn` Right ISPaid void $ passAt l (at 71) @@ -487,7 +487,7 @@ testCreditedByPass = withLate $ \l@Late {lStore = st} -> do closedOrder l "settled" False settleAt l "settled" (SigSettled (btcPaid lateUnits lateUnits) (at 70)) (at 70) `shouldReturn` Right ISPaid closedOrder l "crashed" False - settleAt l "crashed" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired + settleAt l "crashed" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired mapM (balanceOf st) ["settled", "crashed"] `shouldReturn` [Nothing, Nothing] void $ passAt l (at 71) mapM (balanceOf st) ["settled", "crashed"] `shouldReturn` replicate 2 (Just (19200, 19200, 0)) @@ -495,7 +495,7 @@ testCreditedByPass = withLate $ \l@Late {lStore = st} -> do testLiveAgain :: IO () testLiveAgain = withLate $ \l@Late {lStore = st} -> do closedOrder l "x" False - settleAt l "x" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired + settleAt l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired let liveAgain _ = do withTransaction st $ \db -> DB.execute_ db "UPDATE sx_badge_service_name_registrations SET live = 1 WHERE registration_id = 'x'" pure (Right stubRate) @@ -506,21 +506,21 @@ testLiveAgain = withLate $ \l@Late {lStore = st} -> do testTwoInstancesAlert :: IO () testTwoInstancesAlert = withLate $ \l -> do closedOrder l "twice" False - settleAt l "twice" (SigClosed (btcPaid lateUnits 0)) (at 70) `shouldReturn` Right ISExpired + settleAt l "twice" (SigClosed (btcPaid lateUnits 0) PaidInPart) (at 70) `shouldReturn` Right ISExpired let first = "invoice inv-twice of order twice: 320000 satoshi received" logs <- (<>) <$> alertsAt l (Right stubRate) (pastWindow (at 70) 60) <*> alertsAt l (Right stubRate) (pastWindow (at 70) 60) count first logs `shouldBe` 1 - settleAt l "twice" (SigClosed (btcPaid 400000 0)) (at 80) `shouldReturn` Right ISExpired + settleAt l "twice" (SigClosed (btcPaid 400000 0) PaidInPart) (at 80) `shouldReturn` Right ISExpired alertsAt l (Right stubRate) (pastWindow (at 70) 120) >>= (`shouldSatisfy` logged "ERROR" "invoice inv-twice of order twice: 400000 satoshi received, 0 satoshi confirmed") testFallingSum :: IO () testFallingSum = withLate $ \l@Late {lStore = st} -> do closedOrder l "x" False - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) - void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000) PaidInPart) confirmed <- withTransaction st $ \db -> DB.query db "SELECT confirmed_units FROM sx_badge_service_payments WHERE invoice_id = 'inv-x'" () confirmed `shouldBe` [Only (Just lateUnits)] - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) length <$> creditsOf st "x" `shouldReturn` 1 balanceOf st "x" `shouldReturn` Just (19200, 19200, 0) @@ -531,7 +531,7 @@ testHintPastWindow = withLate $ \l@Late {lStore = st} -> do let longAgo = addUTCTime (negate $ settleWindow + 3600) now withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_invoices SET created_at = ? WHERE invoice_id = 'inv-x'" (Only longAgo) unpaidRefs st (addUTCTime (negate settleWindow) now) >>= (`shouldNotSatisfy` elem ("crypto", refOf "x")) - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) balanceOf st "x" `shouldReturn` Just (19200, 19200, 0) testStripeCredited :: IO () @@ -576,9 +576,9 @@ testXmrLate = withLate $ \l@Late {lStore = st} -> do testCreditWhileHeld :: IO () testCreditWhileHeld = withLate $ \l@Late {lStore = st} -> do closedOrder l "x" False - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) holder st "h" "x" 19200 (at 60) `shouldReturn` Right () - void $ readSignal l "x" (SigClosed (btcPaid 400000 400000)) + void $ readSignal l "x" (SigClosed (btcPaid 400000 400000) PaidInPart) figures st "x" (at 10) `shouldReturn` Just (24000, 24000, 0, Just BalanceHold {bhHolder = RegistrationId "h", bhUntil = at 60, bhOverdue = False, bhFunded = False}) settleAt l "h" (SigSettled (btcPaid 330000 330000) (at 10)) (at 10) `shouldReturn` Right ISPaid figures st "x" (at 10) `shouldReturn` Just (4800, 24000, 0, Nothing) @@ -590,8 +590,8 @@ coveredSpend st r src price seen = withTransaction st $ \db -> createBalanceRegi testSpendBeforeCredit :: IO () testSpendBeforeCredit = withLate $ \l@Late {lStore = st} -> do closedOrder l "x" False - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) - void $ readSignal l "x" (SigClosed (btcPaid 400000 400000)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) + void $ readSignal l "x" (SigClosed (btcPaid 400000 400000) PaidInPart) coveredSpend st "c" "x" 10000 19200 `shouldReturn` Left RRBalanceChanged coveredSpend st "c" "x" 10000 24000 `shouldReturn` Right () balanceOf st "x" `shouldReturn` Just (14000, 24000, 0) @@ -600,9 +600,9 @@ testCreditRefundTwice :: IO () testCreditRefundTwice = withLate $ \l@Late {lStore = st} -> do turns <- newTurns closedOrder l "x" False - void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000) PaidInPart) void (recordRefund turns st "x" 9600 (at 80) >>= either (fail . show) pure) - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) void (recordRefund turns st "inv-x" 9600 (at 81) >>= either (fail . show) pure) balanceOf st "x" `shouldReturn` Just (0, 19200, 19200) invariantHolds st "x" @@ -611,7 +611,7 @@ testSpendAndRefundLate :: IO () testSpendAndRefundLate = withLate $ \l@Late {lStore = st} -> do turns <- newTurns closedOrder l "x" False - void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) coveredSpend st "c" "x" 10000 19200 `shouldReturn` Right () nrBalanceSource <$> reg st "c" `shouldReturn` Just (RegistrationId "x") recordRefund turns st "x" 10000 (at 80) >>= (`shouldSatisfy` \case Left (RefundAmount 9200) -> True; _ -> False) @@ -654,14 +654,14 @@ testZeroBalances = withLate $ \Late {lStore = st} -> do testLateWaits :: IO () testLateWaits = withLate $ \l@Late {lStore = st} -> do mapM_ (\r -> closedOrder l r False) ["confirming", "crediting", "highspeed", "units", "floor", "alerted"] - settleAt l "crediting" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired - settleAt l "highspeed" (SigClosed (btcPaid lateUnits 0) {rcvUncreditable = Just UCHighSpeed}) (at 70) `shouldReturn` Right ISExpired - settleAt l "units" (SigClosed (btcPaid 0 0) {rcvAmount = CurrencyAmount 20000, rcvCrypto = Just "0.003200001", rcvUnits = Nothing, rcvUncreditable = Just UCUncounted}) (at 70) `shouldReturn` Right ISExpired - settleAt l "alerted" (SigClosed (btcPaid lateUnits 0)) (at 70) `shouldReturn` Right ISExpired + settleAt l "crediting" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired + settleAt l "highspeed" (SigClosed (btcPaid lateUnits 0) {rcvUncreditable = Just UCHighSpeed} PaidInPart) (at 70) `shouldReturn` Right ISExpired + settleAt l "units" (SigClosed (btcPaid 0 0) {rcvAmount = CurrencyAmount 20000, rcvCrypto = Just "0.003200001", rcvUnits = Nothing, rcvUncreditable = Just UCUncounted} PaidInPart) (at 70) `shouldReturn` Right ISExpired + settleAt l "alerted" (SigClosed (btcPaid lateUnits 0) PaidInPart) (at 70) `shouldReturn` Right ISExpired void $ alertsAt l (Right stubRate) (pastWindow (at 70) 60) - settleAt l "confirming" (SigClosed (btcPaid lateUnits 0)) (pastWindow (at 70) 60) `shouldReturn` Right ISExpired + settleAt l "confirming" (SigClosed (btcPaid lateUnits 0) PaidInPart) (pastWindow (at 70) 60) `shouldReturn` Right ISExpired setRate l (Right $ rateOf "31000" 31000) - void $ readSignal l "floor" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "floor" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) placeOrderRow st "open" False 20000 (at 60) settleAt l "open" (SigFunded (btcPaid lateUnits 0) PaidInFull) (at 70) `shouldReturn` Right ISOpen let waits = mapM (\r -> (r,) <$> lateWaitOf st r) @@ -675,7 +675,7 @@ testLateWaits = withLate $ \l@Late {lStore = st} -> do ("open", Nothing) ] setRate l (Right stubRate) - void $ readSignal l "alerted" (SigClosed (btcPaid lateUnits lateUnits)) + void $ readSignal l "alerted" (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) void $ passAt l (at 71) waits ["crediting", "floor", "alerted"] `shouldReturn` [("crediting", Nothing), ("floor", Just LWSupport), ("alerted", Nothing)] @@ -706,7 +706,7 @@ testConcurrentCredits = withServiceStores $ \open -> do let due :: Text -> IO () due r = do closedOrder l r False - settleAt l r (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired + settleAt l r (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 70) `shouldReturn` Right ISExpired forM_ [1 .. rounds] $ \n -> do let r = "x" <> T.pack (show n) due r @@ -741,12 +741,12 @@ testCreditAgainstSettlement = withServiceStores $ \open -> do withLateOn st $ \l -> forM_ [1 .. rounds] $ \n -> do let r = "x" <> T.pack (show n) closedOrder l r False - settleAt l r (SigClosed (btcPaid lateUnits 160000)) (at 70) `shouldReturn` Right ISExpired + settleAt l r (SigClosed (btcPaid lateUnits 160000) PaidInPart) (at 70) `shouldReturn` Right ISExpired arrived <- newTVarIO 0 let readRate :: CryptoCurrency -> IO (Either ProviderError Rate) readRate _ = Right stubRate <$ meet arrived raise :: IO (Either Text InvoiceStatus) - raise = meet arrived >> settleOrder other otherWaiters Nothing (invOf r) (SigClosed (btcPaid lateUnits lateUnits)) (at 80) + raise = meet arrived >> settleOrder other otherWaiters Nothing (invOf r) (SigClosed (btcPaid lateUnits lateUnits) PaidInPart) (at 80) (credited, raised) <- concurrently (creditLateInvoice st readRate (invOf r) (at 80)) raise (n, raised) `shouldBe` (n, Right ISExpired) credited `shouldSatisfy` \case COCredited _ -> True; _ -> False diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 6528852d1d..027775dff6 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -1302,7 +1302,7 @@ testOneLateAlert = withOrders $ \ctx@Ctx {cStore = st, cWeb} -> do poller <- newPoller setSignals (cStub ctx) [(ref, SigFunded paid PaidInPart)] refunds <$> readWith poller `shouldReturn` 0 - setSignals (cStub ctx) [(ref, SigClosed paid)] + setSignals (cStub ctx) [(ref, SigClosed paid PaidInPart)] logs <- readWith poller refunds logs `shouldBe` 1 logs `shouldSatisfy` T.isInfixOf "it stays unpaid, and its money is credited to its balance once confirmed, else alerted" @@ -1342,7 +1342,7 @@ testCancelAlertsFunded = withOrdersCancelling (SigFunded paid PaidInPart) $ \ctx (status, v) <- post ctx ("/api/invoice/" <> T.unpack (invoiceText invId) <> "/cancel") "" (status, field "status" =<< v, field "cryptoAmountPaid" =<< v) `shouldBe` (200, Just "expired", Just "0.00078") length (T.breakOnAll (alertOf invId) logs) `shouldBe` 1 - capturingStderr (settleNow ctx invId (SigClosed paid) `shouldReturn` Right ISExpired) >>= (`shouldNotSatisfy` T.isInfixOf (alertOf invId)) + capturingStderr (settleNow ctx invId (SigClosed paid PaidInPart) `shouldReturn` Right ISExpired) >>= (`shouldNotSatisfy` T.isInfixOf (alertOf invId)) (nrPhase &&& nrLive) <$> invoiceRegistration ctx invId `shouldReturn` (PUnpaid, False) where paid = rcv 5000 (Just "0.00078") @@ -1414,7 +1414,7 @@ testSettlementLocksInvoice = withOrders $ \ctx -> do testExpiryCloses :: IO () testExpiryCloses = withOrders $ \ctx -> do (closedByProvider, _) <- placed ctx aliceOrder - settleNow ctx closedByProvider (SigClosed (rcv 0 Nothing)) `shouldReturn` Right ISExpired + settleNow ctx closedByProvider (SigClosed (rcv 0 Nothing) PaidInPart) `shouldReturn` Right ISExpired r <- invoiceRegistration ctx closedByProvider (nrPhase r, nrLive r, nrVersion r) `shouldBe` (PUnpaid, False, 2) (swept, _) <- placed ctx aliceOrder {oLabel = "dynamis", oPrice = 20000, oCommitment = commitmentOf 2} @@ -1455,7 +1455,7 @@ testPassSweepsAroundFailures = do withConnection st $ \db -> DB.execute db "UPDATE sx_badge_service_name_registrations SET phase = 'lost' WHERE registration_id = ? AND phase = ?" (poisonedId, "unpaid" :: Text) poisonedRef <- refOf poisoned refOf unread >>= writeIORef unreadable - setSignals (cStub ctx) [(poisonedRef, SigClosed (rcv 0 Nothing))] + setSignals (cStub ctx) [(poisonedRef, SigClosed (rcv 0 Nothing) PaidInPart)] poller <- newPollerEnv st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) (weHints cWeb) (weProviders cWeb) (poll $ weConfig cWeb) void $ capturingStderr $ runOnePass poller mapM (fmap (irStatus <$>) . getInvoice st) [poisoned, unread, good] `shouldReturn` map Just [ISOpen, ISOpen, ISExpired] @@ -1471,7 +1471,7 @@ testCleanupIn ctx@Ctx {cStore = st} = do mapM_ (uncurry place) [("gone", 1), ("funded", 2), ("late", 3), ("unread", 4)] placePaid st "recent" ownerA (order "alicebakery5" 5) (addUTCTime 3600 due) `shouldReturn` Right () settleOrder st (weWaiters $ cWeb ctx) Nothing (InvoiceId "inv-funded") (SigFunded (rcv 100 (Just "0.00001")) PaidInPart) t0 `shouldReturn` Right ISOpen - setSignals (cStub ctx) [(ref "late", SigClosed (rcv 5000 (Just "0.00078")))] + setSignals (cStub ctx) [(ref "late", SigClosed (rcv 5000 (Just "0.00078")) PaidInPart)] failing <- newIORef False let reading p = p {pReadInvoice = \r -> readIORef failing >>= \f -> if f && r == ref "unread" then pure (Left $ ProviderError "down") else pReadInvoice p r} providers = map reading (weProviders $ cWeb ctx) diff --git a/tests/Bots/StoreService/StripeTests.hs b/tests/Bots/StoreService/StripeTests.hs index 94b8fcfcdb..ec15fc3080 100644 --- a/tests/Bots/StoreService/StripeTests.hs +++ b/tests/Bots/StoreService/StripeTests.hs @@ -7,6 +7,7 @@ module Bots.StoreService.StripeTests (badgeStripeTests) where import StoreService.Config (StripeConfig (..)) import StoreService.Providers ( Confirmed (..), + Funded (..), ListPass (..), OrderDraft (..), PaymentSignal (..), @@ -176,7 +177,7 @@ testFakeCancel = withProvider $ \fake p -> do ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe) pCancelInvoice p pid `shouldReturn` Right () fakeIntentStatus fake pid `shouldReturn` Just "canceled" - pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived)) + pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived PaidInPart)) pCancelInvoice p pid >>= (`shouldSatisfy` namesInError "payment_intent_unexpected_state") testFakeReadExpands :: IO () @@ -193,7 +194,7 @@ testFakeCanceled = withProvider $ \fake p -> do ProviderInvoice {piProviderRef = pid} <- createdInvoice p (SPMCard CPStripe) setIntentState fake pid ["status" .= ("canceled" :: Text)] -- A nonzero received amount here would write a phantom payment for money the buyer never sent. - pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived)) + pReadInvoice p pid `shouldReturn` Right (Just (SigClosed nothingReceived PaidInPart)) testFakeCreate500 :: IO () testFakeCreate500 = withProvider $ \fake p -> do @@ -236,7 +237,7 @@ testConfirmedOnlySucceeded = do now <- getCurrentTime let read' status = signalOf now IntentRead {irId = "pi_test_x", irStatus = status, irAmountReceived = 5400, irChargeCreated = Nothing} read' "succeeded" `shouldBe` Right (Just (SigSettled (cardReceived 5400 5400) now)) - read' "canceled" `shouldBe` Right (Just (SigClosed (cardReceived 0 0))) + read' "canceled" `shouldBe` Right (Just (SigClosed (cardReceived 0 0) PaidInPart)) withProvider $ \_ p -> isNothing (pCurrentRate p) `shouldBe` True -- | A status=open query returns only open intents, which carry no signal, so the poll lists by @@ -274,7 +275,7 @@ testFakeListsOpen = withProvider $ \_ p -> do rcv `shouldBe` fiftyFourDollarsReceived settledAt `shouldSatisfy` \t -> t >= askedAt && t <= answeredAt other -> failWith ("pi_test_a should settle at read time, got " <> show other) - lookup "pi_test_b" lpMoved `shouldBe` Just (SigClosed nothingReceived) + lookup "pi_test_b" lpMoved `shouldBe` Just (SigClosed nothingReceived PaidInPart) Left e -> failWith ("expected a list pass, got " <> show e) testFakeListSkipsIdless :: IO () diff --git a/tests/Bots/StoreService/WebTests.hs b/tests/Bots/StoreService/WebTests.hs index e075370a99..3e7c6b72ff 100644 --- a/tests/Bots/StoreService/WebTests.hs +++ b/tests/Bots/StoreService/WebTests.hs @@ -224,6 +224,7 @@ badgeWebTests = do it "omits the confirmations where no provider is configured" testViewOmitsConfirmationsWithoutBTCPay it "carries the provider's paid-in-full verdict, which the amounts cannot give" testViewCarriesTheProvidersPaidVerdict it "never withdraws a paid-in-full verdict on a later read" testPaidVerdictIsNotWithdrawnByALaterRead + it "carries a closed invoice's paid-in-full verdict, the status staying expired" testViewCarriesAClosedPaidVerdict it "answers an unknown id with 404 not_found and nothing else" testUnknownInvoiceIsOpaque it "releases a held wait when a payment lands without settling" testHeldWaitWakesOnAPaymentThatDoesNotSettle it "leaves a held wait alone when a pass writes nothing" testHeldWaitIsNotWokenByAPassThatWroteNothing @@ -909,7 +910,7 @@ stubProvider ref = lost <- ssCancelLost <$> readIORef ref if lost then do - atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert providerRef (SigClosed (rcv 0 Nothing)) (ssInvoices s)}, ()) + atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert providerRef (SigClosed (rcv 0 Nothing) PaidInPart) (ssInvoices s)}, ()) pure (Left (ProviderError "the response was lost")) else maybe (Right ()) Left . ssCancelError <$> readIORef ref, pListOpen = do @@ -2303,7 +2304,7 @@ testFundedRecordsWithoutMoving = bounded "funded records only" $ withServiceStor 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 + settle st iid (SigClosed (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISExpired invoiceStatus st iid `shouldReturn` ISExpired p <- paymentRow st iid ipAmount p `shouldBe` Just (CurrencyAmount 200) @@ -2313,7 +2314,7 @@ testClosedExpiresAnOpenInvoice = bounded "closed expires" $ withServiceStore $ \ testClosedWithNothingWritesNoPayment :: IO () testClosedWithNothingWritesNoPayment = bounded "closed on nothing" $ withServiceStore $ \st -> do iid <- seedOpen st - settle st iid (SigClosed (rcv 0 Nothing)) settleAt `shouldReturn` Right ISExpired + settle st iid (SigClosed (rcv 0 Nothing) PaidInPart) settleAt `shouldReturn` Right ISExpired invoiceStatus st iid `shouldReturn` ISExpired Just row <- getInvoice st iid irPayment row `shouldBe` Nothing @@ -2322,8 +2323,8 @@ testClosedWithNothingWritesNoPayment = bounded "closed on nothing" $ withService 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 + settle st iid (SigClosed (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISExpired + settle st iid (SigClosed (rcv 200 (Just "0.00020000")) PaidInPart) replayAt `shouldReturn` Right ISExpired invoiceStatus st iid `shouldReturn` ISExpired p <- paymentRow st iid ipAmount p `shouldBe` Just (CurrencyAmount 200) @@ -2344,7 +2345,7 @@ testPaidRefusesEverySignal = bounded "paid refuses" $ withServiceStore $ \st -> ) [ SigSettled (rcv 900 (Just "0.00090000")) replayAt, SigFunded (rcv 900 (Just "0.00090000")) PaidInPart, - SigClosed (rcv 900 (Just "0.00090000")) + SigClosed (rcv 900 (Just "0.00090000")) PaidInPart ] invoiceStatus st iid `shouldReturn` ISPaid bcExpiresAt <$> settledCode st iid `shouldReturn` deadline @@ -2706,7 +2707,7 @@ testEverySignalSettles = bounded "every signal settles" $ withStubPoller raceHol ref [ ("p-settled", settledSignal), ("p-funded", SigFunded (rcv 200 (Just "0.00020000")) PaidInPart), - ("p-closed", SigClosed (rcv 100 (Just "0.00010000"))) + ("p-closed", SigClosed (rcv 100 (Just "0.00010000")) PaidInPart) ] runOnePass poller invoiceStatus (weStore env) paid `shouldReturn` ISPaid @@ -2852,7 +2853,7 @@ testSweepWritesStatusAlone = bounded "sweep writes status alone" $ withStubPolle 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")))] + setSignals ref [("p-1", SigClosed (rcv 200 (Just "0.00020000")) PaidInPart)] runOnePass poller invoiceStatus (weStore env) iid `shouldReturn` ISExpired p <- paymentRow (weStore env) iid @@ -3793,6 +3794,17 @@ testPaidVerdictIsNotWithdrawnByALaterRead = bounded "verdict sticks" $ withCheck o <- jsonObject =<< webGet client (invoicePath iid) fieldOf o "paidInFull" `shouldBe` Just (J.Bool True) +testViewCarriesAClosedPaidVerdict :: IO () +testViewCarriesAClosedPaidVerdict = bounded "closed in full" $ withCheckout $ \_ env client -> do + iid <- seedOpenInvoice env + let readVerdict = (\o -> (fieldOf o "status", fieldOf o "paidInFull", fieldOf o "amountPaid")) <$> (jsonObject =<< webGet client (invoicePath iid)) + settleOrder (weStore env) (weWaiters env) Nothing iid (SigClosed (rcv 250 (Just "0.00025000")) PaidInPart) someCreated + `shouldReturn` Right ISExpired + readVerdict `shouldReturn` (Just (J.String "expired"), Just (J.Bool False), Just (J.Number 250)) + settleOrder (weStore env) (weWaiters env) Nothing iid (SigClosed (rcv 500 (Just "0.00050000")) PaidInFull) someCreated + `shouldReturn` Right ISExpired + readVerdict `shouldReturn` (Just (J.String "expired"), Just (J.Bool True), Just (J.Number 500)) + testExpireOverdueSparesAZeroAmount :: IO () testExpireOverdueSparesAZeroAmount = withServiceStore $ \st -> do seedBadgePrice st "price1"