From f2d414a8fd76deae1abc92d9fcf23444f2668ecb Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 16:13:50 +0000 Subject: [PATCH] store: credit late XMR only once shown confirmed --- .../src/StoreService/Names/Store.hs | 5 ++-- .../src/StoreService/Orders.hs | 1 + .../src/StoreService/Poller.hs | 2 ++ .../src/StoreService/Providers.hs | 4 +-- .../src/StoreService/Providers/BTCPay.hs | 25 ++++++++++++---- .../StoreService/Store/Postgres/Migrations.hs | 2 +- .../StoreService/Store/SQLite/Migrations.hs | 2 +- tests/Bots/StoreService/BTCPayTests.hs | 27 +++++++++++++---- .../Bots/StoreService/NamesLateCreditTests.hs | 30 +++++++++++++++++++ 9 files changed, 80 insertions(+), 18 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Store.hs b/apps/simplex-store-service/src/StoreService/Names/Store.hs index 4dda7c42a1..feece95196 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Store.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Store.hs @@ -340,8 +340,8 @@ data LateWait = LWConfirming | LWCrediting | LWSupport deriving (Eq, Show) -- | Why a closed order's money will not be credited by itself: an invoice made under HighSpeed, an amount that could not be counted in units, --- a current rate below the floor, or unconfirmed money alerted past the read window. -data LateSupport = LSHighSpeed | LSUnits | LSRateFloor | LSUnconfirmed +-- a current rate below the floor, unconfirmed money alerted past the read window, or money the provider shows no confirmation of. +data LateSupport = LSHighSpeed | LSUnits | LSRateFloor | LSUnconfirmed | LSNoConfirmation deriving (Eq, Show, Enum, Bounded) instance TextEncoding LateSupport where @@ -350,6 +350,7 @@ instance TextEncoding LateSupport where LSUnits -> "units" LSRateFloor -> "rate_floor" LSUnconfirmed -> "unconfirmed" + LSNoConfirmation -> "no_confirmation" textDecode t = lookup t [(textEncode s, s) | s <- [minBound .. maxBound]] instance FromField LateSupport where fromField = fromTextField_ textDecode diff --git a/apps/simplex-store-service/src/StoreService/Orders.hs b/apps/simplex-store-service/src/StoreService/Orders.hs index 92023d6c78..fbb3928280 100644 --- a/apps/simplex-store-service/src/StoreService/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Orders.hs @@ -221,6 +221,7 @@ lateSupportOf :: Uncreditable -> LateSupport lateSupportOf = \case UCHighSpeed -> LSHighSpeed UCUncounted -> LSUnits + UCNoConfirmationShown -> LSNoConfirmation latePayment :: InvoiceId -> RegistrationId -> IO () latePayment (InvoiceId invText) (RegistrationId rid) = diff --git a/apps/simplex-store-service/src/StoreService/Poller.hs b/apps/simplex-store-service/src/StoreService/Poller.hs index 5138b6e547..791178d9d5 100644 --- a/apps/simplex-store-service/src/StoreService/Poller.hs +++ b/apps/simplex-store-service/src/StoreService/Poller.hs @@ -399,6 +399,7 @@ lateReason :: PollerEnv -> LateAlert -> IO (Text, Maybe LateSupport) lateReason env@PollerEnv {peStore, peProviders} LateAlert {laPending, laState = LateCreditState {lsInvoice, lsCoin, lsSupport, lsInvoiceRate}} = case laPending of LPUncounted -> pure (uncounted, Nothing) _ | lsSupport == Just LSHighSpeed -> pure (highSpeed, Nothing) + _ | lsSupport == Just LSNoConfirmation -> pure (noConfirmation, Nothing) LPUncredited -> case lsCoin of Nothing -> pure (cardWaits, Nothing) Just coin @@ -411,6 +412,7 @@ lateReason env@PollerEnv {peStore, peProviders} LateAlert {laPending, laState = where unconfirmed = "refund by hand only a transaction confirmed on chain that BTCPay no longer monitors; one still Processing there waits" highSpeed = "the invoice was made under HighSpeed, so its money is never credited by itself; refund by hand only a transaction confirmed on chain" + noConfirmation = "the Monero plugin shows no confirmation of this money (the invoice's settled-confirmation threshold is 0 or not given), so it is never credited by itself; refund by hand only a transaction confirmed on chain" rateRead = "confirmed, the credit waits on the rate read; do not refund; fix the rate read" cardWaits = "confirmed, the credit waits on the poller's credit pass; do not refund; check the service log" rateFloor current = "confirmed; the coin's price fell by more than half since the invoice (" <> fromMaybe "?" lsInvoiceRate <> ", " <> current <> "); the owner decides: credit at the current rate, or refund by hand" diff --git a/apps/simplex-store-service/src/StoreService/Providers.hs b/apps/simplex-store-service/src/StoreService/Providers.hs index 8e5aae52c2..f4d02372e2 100644 --- a/apps/simplex-store-service/src/StoreService/Providers.hs +++ b/apps/simplex-store-service/src/StoreService/Providers.hs @@ -52,8 +52,8 @@ data Confirmed = Confirmed {cfCents :: CurrencyAmount, cfUnits :: Maybe Int64} deriving (Eq, Show) -- | Why money on an invoice is never credited by itself: it was made under a policy that settles at zero confirmations, --- or its crypto could not be counted in atomic units. Such money confirms nothing. -data Uncreditable = UCHighSpeed | UCUncounted +-- its crypto could not be counted in atomic units, or the provider shows no confirmation of it. Such money confirms nothing. +data Uncreditable = UCHighSpeed | UCUncounted | UCNoConfirmationShown deriving (Eq, Show) -- | A coin's current price in the service's currency, above 0: as the provider wrote it, and as a decimal to compute with. diff --git a/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs b/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs index fef0764691..23bc5b199a 100644 --- a/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs +++ b/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs @@ -86,7 +86,11 @@ import Simplex.Messaging.Util (safeDecodeUtf8, tshow) -- - an invoice's checkout.speedPolicy, GET stores/{storeId}/invoices/{invoiceId} and the list: BTCPayServer.Client/Models/InvoiceData.cs, -- nullable; HighSpeed settles at 0 confirmations, MediumSpeed at 1, LowMediumSpeed at 2, LowSpeed at 6 -- (wwwroot/swagger/v1/swagger.template.json, SpeedPolicy). The Monero plugin (btcpay-monero/btcpayserver-monero-plugin v1.4.0, --- Plugins/Monero/Services/MoneroListener.cs, ConfirmationsRequired) maps the policies the same way, unless the store sets its own threshold; +-- Plugins/Monero/Services/MoneroListener.cs, ConfirmationsRequired) maps the policies the same way, unless the store sets its own +-- InvoiceSettledConfirmationThreshold, which settles a payment at that many confirmations. Greenfield's payment model +-- (Controllers/GreenField/GreenfieldInvoiceController.cs, ToPaymentModel) carries no payment's confirmations; the method's +-- additionalData (Payments/MoneroLikeOnChainPaymentMethodDetails.cs, camel-cased by Data/BlobSerializer.cs) carries the invoice's +-- invoiceSettledConfirmationThreshold, so a Settled XMR payment shows a confirmation only when it is at least 1; -- - the store's rates, GET stores/{storeId}/rates?currencyPair=BTC_USD: Controllers/GreenField/GreenfieldStoreRatesController.cs and -- Models/StoreRateResult.cs, a list of {currencyPair, errors, rate}, rate null when errors is not empty; it needs canviewstoresettings. btcMethodId, xmrMethodId :: Text @@ -199,7 +203,8 @@ data GPaymentMethod = GPaymentMethod gpmRate :: Maybe WireNum, gpmPaid :: Maybe WireNum, gpmDue :: Maybe WireNum, - gpmPayments :: [GPayment] + gpmPayments :: [GPayment], + gpmSettledThreshold :: Maybe Int } deriving (Show) @@ -213,6 +218,12 @@ instance J.FromJSON GPaymentMethod where <*> o J..:? "paymentMethodPaid" <*> o J..:? "due" <*> (fromMaybe [] <$> o J..:? "payments") + <*> (settledThreshold <$> o J..:? "additionalData") + where + -- read leniently: another plugin's additionalData must not fail the read + settledThreshold = \case + Just (J.Object d) | Just (J.Number n) <- KM.lookup "invoiceSettledConfirmationThreshold" d -> toBoundedInteger n + _ -> Nothing -- | A payment without a value is read, and only its units cannot be counted. data GPayment = GPayment @@ -428,12 +439,13 @@ paymentMethodsSignal now ref status policy body = -- 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 - (m@GPaymentMethod {gpmRate, gpmPaid, gpmDue, gpmPayments}, cc) <- chooseMethod ref ms + (m@GPaymentMethod {gpmRate, gpmPaid, gpmDue, gpmPayments, gpmSettledThreshold}, cc) <- chooseMethod ref ms rate <- priced "rate" gpmRate paid <- priced "paymentMethodPaid" gpmPaid let decimals = unitDecimals cc confirming = maybe False (`elem` map speedPolicyName confirmingPolicies) policy - received = receivedOf decimals confirming (status == "Settled") rate paid gpmDue gpmPayments + shown = cc /= CCXmr || maybe False (>= 1) gpmSettledThreshold + received = receivedOf decimals confirming shown (status == "Settled") rate paid gpmDue gpmPayments case status of "Settled" -> Right (Just (SigSettled received (fromMaybe now (latestSettledAt m)))) "Processing" -> Right (Just (SigFunded received PaidInFull)) @@ -475,8 +487,8 @@ findMethod what ref methodId body = do -- | The confirmed crypto shares paymentMethodPaid's basis, whatever it nets out: all of it once the invoice or every payment is Settled, -- else the Settled payments' value capped at it. An amount with a non-zero digit past its unit leaves every figure in units out. -receivedOf :: Int -> Bool -> Bool -> WireNum -> WireNum -> Maybe WireNum -> [GPayment] -> Received -receivedOf decimals confirming invoiceSettled rate paid due payments = +receivedOf :: Int -> Bool -> Bool -> Bool -> WireNum -> WireNum -> Maybe WireNum -> [GPayment] -> Received +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, @@ -498,6 +510,7 @@ receivedOf decimals confirming invoiceSettled rate paid due payments = uncreditable | isNothing counted = Just UCUncounted | not confirming = Just UCHighSpeed + | not shown = Just UCNoConfirmationShown | otherwise = Nothing toUnits v | v < 0 = Nothing diff --git a/apps/simplex-store-service/src/StoreService/Store/Postgres/Migrations.hs b/apps/simplex-store-service/src/StoreService/Store/Postgres/Migrations.hs index 736ddd3a82..cd805f2fd7 100644 --- a/apps/simplex-store-service/src/StoreService/Store/Postgres/Migrations.hs +++ b/apps/simplex-store-service/src/StoreService/Store/Postgres/Migrations.hs @@ -442,7 +442,7 @@ DROP INDEX @idx_name_balances_reserved_by; DROP TABLE @name_balances; |] --- Why a closed order's late money will not be credited by itself: high_speed, units, rate_floor or unconfirmed. Never cleared. +-- Why a closed order's late money will not be credited by itself: high_speed, units, rate_floor, unconfirmed or no_confirmation. Never cleared. m20261022_name_late_wait :: Text m20261022_name_late_wait = withPrefix diff --git a/apps/simplex-store-service/src/StoreService/Store/SQLite/Migrations.hs b/apps/simplex-store-service/src/StoreService/Store/SQLite/Migrations.hs index 7761b1e838..5c432c0458 100644 --- a/apps/simplex-store-service/src/StoreService/Store/SQLite/Migrations.hs +++ b/apps/simplex-store-service/src/StoreService/Store/SQLite/Migrations.hs @@ -444,7 +444,7 @@ DROP INDEX @idx_name_balances_reserved_by; DROP TABLE @name_balances; |] --- Why a closed order's late money will not be credited by itself: high_speed, units, rate_floor or unconfirmed. Never cleared. +-- Why a closed order's late money will not be credited by itself: high_speed, units, rate_floor, unconfirmed or no_confirmation. Never cleared. m20261022_name_late_wait :: Query m20261022_name_late_wait = withPrefix diff --git a/tests/Bots/StoreService/BTCPayTests.hs b/tests/Bots/StoreService/BTCPayTests.hs index bfee4427f0..5db1ed7c47 100644 --- a/tests/Bots/StoreService/BTCPayTests.hs +++ b/tests/Bots/StoreService/BTCPayTests.hs @@ -82,6 +82,7 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do it "confirms all of paymentMethodPaid when every payment reads Settled, whatever their values" testConfirmedAllSettled it "confirms the Settled payments' value otherwise, rounded to cents once and capped at paymentMethodPaid" testConfirmedSettledSum it "counts BTC in satoshi and XMR in piconero" testConfirmedUnits + it "confirms XMR only when the invoice's settled-confirmation threshold is at least 1, never with 0 or none" testXmrConfirmations it "confirms nothing under HighSpeed, or with no or an unknown speed policy, an invoice-level Settled included" testHighSpeedConfirmsNothing it "accepts trailing zeros past the unit" testTrailingZeros it "drops only the units of an amount with a non-zero digit past its unit, the signal and its cents as before" testDigitPastUnit @@ -144,8 +145,9 @@ paymentOf status value = "fee" .= ("0.00000100" :: Text) ] -xmrPaid :: Text -> [J.Value] -> J.Value -xmrPaid paid payments = +-- | The Monero plugin's method, its additionalData carrying the invoice's settled-confirmation threshold when given. +xmrPaid :: Maybe Int -> Text -> [J.Value] -> J.Value +xmrPaid threshold paid payments = J.object [ "paymentMethodId" .= xmrMethodId, "destination" .= ("44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A" :: Text), @@ -153,7 +155,8 @@ xmrPaid paid payments = "rate" .= ("168.25" :: Text), "paymentMethodPaid" .= paid, "due" .= ("0.00000000" :: Text), - "payments" .= payments + "payments" .= payments, + "additionalData" .= J.object (maybe [] (\n -> ["invoiceSettledConfirmationThreshold" .= n]) threshold) ] testConfirmedInvoiceSettled :: IO () @@ -178,8 +181,20 @@ testConfirmedSettledSum = do testConfirmedUnits :: IO () testConfirmedUnits = do (rcvUnitsOf =<<) <$> signalOf "Settled" [btcPaid "0.00050000" []] `shouldBe` Right (Just 50000) - signalOf "Settled" [xmrPaid "0.32095000" [paymentOf "Settled" "0.32095000"]] - `shouldBe` Right (Just (SigSettled xmrReceived {rcvConfirmed = Confirmed {cfCents = CurrencyAmount 5400, cfUnits = Just 320950000000}} (posixSecondsToUTCTime 1700000000))) + signalOf "Settled" [xmrPaid (Just 1) "0.32095000" [paymentOf "Settled" "0.32095000"]] + `shouldBe` Right (Just (SigSettled xmrConfirmed (posixSecondsToUTCTime 1700000000))) + +xmrConfirmed :: Received +xmrConfirmed = xmrReceived {rcvConfirmed = Confirmed {cfCents = CurrencyAmount 5400, cfUnits = Just 320950000000}, rcvUncreditable = Nothing} + +-- | A Monero payment's own confirmations are not in Greenfield's payment model, so only the invoice's threshold shows one. +testXmrConfirmations :: IO () +testXmrConfirmations = do + let settledWith threshold = signalOf "Settled" [xmrPaid threshold "0.32095000" [paymentOf "Settled" "0.32095000"]] + settled r = Right (Just (SigSettled r (posixSecondsToUTCTime 1700000000))) + settledWith (Just 0) `shouldBe` settled xmrReceived + settledWith Nothing `shouldBe` settled xmrReceived + mapM_ (\n -> settledWith (Just n) `shouldBe` settled xmrConfirmed) [1, 10] rcvUnitsOf :: PaymentSignal -> Maybe Int64 rcvUnitsOf = \case @@ -618,7 +633,7 @@ xmrReceived = rcvUnits = Just 320950000000, rcvRate = Just "168.25", rcvConfirmed = Confirmed {cfCents = CurrencyAmount 0, cfUnits = Just 0}, - rcvUncreditable = Nothing + rcvUncreditable = Just UCNoConfirmationShown } fiftyFourDollars :: OrderDraft diff --git a/tests/Bots/StoreService/NamesLateCreditTests.hs b/tests/Bots/StoreService/NamesLateCreditTests.hs index 175509d4cb..05cb6fbc98 100644 --- a/tests/Bots/StoreService/NamesLateCreditTests.hs +++ b/tests/Bots/StoreService/NamesLateCreditTests.hs @@ -75,6 +75,7 @@ namesLateCreditTests = describe "StoreService names: balance life" $ do it "keeps the confirmed figure and the credit when the settled sum falls, crediting nothing on the same sum again" testFallingSum it "credits an invoice past the read window after a hinted read" testHintPastWindow it "credits Stripe's succeeded amount without reading a rate" testStripeCredited + it "credits late XMR in piconero when the plugin shows a confirmation, and alerts it to support when it shows none" testXmrLate describe "balances with late credits" $ do it "keeps a credit made while the balance is held, the held spend settling" testCreditWhileHeld it "refuses a covered spend that read the amount before a credit" testSpendBeforeCredit @@ -507,6 +508,35 @@ testStripeCredited = withLate $ \l@Late {lStore = st} -> do balanceOf st "c" `shouldReturn` Just (20000, 20000, 0) rateCalls l `shouldReturn` 0 +-- | 0.32095 XMR at the invoice's rate of 168.25, all of it Settled; uncreditable unless the plugin shows a confirmation. +xmrPaid :: Maybe Uncreditable -> Received +xmrPaid uncreditable = + Received + { rcvAmount = CurrencyAmount 5400, + rcvCrypto = Just "0.32095000", + rcvDue = Nothing, + rcvUnits = Just xmrUnits, + rcvRate = Just "168.25", + rcvConfirmed = maybe (Confirmed {cfCents = CurrencyAmount 5400, cfUnits = Just xmrUnits}) (const Confirmed {cfCents = CurrencyAmount 0, cfUnits = Just 0}) uncreditable, + rcvUncreditable = uncreditable + } + where + xmrUnits = 320950000000 + +testXmrLate :: IO () +testXmrLate = withLate $ \l@Late {lStore = st} -> do + mapM_ (\r -> closedOrder l r False) ["xmrshown", "xmrnone"] + withTransaction st $ \db -> DB.execute_ db "UPDATE sx_badge_service_invoices SET payment_crypto_currency = 'xmr' WHERE invoice_id IN ('inv-xmrshown', 'inv-xmrnone')" + setRate l (Right $ rateOf "150" 150) + void $ readSignal l "xmrshown" (SigSettled (xmrPaid Nothing) (at 70)) + creditsOf st "xmrshown" `shouldReturn` [(Just 320950000000, Just "168.25", Just "150", Just "150", 4814)] + void $ readSignal l "xmrnone" (SigSettled (xmrPaid $ Just UCNoConfirmationShown) (at 70)) + balanceOf st "xmrnone" `shouldReturn` Nothing + lateWaitOf st "xmrnone" `shouldReturn` Just LWSupport + now <- getCurrentTime + alertsAt l (Right stubRate) (pastWindow now 60) + >>= (`shouldSatisfy` logged "ERROR" "invoice inv-xmrnone of order xmrnone: 320950000000 piconero received, 0 piconero confirmed, 0 piconero credited; the Monero plugin shows no confirmation") + -- balances with late credits testCreditWhileHeld :: IO ()