store: read confirmed money and rates at providers

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)
   }

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

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.

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": [
             {

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": [
             {

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": [
             {

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": {}

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": [
         {

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": {}

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": {}

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": [
         {

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" "<html>502 Bad Gateway</html>" `shouldSatisfy` namesInError "could not read the response"
+  paymentMethodsSignal readTime ref "Settled" (Just "MediumSpeed") "<html>502 Bad Gateway</html>" `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

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])
 

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.

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