diff --git a/apps/simplex-store-service/src/StoreService/Providers.hs b/apps/simplex-store-service/src/StoreService/Providers.hs index c0904094c5..8e5aae52c2 100644 --- a/apps/simplex-store-service/src/StoreService/Providers.hs +++ b/apps/simplex-store-service/src/StoreService/Providers.hs @@ -5,6 +5,9 @@ module StoreService.Providers ( ProviderError (..), WebhookError (..), Received (..), + Confirmed (..), + Uncreditable (..), + Rate (..), PaymentSignal (..), ProviderInvoice (..), Funded (..), @@ -17,10 +20,12 @@ module StoreService.Providers where import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time.Clock (NominalDiffTime, UTCTime) import Network.HTTP.Types.Header (Header) -import Simplex.Chat.PaymentService.Types (CurrencyAmount, PaymentProvider (..), ServicePaymentDestination, ServicePaymentMethod) +import Simplex.Chat.PaymentService.Types (CryptoCurrency, CurrencyAmount, PaymentProvider (..), ServicePaymentDestination, ServicePaymentMethod) newtype ProviderError = ProviderError Text deriving (Eq, Show) @@ -29,7 +34,30 @@ data WebhookError = WebhookError Text | WebhookStale Text deriving (Eq, Show) -- rcvAmount is the total received on the invoice so far, not the amount of one payment. -- rcvDue is the provider's figure for what is still owed. -data Received = Received {rcvAmount :: CurrencyAmount, rcvCrypto :: Maybe Text, rcvDue :: Maybe Text} +-- rcvUnits is the crypto received in integer atomic units, Nothing for card money or crypto that could not be counted in them. +-- rcvRate is the invoice's rate for crypto, as the provider wrote it. +data Received = Received + { rcvAmount :: CurrencyAmount, + rcvCrypto :: Maybe Text, + rcvDue :: Maybe Text, + rcvUnits :: Maybe Int64, + rcvRate :: Maybe Text, + rcvConfirmed :: Confirmed, + rcvUncreditable :: Maybe Uncreditable + } + deriving (Eq, Show) + +-- | The money confirmed so far: its cents at the invoice's rate, and for crypto its atomic units. +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 + 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. +data Rate = Rate {rateText :: Text, rateValue :: Scientific} deriving (Eq, Show) -- The provider applies its own tolerance, so this cannot be recomputed from the amounts. @@ -77,5 +105,7 @@ data Provider = Provider -- Stops the provider from accepting payment for this order. pCancelInvoice :: Text -> IO (Either ProviderError ()), pListOpen :: IO (Either ProviderError ListPass), + -- | Nothing for a provider of card payments, which needs no rate. + pCurrentRate :: Maybe (CryptoCurrency -> IO (Either ProviderError Rate)), pVerifyWebhook :: UTCTime -> [Header] -> ByteString -> Either WebhookError (Maybe Text) } diff --git a/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs b/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs index 3b55fe1190..fef0764691 100644 --- a/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs +++ b/apps/simplex-store-service/src/StoreService/Providers/BTCPay.hs @@ -7,6 +7,7 @@ module StoreService.Providers.BTCPay ( btcpayProvider, btcMethodId, xmrMethodId, + unitDecimals, minorToDecimal, paymentMethodsSignal, listSignals, @@ -16,22 +17,26 @@ module StoreService.Providers.BTCPay ) where -import StoreService.Config (BTCPayConfig (..), speedPolicyName) +import StoreService.Catalog (catalogCurrency) +import StoreService.Config (BTCPayConfig (..), SpeedPolicy (..), speedPolicyName) import StoreService.Providers - ( ListPass (..), + ( Confirmed (..), + ListPass (..), OrderDraft (..), PaymentSignal (..), Provider (..), ProviderError (..), ProviderInvoice (..), Funded (..), + Rate (..), Received (..), + Uncreditable (..), settleWindow, WebhookError (..), ) import Control.Exception (try) import StoreService.Log (logError, logInfo, logWarn) -import Control.Monad (unless) +import Control.Monad (unless, (<=<)) import Crypto.Hash (Digest, SHA256) import Crypto.MAC.HMAC (HMAC, hmac, hmacGetDigest) import qualified Data.Aeson as J @@ -45,8 +50,8 @@ import qualified Data.ByteString.Lazy as LB import Data.Char (toLower) import Data.Int (Int64) import Data.List (find) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Scientific (FPFormat (Fixed), Scientific, base10Exponent, formatScientific) +import Data.Maybe (fromMaybe, isNothing, mapMaybe) +import Data.Scientific (FPFormat (Fixed), Scientific, base10Exponent, formatScientific, scientific, toBoundedInteger) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -74,12 +79,35 @@ import Simplex.Chat.PaymentService.Types ) import Simplex.Messaging.Util (safeDecodeUtf8, tshow) +-- Shapes cited from BTCPay Server v2.4.5 (https://github.com/btcpayserver/btcpayserver/tree/v2.4.5): +-- - payment methods, GET stores/{storeId}/invoices/{invoiceId}/payment-methods: BTCPayServer.Client/Models/InvoicePaymentMethodDataModel.cs, +-- each method's rate, paymentMethodPaid, due, amount, paymentMethodFee and payments, each payment's id, receivedDate, value, fee and +-- status (Invalid, Processing or Settled), the decimals as strings; +-- - 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; +-- - 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 btcMethodId = "BTC-CHAIN" xmrMethodId = "XMR-CHAIN" +methodCurrencies :: [(Text, CryptoCurrency)] +methodCurrencies = [(btcMethodId, CCBtc), (xmrMethodId, CCXmr)] + knownMethodIds :: [Text] -knownMethodIds = [btcMethodId, xmrMethodId] +knownMethodIds = map fst methodCurrencies + +-- | The decimals of each coin's atomic unit: satoshi and piconero. +unitDecimals :: CryptoCurrency -> Int +unitDecimals = \case + CCBtc -> 8 + CCXmr -> 12 + +-- | The policies that settle a payment only after at least one confirmation. +confirmingPolicies :: [SpeedPolicy] +confirmingPolicies = [MediumSpeed, LowMediumSpeed, LowSpeed] -- The last two are the only events a payment into a closed invoice sends. actedOnEventTypes :: [Text] @@ -148,6 +176,7 @@ data GInvoice = GInvoice { giId :: Text, giStatus :: Text, giAdditionalStatus :: Maybe Text, + giSpeedPolicy :: Maybe Text, giPaymentMethods :: Maybe [GPaymentMethod] } deriving (Show) @@ -158,6 +187,7 @@ instance J.FromJSON GInvoice where <$> o J..: "id" <*> o J..: "status" <*> o J..:? "additionalStatus" + <*> (maybe (pure Nothing) (J..:? "speedPolicy") =<< o J..:? "checkout") <*> o J..:? "paymentMethods" -- totalPaid is not decoded because it counts every method's payment in this currency, so it is non-zero @@ -184,15 +214,27 @@ instance J.FromJSON GPaymentMethod where <*> o J..:? "due" <*> (fromMaybe [] <$> o J..:? "payments") +-- | A payment without a value is read, and only its units cannot be counted. data GPayment = GPayment { gpStatus :: Text, - gpReceivedDate :: WireNum + gpReceivedDate :: WireNum, + gpValue :: Maybe WireNum } deriving (Show) instance J.FromJSON GPayment where parseJSON = J.withObject "payment" $ \o -> - GPayment <$> o J..: "status" <*> o J..: "receivedDate" + GPayment <$> o J..: "status" <*> o J..: "receivedDate" <*> o J..:? "value" + +data GRate = GRate + { grPair :: Text, + grErrors :: [Text], + grRate :: Maybe WireNum + } + +instance J.FromJSON GRate where + parseJSON = J.withObject "store rate" $ \o -> + GRate <$> o J..: "currencyPair" <*> (fromMaybe [] <$> o J..:? "errors") <*> o J..:? "rate" newtype GCreated = GCreated {gcId :: Text} deriving (Show) @@ -226,6 +268,7 @@ btcpayProvider cfg = do pReadInvoice = readInvoice env, pCancelInvoice = cancelInvoice env, pListOpen = listOpen env, + pCurrentRate = Just (currentRate env), pVerifyWebhook = const (verifyBTCPaySig (bWebhookSecret cfg)) } @@ -305,11 +348,11 @@ readInvoice env ref = do inv <- greenfield env what methodGet ["invoices", ref] [] Nothing case inv >>= decodeGreenfield what of Left e -> pure (Left e) - Right GInvoice {giStatus, giAdditionalStatus} -> do + Right GInvoice {giStatus, giAdditionalStatus, giSpeedPolicy} -> do logAdditionalStatus ref giAdditionalStatus ms <- greenfield env what methodGet ["invoices", ref, "payment-methods"] [] Nothing now <- getCurrentTime - pure (ms >>= paymentMethodsSignal now ref giStatus) + pure (ms >>= paymentMethodsSignal now ref giStatus giSpeedPolicy) where what = "read invoice" @@ -356,11 +399,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, giPaymentMethods} pass = case giPaymentMethods of + addInvoice GInvoice {giId, giStatus, 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 ms of + Just ms -> case invoiceSignal now giId giStatus 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} @@ -377,17 +420,20 @@ logAdditionalStatus ref = \case Just s | s /= "None" -> logInfo ("btcpay: invoice " <> ref <> " additionalStatus " <> s) _ -> pure () -paymentMethodsSignal :: UTCTime -> Text -> Text -> LB.ByteString -> Either ProviderError (Maybe PaymentSignal) -paymentMethodsSignal now ref status body = - decodeGreenfield "read invoice" body >>= invoiceSignal now ref status +-- | 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 -- Complete is the old API's status name and never matches, so it has no case here. -invoiceSignal :: UTCTime -> Text -> Text -> [GPaymentMethod] -> Either ProviderError (Maybe PaymentSignal) -invoiceSignal now ref status ms = do - m@GPaymentMethod {gpmRate, gpmPaid, gpmDue} <- chooseMethod ref ms +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 rate <- priced "rate" gpmRate paid <- priced "paymentMethodPaid" gpmPaid - let received = receivedOf rate paid gpmDue + let decimals = unitDecimals cc + confirming = maybe False (`elem` map speedPolicyName confirmingPolicies) policy + received = receivedOf decimals confirming (status == "Settled") rate paid gpmDue gpmPayments case status of "Settled" -> Right (Just (SigSettled received (fromMaybe now (latestSettledAt m)))) "Processing" -> Right (Just (SigFunded received PaidInFull)) @@ -399,9 +445,9 @@ invoiceSignal now ref status ms = do priced field = maybe (Left (ProviderError ("btcpay invoice " <> ref <> ": its payment method carries no " <> field))) Right -chooseMethod :: Text -> [GPaymentMethod] -> Either ProviderError GPaymentMethod -chooseMethod ref ms = case filter ((`elem` knownMethodIds) . gpmId) ms of - m : _ -> Right m +chooseMethod :: Text -> [GPaymentMethod] -> Either ProviderError (GPaymentMethod, CryptoCurrency) +chooseMethod ref ms = case [(m, cc) | m <- ms, Just cc <- [lookup (gpmId m) methodCurrencies]] of + known : _ -> Right known [] -> Left . ProviderError $ "btcpay invoice " @@ -427,13 +473,52 @@ findMethod what ref methodId body = do <> T.intercalate ", " (map gpmId ms) <> "]" -receivedOf :: WireNum -> WireNum -> Maybe WireNum -> Received -receivedOf rate paid due = +-- | 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 = Received { rcvAmount = toMinorUnits (wnValue paid * wnValue rate), rcvCrypto = if wnValue paid > 0 then Just (wnText paid) else Nothing, - rcvDue = wnText <$> due + rcvDue = wnText <$> due, + rcvUnits = fst <$> counted, + rcvRate = Just (wnText rate), + rcvConfirmed = case uncreditable of + Nothing -> Confirmed {cfCents = toMinorUnits (scientific (maybe 0 (toInteger . snd) counted) (negate decimals) * wnValue rate), cfUnits = snd <$> counted} + Just _ -> Confirmed {cfCents = CurrencyAmount 0, cfUnits = Just 0}, + rcvUncreditable = uncreditable } + where + settled = filter ((== "Settled") . gpStatus) payments + allSettled = invoiceSettled || (not (null payments) && length settled == length payments) + counted = do + paidUnits <- toUnits (wnValue paid) + settledUnits <- mapM (toUnits . wnValue <=< gpValue) settled + pure (paidUnits, if allSettled then paidUnits else fromInteger (min (toInteger paidUnits) (sum (map toInteger settledUnits)))) + uncreditable + | isNothing counted = Just UCUncounted + | not confirming = Just UCHighSpeed + | otherwise = Nothing + toUnits v + | v < 0 = Nothing + | otherwise = toBoundedInteger (v * scientific 1 decimals) :: Maybe Int64 + +-- | Of the coin against the catalog's currency, as the invoices are priced, so it compares with an invoice's rate. +currentRate :: BTCPayEnv -> CryptoCurrency -> IO (Either ProviderError Rate) +currentRate env cc = (>>= rateOf) <$> greenfield env what methodGet ["rates"] [("currencyPair", Just (TE.encodeUtf8 pair))] Nothing + where + what = "read rate " <> pair + pair = coinCode <> "_" <> T.toUpper catalogCurrency + coinCode = case cc of + CCBtc -> "BTC" + CCXmr -> "XMR" + rateOf body = do + rates :: [GRate] <- decodeGreenfield what body + GRate {grErrors, grRate} <- maybe (failed "the answer has no such pair") Right (find ((== pair) . grPair) rates) + unless (null grErrors) $ failed (T.intercalate "; " grErrors) + WireNum {wnText, wnValue} <- maybe (failed "no rate") Right grRate + if wnValue > 0 then Right Rate {rateText = wnText, rateValue = wnValue} else failed ("the rate " <> wnText <> " is not above 0") + failed e = Left (ProviderError (what <> ": " <> e)) -- Clamp stops a wildly wrong figure wrapping Word32 and coming out small. toMinorUnits :: Scientific -> CurrencyAmount diff --git a/apps/simplex-store-service/src/StoreService/Providers/Stripe.hs b/apps/simplex-store-service/src/StoreService/Providers/Stripe.hs index aff7100cf7..562ba52fe7 100644 --- a/apps/simplex-store-service/src/StoreService/Providers/Stripe.hs +++ b/apps/simplex-store-service/src/StoreService/Providers/Stripe.hs @@ -12,7 +12,8 @@ where import StoreService.Config (StripeConfig (..)) import StoreService.Providers - ( ListPass (..), + ( Confirmed (..), + ListPass (..), OrderDraft (..), PaymentSignal (..), Provider (..), @@ -121,6 +122,7 @@ stripeProvider cfg = do pReadInvoice = readInvoice env, pCancelInvoice = cancelInvoice env, pListOpen = listOpen env, + pCurrentRate = Nothing, pVerifyWebhook = verifyStripeSig (sWebhookSecret cfg) } @@ -263,13 +265,23 @@ readInvoice env pid = do signalOf :: UTCTime -> IntentRead -> Either ProviderError (Maybe PaymentSignal) signalOf now IntentRead {irStatus, irAmountReceived, irChargeCreated} = case irStatus of - "succeeded" -> Right (Just (SigSettled (received irAmountReceived) settledAt)) - "canceled" -> Right (Just (SigClosed (received 0))) + "succeeded" -> Right (Just (SigSettled (received irAmountReceived irAmountReceived) settledAt)) + "canceled" -> Right (Just (SigClosed (received 0 0))) s | s `elem` openStatuses -> Right Nothing | otherwise -> Left (ProviderError ("stripe payment_intent: unknown status " <> s)) where openStatuses = ["requires_payment_method", "requires_confirmation", "requires_action", "processing", "requires_capture"] - received amt = Received {rcvAmount = amountFrom amt, rcvCrypto = Nothing, rcvDue = Nothing} + -- only a succeeded intent's money is confirmed + received amt confirmed = + Received + { rcvAmount = amountFrom amt, + rcvCrypto = Nothing, + rcvDue = Nothing, + rcvUnits = Nothing, + rcvRate = Nothing, + rcvConfirmed = Confirmed {cfCents = amountFrom confirmed, cfUnits = Nothing}, + rcvUncreditable = Nothing + } settledAt = maybe now posixSecondsToUTCTime irChargeCreated -- Clamp stops a wildly wrong figure wrapping Word32 and coming out small. diff --git a/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-alien-method.json b/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-alien-method.json index 3339eb44a8..1a6eeb2c5d 100644 --- a/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-alien-method.json +++ b/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-alien-method.json @@ -49,7 +49,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { @@ -113,7 +113,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { diff --git a/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-alien-status.json b/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-alien-status.json index 28aad30892..017e879493 100644 --- a/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-alien-status.json +++ b/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-alien-status.json @@ -49,7 +49,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { @@ -113,7 +113,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { diff --git a/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-no-id.json b/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-no-id.json index 9a8ed8c97f..cd19e8d26b 100644 --- a/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-no-id.json +++ b/apps/simplex-store-service/test-fixtures/btcpay/invoice-list-no-id.json @@ -49,7 +49,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { @@ -112,7 +112,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { diff --git a/apps/simplex-store-service/test-fixtures/btcpay/invoice-list.json b/apps/simplex-store-service/test-fixtures/btcpay/invoice-list.json index 95d477f14f..0672dd9e88 100644 --- a/apps/simplex-store-service/test-fixtures/btcpay/invoice-list.json +++ b/apps/simplex-store-service/test-fixtures/btcpay/invoice-list.json @@ -49,7 +49,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { @@ -113,7 +113,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.32095000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { @@ -177,7 +177,7 @@ "totalPaid": "0.00000000", "due": "0.00050000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [], "additionalData": {} diff --git a/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-btc.json b/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-btc.json index 83c03dcfd4..952ffb66ac 100644 --- a/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-btc.json +++ b/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-btc.json @@ -11,7 +11,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { diff --git a/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-no-amount.json b/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-no-amount.json index d1c4129ce2..59b51638bc 100644 --- a/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-no-amount.json +++ b/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-no-amount.json @@ -10,7 +10,7 @@ "paymentMethodPaid": "0.00000000", "totalPaid": "0.00000000", "due": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [], "additionalData": {} diff --git a/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-no-destination.json b/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-no-destination.json index 4dc67e6170..4ca3d37bdb 100644 --- a/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-no-destination.json +++ b/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-no-destination.json @@ -9,7 +9,7 @@ "totalPaid": "0.00000000", "due": "0.00050000", "amount": "0.00050000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": false, "payments": [], "additionalData": {} diff --git a/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-xmr.json b/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-xmr.json index c68256f3d7..e825040420 100644 --- a/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-xmr.json +++ b/apps/simplex-store-service/test-fixtures/btcpay/payment-methods-xmr.json @@ -11,7 +11,7 @@ "totalPaid": "9.99999999", "due": "0.00000000", "amount": "0.32095000", - "networkFee": "0.00000500", + "paymentMethodFee": "0.00000500", "activated": true, "payments": [ { diff --git a/tests/Bots/StoreService/BTCPayTests.hs b/tests/Bots/StoreService/BTCPayTests.hs index 268faca7e8..bfee4427f0 100644 --- a/tests/Bots/StoreService/BTCPayTests.hs +++ b/tests/Bots/StoreService/BTCPayTests.hs @@ -14,14 +14,18 @@ import StoreService.Providers Provider (..), ProviderError (..), ProviderInvoice (..), + Rate (..), Received (..), + Confirmed (..), + Uncreditable (..), WebhookError (..), settleWindow, ) import StoreService.Providers.BTCPay (btcMethodId, btcpayProvider, listSignals, minorToDecimal, paymentMethodsSignal, verifyBTCPaySig, xmrMethodId) +import StoreService.Config (SpeedPolicy (..)) import Bots.StoreService.FakeBTCPay import Control.Exception (evaluate) -import Control.Monad (join) +import Control.Monad (forM_, join) import Data.Aeson ((.=)) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as KM @@ -29,6 +33,8 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB import Data.Char (toUpper) import Data.Foldable (toList) +import Data.Int (Int64) +import Data.Word (Word32) import Data.Scientific (Scientific, scientific) import Data.Text (Text) import qualified Data.Text as T @@ -71,6 +77,14 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do it "keeps the crypto amount exactly as the provider wrote it" testCryptoAmountVerbatim it "multiplies the decimals exactly, where a Double would be a cent out" testExactDecimalMultiplication it "reads a numeric field sent as a JSON number as well as a string" testNumberAsWellAsString + describe "confirmed money" $ do + it "confirms all of paymentMethodPaid on an invoice-level Settled, with a payment still Processing" testConfirmedInvoiceSettled + 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 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 describe "the list pass" $ do it "skips an invoice whose status it does not know, and settles the rest" testListSkipsUnknownStatus it "skips an invoice it cannot parse, and settles the rest" testListSkipsUnparseable @@ -106,7 +120,11 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do it "makes a 500 on a read a ProviderError the next read recovers from" testFakeRead500 it "verifies a webhook with the secret it was configured with" testFakeWebhookSecretWiring it "keeps totalPaid distinguishable in every fixture an amount is asserted from" testFixturesGuardTotalPaid - it "keeps due distinguishable from networkFee, so the wrong field cannot be read" testFixturesGuardDue + it "keeps due distinguishable from paymentMethodFee, so the wrong field cannot be read" testFixturesGuardDue + describe "rates and speed policies against the fake Greenfield" $ do + it "reads the store's rate for the coin against the catalog's currency" testFakeRate + it "refuses a failed read, a missing pair, a rate with errors, a null rate and a rate at or below 0" testFakeRateRefusals + it "reads the speed policy an invoice was made under, whatever the configuration says now" testFakeInvoicePolicy describe "the list pass against the fake Greenfield" $ do it "returns the invoices whose state moved and omits the one that did not" testFakeListMoved it "bounds the request at 72 hours plus one invoice window" testFakeListWindow @@ -115,6 +133,81 @@ badgeBTCPayTests = describe "badge btcpay adapter" $ do it "fails the pass when the payment methods are absent" testFakeListNoPaymentMethods it "skips an invoice it cannot even name, unaccounted for" testFakeListNoId +-- | A payment of the value given, as the methods body lists it. +paymentOf :: Text -> Text -> J.Value +paymentOf status value = + J.object + [ "id" .= ("txid-" <> value), + "status" .= status, + "receivedDate" .= (1700000000 :: Int), + "value" .= value, + "fee" .= ("0.00000100" :: Text) + ] + +xmrPaid :: Text -> [J.Value] -> J.Value +xmrPaid paid payments = + J.object + [ "paymentMethodId" .= xmrMethodId, + "destination" .= ("44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A" :: Text), + "amount" .= ("0.32095000" :: Text), + "rate" .= ("168.25" :: Text), + "paymentMethodPaid" .= paid, + "due" .= ("0.00000000" :: Text), + "payments" .= payments + ] + +testConfirmedInvoiceSettled :: IO () +testConfirmedInvoiceSettled = + signalOf "Settled" [btcPaid "0.00050000" [paymentOf "Settled" "0.00025000", paymentOf "Processing" "0.00025000"]] + `shouldBe` Right (Just (SigSettled halfMilliBtc (posixSecondsToUTCTime 1700000000))) + +-- | The values sum to more than paymentMethodPaid, as a fee BTCPay nets out would; all of it is confirmed, never more. +testConfirmedAllSettled :: IO () +testConfirmedAllSettled = + signalOf "Processing" [btcPaid "0.00049800" [paymentOf "Settled" "0.00025000", paymentOf "Settled" "0.00025000"]] + `shouldBe` Right (Just (SigFunded (btcReceived 5378 (Just "0.00049800") "0.00050000" 49800 49800 5378) PaidInFull)) + +-- | 5 + 5 satoshi are 0.54 + 0.54 cents, 2 cents rounded one by one but 1 rounded once. +testConfirmedSettledSum :: IO () +testConfirmedSettledSum = do + signalOf "Processing" [btcPaid "0.00000015" (map (paymentOf "Settled") ["0.00000005", "0.00000005"] <> [paymentOf "Processing" "0.00000005"])] + `shouldBe` Right (Just (SigFunded (btcReceived 2 (Just "0.00000015") "0.00050000" 15 10 1) PaidInFull)) + signalOf "Processing" [btcPaid "0.00050000" [paymentOf "Settled" "0.00030000", paymentOf "Settled" "0.00030000", paymentOf "Processing" "0.00010000"]] + `shouldBe` Right (Just (SigFunded halfMilliBtc PaidInFull)) + +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))) + +rcvUnitsOf :: PaymentSignal -> Maybe Int64 +rcvUnitsOf = \case + SigFunded r _ -> rcvUnits r + SigSettled r _ -> rcvUnits r + SigClosed r -> rcvUnits r + +testHighSpeedConfirmsNothing :: IO () +testHighSpeedConfirmsNothing = do + let settledUnder policy = signalUnder policy "Settled" [btcPaid "0.00050000" [paymentOf "Settled" "0.00050000"]] + unconfirmed = halfMilliBtcUnconfirmed {rcvUncreditable = Just UCHighSpeed} + mapM_ (\policy -> (policy, settledUnder policy) `shouldBe` (policy, Right (Just (SigSettled unconfirmed (posixSecondsToUTCTime 1700000000))))) [Just "HighSpeed", Nothing, Just "Turbo"] + mapM_ (\policy -> (policy, settledUnder policy) `shouldBe` (policy, Right (Just (SigSettled halfMilliBtc (posixSecondsToUTCTime 1700000000))))) [Just "MediumSpeed", Just "LowMediumSpeed", Just "LowSpeed"] + +testTrailingZeros :: IO () +testTrailingZeros = + signalOf "Settled" [btcPaid "0.000500000000" [paymentOf "Settled" "0.0005000000000"]] + `shouldBe` Right (Just (SigSettled halfMilliBtc {rcvCrypto = Just "0.000500000000", rcvDue = Just "0.00050000"} (posixSecondsToUTCTime 1700000000))) + +-- | A badge invoice reads and settles on this signal as before; only a late credit needs the units. +testDigitPastUnit :: IO () +testDigitPastUnit = do + let uncounted crypto due = halfMilliBtcUnconfirmed {rcvCrypto = Just crypto, rcvDue = Just due, rcvUnits = Nothing, rcvUncreditable = Just UCUncounted} + signalOf "Settled" [btcPaid "0.000500001" [paymentOf "Settled" "0.000500001"]] + `shouldBe` Right (Just (SigSettled (uncounted "0.000500001" "0.00050000") (posixSecondsToUTCTime 1700000000))) + signalOf "Processing" [btcPaid "0.00050000" [paymentOf "Settled" "0.000250001", paymentOf "Processing" "0.00025000"]] + `shouldBe` Right (Just (SigFunded (uncounted "0.00050000" "0.00000000") PaidInFull)) + testMinorToDecimal :: IO () testMinorToDecimal = map (minorToDecimal . CurrencyAmount) [0, 5, 99, 100, 700, 4200, 42000, 100000000] @@ -136,7 +229,7 @@ btcPaid paid payments = "paymentMethodPaid" .= paid, "totalPaid" .= ("9.99999999" :: Text), "due" .= dueAfter paid, - "networkFee" .= ("0.00000500" :: Text), + "paymentMethodFee" .= ("0.00000500" :: Text), "payments" .= payments ] @@ -163,13 +256,33 @@ methodsBody :: [J.Value] -> LB.ByteString methodsBody = J.encode signalOf :: Text -> [J.Value] -> Either ProviderError (Maybe PaymentSignal) -signalOf status methods = paymentMethodsSignal readTime ref status (methodsBody methods) +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) + +-- | 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 +btcReceived cents crypto due units confirmedUnits confirmedCents = + Received + { rcvAmount = CurrencyAmount cents, + rcvCrypto = crypto, + rcvDue = Just due, + rcvUnits = Just units, + rcvRate = Just "108000.12", + rcvConfirmed = Confirmed {cfCents = CurrencyAmount confirmedCents, cfUnits = Just confirmedUnits}, + rcvUncreditable = Nothing + } halfMilliBtc :: Received -halfMilliBtc = Received {rcvAmount = CurrencyAmount 5400, rcvCrypto = Just "0.00050000", rcvDue = Just "0.00000000"} +halfMilliBtc = btcReceived 5400 (Just "0.00050000") "0.00000000" 50000 50000 5400 + +halfMilliBtcUnconfirmed :: Received +halfMilliBtcUnconfirmed = halfMilliBtc {rcvConfirmed = Confirmed {cfCents = CurrencyAmount 0, cfUnits = Just 0}} nothingReceived :: Text -> Received -nothingReceived due = Received {rcvAmount = CurrencyAmount 0, rcvCrypto = Nothing, rcvDue = Just due} +nothingReceived due = btcReceived 0 Nothing due 0 0 0 testSettled :: IO () testSettled = @@ -184,24 +297,24 @@ testSettledManuallyMarked = testProcessing :: IO () testProcessing = signalOf "Processing" [btcPaid "0.00050000" [payment "Processing" 1700000000]] - `shouldBe` Right (Just (SigFunded halfMilliBtc PaidInFull)) + `shouldBe` Right (Just (SigFunded halfMilliBtcUnconfirmed PaidInFull)) testClosed :: IO () testClosed = do signalOf "Expired" [btcPaid "0.00050000" [payment "Processing" 1700000000]] - `shouldBe` Right (Just (SigClosed halfMilliBtc)) + `shouldBe` Right (Just (SigClosed halfMilliBtcUnconfirmed)) signalOf "Invalid" [btcPaid "0.00000000" []] `shouldBe` Right (Just (SigClosed (nothingReceived "0.00050000"))) testNewWithPayment :: IO () testNewWithPayment = signalOf "New" [btcPaid "0.00050000" [payment "Processing" 1700000000]] - `shouldBe` Right (Just (SigFunded halfMilliBtc PaidInPart)) + `shouldBe` Right (Just (SigFunded halfMilliBtcUnconfirmed PaidInPart)) testNewWithDust :: IO () testNewWithDust = signalOf "New" [btcPaid "0.00000001" [payment "Processing" 1700000000]] - `shouldBe` Right (Just (SigFunded Received {rcvAmount = CurrencyAmount 0, rcvCrypto = Just "0.00000001", rcvDue = Just "0.00050499"} PaidInPart)) + `shouldBe` Right (Just (SigFunded (btcReceived 0 (Just "0.00000001") "0.00050499" 1 0 0) PaidInPart)) testNewWithNothing :: IO () testNewWithNothing = signalOf "New" [btcPaid "0.00000000" []] `shouldBe` Right Nothing @@ -229,7 +342,7 @@ testAbsurdExponentAsANumberIsRefused = do "rate" .= ("108000.12" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text), "due" .= ("0.00000000" :: Text), - "networkFee" .= ("0.00000500" :: Text), + "paymentMethodFee" .= ("0.00000500" :: Text), "payments" .= ([] :: [J.Value]) ] answered <- timeout 5000000 (evaluate (signalOf "Settled" [method])) @@ -251,7 +364,7 @@ testLongRateIsAccepted = "rate" .= ("0.3333333333333333333333333333" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text), "due" .= ("0.00000000" :: Text), - "networkFee" .= ("0.00000500" :: Text), + "paymentMethodFee" .= ("0.00000500" :: Text), "payments" .= ([] :: [J.Value]) ] @@ -271,7 +384,7 @@ testUnknownPaymentMethod = do testUnreadableResponse :: IO () testUnreadableResponse = - paymentMethodsSignal readTime ref "Settled" "502 Bad Gateway" `shouldSatisfy` namesInError "could not read the response" + paymentMethodsSignal readTime ref "Settled" (Just "MediumSpeed") "502 Bad Gateway" `shouldSatisfy` namesInError "could not read the response" namesInError :: Text -> Either ProviderError a -> Bool namesInError what = \case @@ -285,7 +398,8 @@ listEntry invId status methods = "status" .= status, "additionalStatus" .= ("None" :: Text), "amount" .= ("54.00" :: Text), - "currency" .= ("USD" :: Text) + "currency" .= ("USD" :: Text), + "checkout" .= J.object ["speedPolicy" .= ("MediumSpeed" :: Text)] ] <> maybe [] (\ms -> ["paymentMethods" .= ms]) methods @@ -328,7 +442,7 @@ testListSkipsUnparseable = do "rate" .= ("108000.12" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text), "due" .= ("0.00000000" :: Text), - "networkFee" .= ("0.00000500" :: Text), + "paymentMethodFee" .= ("0.00000500" :: Text), "payments" .= [J.object ["receivedDate" .= (1700000000 :: Int)]] ] broken = listEntry "MALFORMEDINVOICE" "Settled" (Just [noStatus]) @@ -418,7 +532,7 @@ testNumberAsWellAsString = do let asNumbers = "[{\"paymentMethodId\":\"BTC-CHAIN\",\"rate\":108000.12,\"paymentMethodPaid\":0.00050000,\ \\"payments\":[{\"status\":\"Settled\",\"receivedDate\":1700000000}]}]" - case paymentMethodsSignal readTime ref "Settled" asNumbers of + case paymentMethodsSignal readTime ref "Settled" (Just "MediumSpeed") asNumbers of Right (Just (SigSettled r t)) -> do rcvAmount r `shouldBe` CurrencyAmount 5400 rcvCrypto r `shouldBe` Just "0.00050000" @@ -496,7 +610,16 @@ listSettledRef = "SettledInvoiceRefAAAA" listProcessingRef = "ProcessingInvoiceRefB" xmrReceived :: Received -xmrReceived = Received {rcvAmount = CurrencyAmount 5400, rcvCrypto = Just "0.32095000", rcvDue = Just "0.00000000"} +xmrReceived = + Received + { rcvAmount = CurrencyAmount 5400, + rcvCrypto = Just "0.32095000", + rcvDue = Just "0.00000000", + rcvUnits = Just 320950000000, + rcvRate = Just "168.25", + rcvConfirmed = Confirmed {cfCents = CurrencyAmount 0, cfUnits = Just 0}, + rcvUncreditable = Nothing + } fiftyFourDollars :: OrderDraft fiftyFourDollars = @@ -600,21 +723,24 @@ testFakeLifecycle = withProvider $ \fake p -> do pReadInvoice p invRef `shouldReturn` Right Nothing setInvoiceState fake invRef ["paymentMethodPaid" .= ("0.00025000" :: Text)] pReadInvoice p invRef - `shouldReturn` Right (Just (SigFunded Received {rcvAmount = CurrencyAmount 2700, rcvCrypto = Just "0.00025000", rcvDue = Just "0.00000000"} PaidInPart)) + `shouldReturn` Right (Just (SigFunded quarterMilliBtc PaidInPart)) setInvoiceState fake invRef ["status" .= ("Processing" :: Text), "additionalStatus" .= ("PaidPartial" :: Text)] pReadInvoice p invRef - `shouldReturn` Right (Just (SigFunded Received {rcvAmount = CurrencyAmount 2700, rcvCrypto = Just "0.00025000", rcvDue = Just "0.00000000"} PaidInFull)) + `shouldReturn` Right (Just (SigFunded quarterMilliBtc PaidInFull)) setInvoiceState fake invRef ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)] pReadInvoice p invRef `shouldReturn` Right (Just (SigSettled halfMilliBtc fixtureSettledAt)) details <- apiRequests fake "GET" ["invoices", invRef] methods <- apiRequests fake "GET" ["invoices", invRef, "payment-methods"] (length details, length methods) `shouldBe` (4, 5) +quarterMilliBtc :: Received +quarterMilliBtc = btcReceived 2700 (Just "0.00025000") "0.00000000" 25000 0 0 + 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 halfMilliBtc)) + pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed halfMilliBtcUnconfirmed)) setInvoiceState fake invRef ["status" .= ("Invalid" :: Text), "paymentMethodPaid" .= ("0.00000000" :: Text)] pReadInvoice p invRef `shouldReturn` Right (Just (SigClosed (nothingReceived "0.00050000"))) @@ -721,7 +847,7 @@ testFixturesGuardTotalPaid = totalPaidStaysDistinguishable ["payment-methods-btc", "payment-methods-xmr", "invoice-list", "invoice-list-alien-status", "invoice-list-alien-method"] --- | With due equal to networkFee a fixture cannot tell which field the adapter reads, and +-- | With due equal to paymentMethodFee a fixture cannot tell which field the adapter reads, and -- reading the fee would report a part-paid invoice as covered. dueStaysDistinguishable :: HasCallStack => Text -> IO () dueStaysDistinguishable name = do @@ -730,7 +856,7 @@ dueStaysDistinguishable name = do [] -> expectationFailure (T.unpack name <> " carries no payment method") ms -> mapM_ distinguishable ms where - distinguishable m = case (KM.lookup "due" m, KM.lookup "networkFee" m) of + distinguishable m = case (KM.lookup "due" m, KM.lookup "paymentMethodFee" m) of (Just d, Just f) -> d `shouldNotBe` f _ -> pure () @@ -740,6 +866,41 @@ testFixturesGuardDue = dueStaysDistinguishable ["payment-methods-btc", "payment-methods-xmr", "invoice-list", "invoice-list-alien-status", "invoice-list-alien-method"] +testFakeRate :: IO () +testFakeRate = withProvider $ \fake p -> do + readRate <- maybe (failWith "btcpay offers no current rate") pure (pCurrentRate p) + readRate CCBtc `shouldReturn` Right (Rate "108000.12" 108000.12) + setRates fake (J.toJSON [rateEntry "XMR_USD" [] (Just "168.25")]) + readRate CCXmr `shouldReturn` Right (Rate "168.25" 168.25) + map (lookup "currencyPair" . frQuery) <$> apiRequests fake "GET" ["rates"] `shouldReturn` [Just (Just "BTC_USD"), Just (Just "XMR_USD")] + +rateEntry :: Text -> [Text] -> Maybe Text -> J.Value +rateEntry pair errors rate = J.object ["currencyPair" .= pair, "errors" .= errors, "rate" .= rate] + +testFakeRateRefusals :: IO () +testFakeRateRefusals = withProvider $ \fake p -> do + readRate <- maybe (failWith "btcpay offers no current rate") pure (pCurrentRate p) + failNextCalls fake 1 500 + readRate CCBtc >>= (`shouldSatisfy` namesInError "HTTP 500") + let refusedFor answer what = do + setRates fake (J.toJSON answer) + readRate CCBtc >>= (`shouldSatisfy` namesInError what) + refusedFor [rateEntry "XMR_USD" [] (Just "168.25")] "BTC_USD" + refusedFor [rateEntry "BTC_USD" ["coingecko: rate limited"] Nothing] "rate limited" + refusedFor [rateEntry "BTC_USD" [] Nothing] "no rate" + refusedFor [rateEntry "BTC_USD" [] (Just "0")] "not above 0" + refusedFor [rateEntry "BTC_USD" [] (Just "-108000.12")] "not above 0" + +testFakeInvoicePolicy :: IO () +testFakeInvoicePolicy = withFakeBTCPay $ \fake -> do + highSpeed <- btcpayProvider (fbConfig fake) {bSpeedPolicy = HighSpeed} + mediumSpeed <- btcpayProvider (fbConfig fake) + ProviderInvoice {piProviderRef = madeHigh} <- createdInvoice highSpeed (SPMCrypto CCBtc) + ProviderInvoice {piProviderRef = madeMedium} <- createdInvoice mediumSpeed (SPMCrypto CCBtc) + forM_ [madeHigh, madeMedium] $ \r -> setInvoiceState fake r ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)] + pReadInvoice mediumSpeed madeHigh `shouldReturn` Right (Just (SigSettled halfMilliBtcUnconfirmed {rcvUncreditable = Just UCHighSpeed} fixtureSettledAt)) + pReadInvoice highSpeed madeMedium `shouldReturn` Right (Just (SigSettled halfMilliBtc fixtureSettledAt)) + testFakeListMoved :: IO () testFakeListMoved = withProvider $ \_ p -> pListOpen p diff --git a/tests/Bots/StoreService/FakeBTCPay.hs b/tests/Bots/StoreService/FakeBTCPay.hs index b9bf45d954..839198d5d3 100644 --- a/tests/Bots/StoreService/FakeBTCPay.hs +++ b/tests/Bots/StoreService/FakeBTCPay.hs @@ -10,6 +10,7 @@ module Bots.StoreService.FakeBTCPay fakeApiKey, fakeExpiryMinutes, setInvoiceState, + setRates, failNextCalls, failAfterCalls, useListFixture, @@ -98,12 +99,16 @@ data FakeRequest = FakeRequest } deriving (Eq, Show) +-- | isSpeedPolicy: the checkout's speedPolicy the invoice was created with. isPayments: the payments set by a test, else one of all +-- that was paid, Settled once the invoice is. data InvoiceState = InvoiceState { isMethodId :: Text, isStatus :: Text, isAdditionalStatus :: Text, isPaid :: Maybe Text, - isDue :: Maybe Text + isDue :: Maybe Text, + isSpeedPolicy :: Maybe Text, + isPayments :: Maybe J.Value } deriving (Eq, Show) @@ -118,6 +123,8 @@ data FakeState = FakeState fsMethods :: Maybe Text, fsIgnorePaging :: Bool, fsOversize :: Bool, + -- | The rates answer set by a test, else each pair asked at the fixtures' rate. + fsRates :: Maybe J.Value, fsRequests :: [FakeRequest] } @@ -131,6 +138,7 @@ initialState = fsMethods = Nothing, fsIgnorePaging = False, fsOversize = False, + fsRates = Nothing, fsRequests = [] } @@ -222,16 +230,20 @@ btcMethod = "BTC-CHAIN" xmrMethod = "XMR-CHAIN" patchInvoice :: Text -> InvoiceState -> J.Value -> J.Value -patchInvoice invId InvoiceState {isStatus, isAdditionalStatus} = +patchInvoice invId InvoiceState {isStatus, isAdditionalStatus, isSpeedPolicy} v = setField "id" (J.String invId) . setField "status" (J.String isStatus) . setField "additionalStatus" (J.String isAdditionalStatus) + . setField "checkout" (setField "speedPolicy" (maybe J.Null J.String isSpeedPolicy) (fromMaybe (J.object []) (objectField "checkout" v))) + $ v +-- | The fixtures' payments were written for a settled invoice, so the payments follow the state instead. patchMethods :: InvoiceState -> J.Value -> J.Value -patchMethods InvoiceState {isPaid, isDue} = \case +patchMethods InvoiceState {isStatus, isPaid, isDue, isPayments} = \case J.Array vs -> J.Array (fmap one vs) other -> other where + paidStatus = if isStatus == "Settled" then "Settled" else "Processing" :: Text one = \case J.Object o -> let paid = fromMaybe (fixturePaid o) isPaid @@ -241,12 +253,20 @@ patchMethods InvoiceState {isPaid, isDue} = \case due = if isZero paid then isDue <|> textField "amount" o else isDue withPaid = KM.insert "paymentMethodPaid" (J.String paid) o withDue = maybe withPaid (\d -> KM.insert "due" (J.String d) withPaid) due - in J.Object (if isZero paid then KM.insert "payments" (J.Array mempty) withDue else withDue) + payments + | Just ps <- isPayments = ps + | isZero paid = J.Array mempty + | otherwise = J.toJSON [J.object ["id" J..= ("faketx-" <> paid), "receivedDate" J..= settledDate, "value" J..= paid, "fee" J..= ("0.00000000" :: Text), "status" J..= paidStatus]] + in J.Object (KM.insert "payments" payments withDue) v -> v fixturePaid o = case KM.lookup "paymentMethodPaid" o of Just (J.String t) -> t _ -> "0" +-- | The fixtures' settlement time. +settledDate :: Int +settledDate = 1700003600 + isZero :: Text -> Bool isZero t = (J.decodeStrict (TE.encodeUtf8 t) :: Maybe Scientific) == Just 0 @@ -264,6 +284,7 @@ fakeApp stv req respond = do ["_fixtures"] | isPost -> control body setFixtures ["_paging"] | isPost -> control body setPaging ["_oversize"] | isPost -> control body setOversize + ["_rates"] | isPost -> setRatesAnswer body "api" : "v1" : "stores" : storeId : rest -> apiCall body storeId rest _ -> refuse notFound404 "no such path on the fake btcpay" where @@ -292,7 +313,8 @@ fakeApp stv req respond = do { isStatus = fromMaybe (isStatus inv) (textField "status" o), isAdditionalStatus = fromMaybe (isAdditionalStatus inv) (textField "additionalStatus" o), isPaid = maybe (isPaid inv) Just (textField "paymentMethodPaid" o), - isDue = maybe (isDue inv) Just (textField "due" o) + isDue = maybe (isDue inv) Just (textField "due" o), + isPayments = maybe (isPayments inv) Just (KM.lookup "payments" o) } writeTVar stv st {fsInvoices = M.insert invId inv' (fsInvoices st)} pure Nothing @@ -325,6 +347,10 @@ fakeApp stv req respond = do fsListOf name st = st {fsList = name} fsMethodsOf name st = st {fsMethods = Just name} + setRatesAnswer body = case J.decode body of + Just v -> atomically (modifyTVar' stv (\st -> st {fsRates = Just v})) >> ok + Nothing -> refuse badRequest400 "_rates takes the answer to serve, as JSON" + setOversize o = case unknownKeys ["on"] o of Just message -> pure (Just message) Nothing -> case KM.lookup "on" o of @@ -370,6 +396,7 @@ fakeApp stv req respond = do greenfield body = \case ["payment-methods"] | isGet -> serve "store-payment-methods" id + ["rates"] | isGet -> rates ["invoices"] | isPost -> createInvoice body ["invoices"] | isGet -> listInvoices ["invoices", invId] | isGet -> @@ -380,6 +407,13 @@ fakeApp stv req respond = do serve (fromMaybe (methodsFixture (isMethodId inv)) override) (patchMethods inv) _ -> refuse notFound404 "no such greenfield path on the fake btcpay" + rates = do + answer <- fsRates <$> readTVarIO stv + let asked = [TE.decodeUtf8 pair | ("currencyPair", Just pair) <- queryString req] + respond . jsonResponse ok200 $ fromMaybe (J.toJSON (map fixtureRate asked)) answer + fixtureRate pair = J.object ["currencyPair" J..= pair, "errors" J..= ([] :: [Text]), "rate" J..= lookup pair fixtureRates] + fixtureRates = [("BTC_USD", "108000.12"), ("XMR_USD", "168.25") :: (Text, Text)] + listInvoices = do st <- readTVarIO stv fixture <- fixtureResponse (fsList st) @@ -429,7 +463,10 @@ fakeApp stv req respond = do { isMethodId = methodId, isStatus = "New", isAdditionalStatus = "None", - isPaid = Just "0.00000000", isDue = Nothing + isPaid = Just "0.00000000", + isDue = Nothing, + isSpeedPolicy = J.decode body >>= objectField "checkout" >>= objectField "speedPolicy" >>= asText, + isPayments = Nothing } writeTVar stv st {fsNextId = fsNextId st + 1, fsInvoices = M.insert invId inv (fsInvoices st)} pure (invId, inv) @@ -447,7 +484,7 @@ intQuery :: ByteString -> Query -> Maybe Int intQuery k q = join (lookup k q) >>= readMaybe . B8.unpack stateKeys :: [Key] -stateKeys = ["status", "additionalStatus", "paymentMethodPaid", "due"] +stateKeys = ["status", "additionalStatus", "paymentMethodPaid", "due", "payments"] unknownKeys :: [Key] -> J.Object -> Maybe Text unknownKeys known o = case filter (`notElem` known) (KM.keys o) of @@ -461,6 +498,11 @@ chosenMethod v = case objectField "checkout" v >>= objectField "paymentMethods" _ -> Nothing _ -> Nothing +asText :: J.Value -> Maybe Text +asText = \case + J.String t -> Just t + _ -> Nothing + objectField :: Key -> J.Value -> Maybe J.Value objectField k = \case J.Object o -> KM.lookup k o @@ -505,6 +547,10 @@ failAfterCalls skip fake calls code = answerOversize :: FakeBTCPay -> Bool -> IO () answerOversize fake on = controlPost fake "/_oversize" (J.object ["on" J..= on]) +-- | The rates call answers this from now on. +setRates :: FakeBTCPay -> J.Value -> IO () +setRates fake = controlPost fake "/_rates" + useListFixture :: FakeBTCPay -> Text -> IO () useListFixture fake name = controlPost fake "/_fixtures" (J.object ["list" J..= name]) diff --git a/tests/Bots/StoreService/StripeTests.hs b/tests/Bots/StoreService/StripeTests.hs index 773df83c05..94b8fcfcdb 100644 --- a/tests/Bots/StoreService/StripeTests.hs +++ b/tests/Bots/StoreService/StripeTests.hs @@ -6,7 +6,8 @@ module Bots.StoreService.StripeTests (badgeStripeTests) where import StoreService.Config (StripeConfig (..)) import StoreService.Providers - ( ListPass (..), + ( Confirmed (..), + ListPass (..), OrderDraft (..), PaymentSignal (..), Provider (..), @@ -23,6 +24,8 @@ import Data.Aeson ((.=)) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB import Data.Either (isLeft) +import Data.Maybe (isNothing) +import Data.Word (Word32) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) @@ -55,6 +58,7 @@ badgeStripeTests = describe "badge stripe adapter" $ do it "refuses a crypto method, since Stripe offers none" testRefusesCrypto it "makes an unknown intent status a ProviderError, not a silent no-signal" testFakeReadUnknownStatus it "settles a succeeded intent with no charge at read time" testSettledNoChargeReadTime + it "confirms only a succeeded intent's amount, and reads no rate" testConfirmedOnlySucceeded describe "listing intents to settle" $ do it "lists by a created window, never status=open" testFakeListWindow it "moves the settled and canceled intents, at read time, leaving the open one" testFakeListsOpen @@ -73,10 +77,23 @@ fiftyFourDollars :: OrderDraft fiftyFourDollars = OrderDraft {odAmount = CurrencyAmount 5400, odCurrency = "usd"} fiftyFourDollarsReceived :: Received -fiftyFourDollarsReceived = Received {rcvAmount = CurrencyAmount 5400, rcvCrypto = Nothing, rcvDue = Nothing} +fiftyFourDollarsReceived = cardReceived 5400 5400 nothingReceived :: Received -nothingReceived = Received {rcvAmount = CurrencyAmount 0, rcvCrypto = Nothing, rcvDue = Nothing} +nothingReceived = cardReceived 0 0 + +-- | Cents received and confirmed, with no units or rate. +cardReceived :: Word32 -> Word32 -> Received +cardReceived cents confirmed = + Received + { rcvAmount = CurrencyAmount cents, + rcvCrypto = Nothing, + rcvDue = Nothing, + rcvUnits = Nothing, + rcvRate = Nothing, + rcvConfirmed = Confirmed {cfCents = CurrencyAmount confirmed, cfUnits = Nothing}, + rcvUncreditable = Nothing + } fixtureChargeAt :: UTCTime fixtureChargeAt = posixSecondsToUTCTime 1700000000 @@ -214,6 +231,14 @@ testSettledNoChargeReadTime = do let ir = IntentRead {irId = "pi_test_x", irStatus = "succeeded", irAmountReceived = 5400, irChargeCreated = Nothing} signalOf now ir `shouldBe` Right (Just (SigSettled fiftyFourDollarsReceived now)) +testConfirmedOnlySucceeded :: IO () +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))) + withProvider $ \_ p -> isNothing (pCurrentRate p) `shouldBe` True + -- | A status=open query returns only open intents, which carry no signal, so the poll lists by -- creation time instead to catch a settlement the webhook missed. The window reaches back the -- settle window plus an intent's own lifetime. diff --git a/tests/Bots/StoreService/WebTests.hs b/tests/Bots/StoreService/WebTests.hs index 03e0d7c07e..69c5a4b2f2 100644 --- a/tests/Bots/StoreService/WebTests.hs +++ b/tests/Bots/StoreService/WebTests.hs @@ -842,6 +842,7 @@ data StubCall | StubRead Text | StubCancel Text | StubListOpen + | StubRate CryptoCurrency deriving (Eq, Show) data StubState = StubState @@ -857,7 +858,8 @@ data StubState = StubState ssVerifyResult :: Either WebhookError (Maybe Text), ssVerifyThrows :: Bool, ssWebhooks :: [([Header], ByteString)], - ssReadDelay :: Int + ssReadDelay :: Int, + ssRate :: Either ProviderError Rate } newStubState :: Either ProviderError ProviderInvoice -> StubState @@ -874,9 +876,14 @@ newStubState ssCreateResult = ssVerifyResult = Right Nothing, ssVerifyThrows = False, ssWebhooks = [], - ssReadDelay = 0 + ssReadDelay = 0, + ssRate = Right stubRate } +-- | Below the stored invoices' rate of 62500. +stubRate :: Rate +stubRate = Rate {rateText = "60000.5", rateValue = 60000.5} + record :: IORef StubState -> StubCall -> IO () record ref call = atomicModifyIORef' ref $ \s -> (s {ssCalls = ssCalls s ++ [call]}, ()) @@ -906,6 +913,9 @@ stubProvider ref = pure $ case ssListError stub of Just e -> Left e Nothing -> Right ListPass {lpMoved = Map.toList (ssInvoices stub), lpSkipped = ssSkipped stub}, + pCurrentRate = Just $ \cc -> do + record ref (StubRate cc) + ssRate <$> readIORef ref, pVerifyWebhook = const (verifyRecording ref) } @@ -2124,8 +2134,18 @@ replayAt = addUTCTime 3600 settleAt detectedAt :: UTCTime detectedAt = addUTCTime 300 settleAt +-- | Nothing confirmed and no units, as the badge paths read it. rcv :: Word32 -> Maybe Text -> Received -rcv amount crypto = Received {rcvAmount = CurrencyAmount amount, rcvCrypto = crypto, rcvDue = Nothing} +rcv amount crypto = + Received + { rcvAmount = CurrencyAmount amount, + rcvCrypto = crypto, + rcvDue = Nothing, + rcvUnits = Nothing, + rcvRate = Nothing, + rcvConfirmed = Confirmed {cfCents = CurrencyAmount 0, cfUnits = Nothing}, + rcvUncreditable = Nothing + } settle :: DBStore -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus) settle st iid signal at = newWaiters >>= \waiters -> settleOrder st waiters Nothing iid signal at