store: merge the balance's life

2026-11-04 10:47:32 +00:00 · 2026-10-22 16:41:51 +00:00
commit 71e0674dbb
@@ -0,0 +1,96 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | The credit of a closed order's late money to its balance: only confirmed money not yet credited, crypto at the lower
+-- of the invoice's rate and the current one. The rate is read outside any transaction, so the credit runs after the
+-- settlement that recorded the money commits, and again from the poller's pass for whatever is still not credited.
+module StoreService.Names.LateCredits
+  ( CreditOutcome (..),
+    minCurrentRateFraction,
+    creditLateInvoice,
+    lateCreditOf,
+  )
+where
+
+import Data.Ratio ((%))
+import Data.Scientific (Scientific)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime)
+import Simplex.Chat.PaymentService.Types (CryptoCurrency, InvoiceId)
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import StoreService.Names.Store (LateCredit (..), LateCreditState (..), LateSupport (..), NamePhase (..), creditLatePayment, lateCreditState, setLateSupport)
+import StoreService.Providers (ProviderError (..), Rate (..), unitDecimals)
+import StoreService.Store.Invoices (lockInvoice)
+import Text.Read (readMaybe)
+
+-- | A current rate below this fraction of the invoice's is not used: it may be a glitch or a real fall, which the owner decides on.
+minCurrentRateFraction :: Rational
+minCurrentRateFraction = 1 % 2
+
+-- | CONoInvoiceRate: crypto due with no invoice rate recorded to credit it at. CORefused: the credit's number was taken meanwhile,
+-- which the invoice's lock rules out.
+data CreditOutcome
+  = CONothingDue
+  | COCredited LateCredit
+  | CONoInvoiceRate
+  | CORateFailed ProviderError
+  | CORateFloor Text Rate
+  | CORefused
+  deriving (Eq, Show)
+
+creditLateInvoice :: DBStore -> (CryptoCurrency -> IO (Either ProviderError Rate)) -> InvoiceId -> UTCTime -> IO CreditOutcome
+creditLateInvoice st readRate invId now =
+  withTransaction st (`lateCreditState` invId) >>= \case
+    Just s | creditable s && moneyDue s -> case lsCoin s of
+      Nothing -> credit Nothing
+      Just coin -> case invoiceRate s of
+        Nothing -> pure CONoInvoiceRate
+        Just (invoiceText, invoiceValue) ->
+          readRate coin >>= \case
+            Left e -> pure $ CORateFailed e
+            Right rate
+              | toRational (rateValue rate) < minCurrentRateFraction * toRational invoiceValue ->
+                  CORateFloor invoiceText rate <$ withTransaction st (\db -> setLateSupport db invId LSRateFloor)
+              | otherwise -> credit (Just rate)
+    _ -> pure CONothingDue
+  where
+    credit rate = withTransaction st $ \db -> do
+      lockInvoice db invId now
+      lateCreditState db invId >>= \case
+        Just s | creditable s, Just c <- lateCreditOf s rate -> do
+          applied <- creditLatePayment db c now
+          pure $ if applied then COCredited c else CORefused
+        _ -> pure CONothingDue
+
+-- | A closed order's money, unless a rate below the floor sent it to support for good, so a later recovery cannot credit money refunded by hand.
+creditable :: LateCreditState -> Bool
+creditable LateCreditState {lsPhase, lsLive, lsSupport} = lsPhase == PUnpaid && not lsLive && lsSupport /= Just LSRateFloor
+
+moneyDue :: LateCreditState -> Bool
+moneyDue s@LateCreditState {lsConfirmedCents, lsCreditedCents} = case lsCoin s of
+  Nothing -> lsConfirmedCents > lsCreditedCents
+  Just _ -> unitsDue s > 0
+
+unitsDue :: LateCreditState -> Integer
+unitsDue LateCreditState {lsConfirmedUnits, lsCreditedUnits} = maybe 0 toInteger lsConfirmedUnits - toInteger lsCreditedUnits
+
+invoiceRate :: LateCreditState -> Maybe (Text, Scientific)
+invoiceRate LateCreditState {lsInvoiceRate} = lsInvoiceRate >>= \t -> (t,) <$> readMaybe (T.unpack t)
+
+-- | The next credit of the money not yet credited: card cents as they are, crypto units at the lower rate, rounded down to the cent.
+lateCreditOf :: LateCreditState -> Maybe Rate -> Maybe LateCredit
+lateCreditOf s@LateCreditState {lsInvoice, lsRegistration, lsCredits, lsConfirmedCents, lsCreditedCents} rate = case (lsCoin s, rate, invoiceRate s) of
+  (Nothing, _, _)
+    | lsConfirmedCents > lsCreditedCents -> Just (credit Nothing Nothing Nothing Nothing (lsConfirmedCents - lsCreditedCents))
+  (Just coin, Just Rate {rateText, rateValue}, Just (invoiceText, invoiceValue))
+    | unitsDue s > 0 ->
+        let (usedText, usedValue) = if rateValue < invoiceValue then (rateText, rateValue) else (invoiceText, invoiceValue)
+            cents = floor (fromInteger (unitsDue s) * toRational usedValue * 100 / 10 ^ unitDecimals coin)
+         in Just (credit (Just $ fromInteger $ unitsDue s) (Just invoiceText) (Just rateText) (Just usedText) cents)
+  _ -> Nothing
+  where
+    credit lcUnits lcInvoiceRate lcCurrentRate lcRateUsed lcCents =
+      LateCredit {lcInvoice = lsInvoice, lcCreditNo = lsCredits + 1, lcRegistration = lsRegistration, lcUnits, lcInvoiceRate, lcCurrentRate, lcRateUsed, lcCents}
@@ -70,8 +70,8 @@ import StoreService.Names.Env (NamesEnv (..))
 import StoreService.Names.Phases (Phases, RegistrationId (..))
 import StoreService.Names.Abi (bytes32FromHex, hex)
 import StoreService.Names.Signatures (OrderFields (..), orderMessage, parseChecksumAddress, parseSignature, personalDigest)
-import StoreService.Names.Store (Balance, LiveOrder (..), NamePhase (..), NameRegistration (..), NewRegistration (..), PrepaidCode (..), RegistrationPayment (..), RegistrationRefused (..), NameTransaction (..), TxFor (..), TxStatus (..), VersionWrite (..), closeOverdue, createCodeRegistration, getBalance, getLiveOrders, getPrepaidCode, getPrepaidCodeById, getRegistration, getRegistrationByOrderHash, isLabelRegistering, registrationTransactions, retargetRegistration, updateRegistration)
-import StoreService.Names.Turns (Turns, withCodeTurn)
+import StoreService.Names.Store (Balance, LiveOrder (..), NamePhase (..), NameRegistration (..), NewRegistration (..), PrepaidCode (..), RegistrationPayment (..), RegistrationRefused (..), NameTransaction (..), TxFor (..), TxStatus (..), VersionWrite (..), closeOverdue, createCodeRegistration, creditBalance, getBalance, getLiveOrders, getPrepaidCode, getPrepaidCodeById, getRegistration, getRegistrationByOrderHash, isLabelRegistering, registrationTransactions, retargetRegistration, updateRegistration)
+import StoreService.Names.Turns (Turns, withBalanceTurn, withCodeTurn)

 data OrdersEnv = OrdersEnv
  { oeStore :: DBStore,
@@ -276,11 +276,9 @@ checkPrice ct len years price =
 unixSeconds :: UTCTime -> Integer
 unixSeconds = floor . utcTimeToPOSIXSeconds

-- | A paid order that lost its name, any failed order, and one whose reveal was refused for its links can move to another name.
+-- | A failed order, and one whose reveal was refused for its links, can move to another name.
 movable :: NameRegistration -> Bool
-movable NameRegistration {nrPhase, nrPayment, nrLinksRefusedAt} = case nrPhase of
-  PTaken | RPInvoice {} <- nrPayment -> True
-  PTaken | RPBalance <- nrPayment -> True
+movable NameRegistration {nrPhase, nrLinksRefusedAt} = case nrPhase of
  PFailed -> True
  PCommitted -> isJust nrLinksRefusedAt
  _ -> False
@@ -305,13 +303,17 @@ checkMovePrice ct NameRegistration {nrPrice, nrYears} len =
      | otherwise -> pure $ Right price

 -- | The move's write, a compare-and-set on the version read. A code order's code is checked and reserved again in the code's turn.
+-- A paid order moved to a cheaper name keeps the difference as its balance, credited in the move's transaction and the balance's turn.
 retargetOrder :: OrdersEnv -> NameRegistration -> OrderFields -> Int -> IO (Either WriteRefusal Int64)
-retargetOrder OrdersEnv {oeStore, oeTurns, oeNow} r@NameRegistration {nrId, nrPayment} fields@OrderFields {ofLength} price = do
+retargetOrder OrdersEnv {oeStore, oeTurns, oeNow} r@NameRegistration {nrId, nrPayment, nrPrice} fields@OrderFields {ofLength} price = do
  now <- oeNow
  let write db = versionWritten <$> retargetRegistration db r fields price now
+      paidMove
+        | price < nrPrice = withBalanceTurn oeTurns nrId $ withTransaction oeStore $ \db -> write db >>= traverse (\v -> v <$ creditBalance db nrId (nrPrice - price) now)
+        | otherwise = withTransaction oeStore write
  case nrPayment of
-    RPInvoice {} -> withTransaction oeStore write
-    RPBalance -> withTransaction oeStore write
+    RPInvoice {} -> paidMove
+    RPBalance -> paidMove
    RPCode codeId ->
      withTransaction oeStore (`getPrepaidCodeById` codeId) >>= \case
        Nothing -> pure $ Left $ WRRefused $ ORCode CRInvalid
@@ -23,6 +23,8 @@ module StoreService.Names.Store
    LateCreditState (..),
    LatePending (..),
    LateAlert (..),
+    LateSupport (..),
+    LateWait (..),
    CleanupKept (..),
    PrepaidCode (..),
    NewPrepaidCode (..),
@@ -71,6 +73,8 @@ module StoreService.Names.Store
    uncreditedLateInvoices,
    lateAlertDue,
    claimLateAlert,
+    setLateSupport,
+    lateWait,
    insertPrepaidCode,
    getPrepaidCode,
    getPrepaidCodeById,
@@ -126,7 +130,7 @@ import StoreService.Names.Chain (TxHash (..))
 import StoreService.Names.Phases (RegistrationId (..))
 import StoreService.Names.Signatures (OrderFields (..), parseSignature)
 import StoreService.Store (RevokeResult (..))
-import StoreService.Store.Invoices (StoreDecodeError (..), executeChanging, invoiceStatusText, lockInvoice, newInvoiceId, truncateToSecond, unfundedQuery)
+import StoreService.Store.Invoices (StoreDecodeError (..), executeChanging, invoiceStatusText, lockInvoice, newInvoiceId, textToCryptoCurrency, truncateToSecond, unfundedQuery)

 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
@@ -262,10 +266,12 @@ data Balance = Balance
  deriving (Eq, Show)

 -- | The order whose open invoice holds a balance, until that invoice expires; overdue past it with no money received.
+-- Funded once money reached it: it then holds until its payment settles or the provider closes it, whatever the time.
 data BalanceHold = BalanceHold
  { bhHolder :: RegistrationId,
    bhUntil :: UTCTime,
-    bhOverdue :: Bool
+    bhOverdue :: Bool,
+    bhFunded :: Bool
  }
  deriving (Eq, Show)

@@ -293,13 +299,15 @@ data LateCredit = LateCredit
  }
  deriving (Eq, Show)

-- | A name invoice's payment figures, what was credited from it, and its order's phase and live flag. Card money is counted in cents, crypto in units.
+-- | A name invoice's payment figures, what was credited from it, and its order's phase and live flag. Card money (no coin) is counted in cents,
+-- crypto in units. lsSupport: why its money will not be credited by itself, once known.
 data LateCreditState = LateCreditState
  { lsInvoice :: InvoiceId,
    lsRegistration :: RegistrationId,
    lsPhase :: NamePhase,
    lsLive :: Bool,
-    lsCard :: Bool,
+    lsCoin :: Maybe CryptoCurrency,
+    lsSupport :: Maybe LateSupport,
    lsReceivedCents :: Int,
    lsConfirmedCents :: Int,
    lsReceivedUnits :: Maybe Int64,
@@ -327,6 +335,28 @@ instance TextEncoding LatePending where

 instance FromField LatePending where fromField = fromTextField_ textDecode

+-- | What a closed order's late money waits on, for the view: confirmation, the credit, or support.
+data LateWait = LWConfirming | LWCrediting | LWSupport
+  deriving (Eq, Show)
+
+-- | Why a closed order's money will not be credited by itself: an invoice made under HighSpeed, an amount that could not be counted in units,
+-- a current rate below the floor, unconfirmed money alerted past the read window, or money the provider shows no confirmation of.
+data LateSupport = LSHighSpeed | LSUnits | LSRateFloor | LSUnconfirmed | LSNoConfirmation
+  deriving (Eq, Show, Enum, Bounded)
+
+instance TextEncoding LateSupport where
+  textEncode = \case
+    LSHighSpeed -> "high_speed"
+    LSUnits -> "units"
+    LSRateFloor -> "rate_floor"
+    LSUnconfirmed -> "unconfirmed"
+    LSNoConfirmation -> "no_confirmation"
+  textDecode t = lookup t [(textEncode s, s) | s <- [minBound .. maxBound]]
+
+instance FromField LateSupport where fromField = fromTextField_ textDecode
+
+instance ToField LateSupport where toField = toField . textEncode
+
 -- | A closed order's pending money to alert on, with the received figure the alert names and the one the last alert named.
 data LateAlert = LateAlert
  { laState :: LateCreditState,
@@ -683,19 +713,16 @@ closeOverdue db r@NameRegistration {nrId = regId@(RegistrationId rid), nrVersion

 -- | Whether an order can still progress to a registration for its name. The unique live indexes allow one such order per commitment,
 -- and one per owner and label hash, so a wallet can order a name again once its registration is done.
-- An unpaid order is live while its invoice is open, which nrLive carries; a paid order that lost its name can move to another one.
+-- An unpaid order is live while its invoice is open, which nrLive carries; a taken order is final, its worth kept as a balance.
 orderLive :: NameRegistration -> Bool
-orderLive NameRegistration {nrPhase, nrPayment, nrLive} = case nrPhase of
+orderLive NameRegistration {nrPhase, nrLive} = case nrPhase of
  PUnpaid -> nrLive
  PQueued -> True
  PCommitting -> True
  PCommitted -> True
  PRegistering -> True
  PFailed -> True
-  PTaken -> case nrPayment of
-    RPInvoice {} -> True
-    RPBalance -> True
-    RPCode _ -> False
+  PTaken -> False
  PRegistered -> False

 -- | Writes every changeable field of a registration read at its nrVersion, unless it changed since, with live as orderLive decides.
@@ -762,12 +789,26 @@ retargetRegistration db r OrderFields {ofLabelHash, ofLength, ofDuration, ofComm
      }

 -- | Newest first: findLimit of them, then every older one holding a balance above 0, since a balance never expires.
-findRegistrations :: DB.Connection -> Address -> IO [NameRegistration]
-findRegistrations db owner = do
-  newest <- DB.query db (selectRegistrations <> " WHERE r.owner = ?" <> newestFirst <> " LIMIT ?") (Binary $ unAddress owner, findLimit) >>= decodeAll toRegistration
-  holding <- DB.query db (selectRegistrations <> " WHERE r.owner = ?" <> withBalance <> newestFirst) (Only $ Binary $ unAddress owner) >>= decodeAll toRegistration
-  pure $ newest <> filter ((`notElem` map nrId newest) . nrId) holding
+-- Each with the order holding its balance, as getBalance reads the hold at the given time.
+findRegistrations :: DB.Connection -> Address -> UTCTime -> IO [(NameRegistration, Maybe RegistrationId)]
+findRegistrations db owner now = do
+  newest <- DB.query db (selectHeld <> " WHERE r.owner = ?" <> newestFirst <> " LIMIT ?") (holdParams :. (Binary $ unAddress owner, findLimit)) >>= decodeAll found
+  holding <- DB.query db (selectHeld <> " WHERE r.owner = ?" <> withBalance <> newestFirst) (holdParams :. Only (Binary $ unAddress owner)) >>= decodeAll found
+  pure $ newest <> filter ((`notElem` map (nrId . fst) newest) . nrId . fst) holding
  where
+    selectHeld =
+      registrationColumns
+        <> ", (SELECT b.reserved_by FROM sx_badge_service_name_balances b"
+        <> " JOIN sx_badge_service_name_registrations h ON h.registration_id = b.reserved_by"
+        <> " JOIN sx_badge_service_name_invoices hni ON hni.registration_id = b.reserved_by"
+        <> " JOIN sx_badge_service_invoices i ON i.invoice_id = hni.invoice_id"
+        <> " WHERE b.registration_id = r.registration_id AND NOT ("
+        <> holdOverdue
+        <> "))"
+        <> registrationFrom
+    holdParams = (PUnpaid, invoiceStatusText ISPaid, truncateToSecond now)
+    found :: RegistrationRow :. Only (Maybe Text) -> Either Text (NameRegistration, Maybe RegistrationId)
+    found (row :. Only holder) = (\r -> (r, RegistrationId <$> holder)) <$> toRegistration row
    newestFirst = " ORDER BY r.created_at DESC, r.registration_id DESC"
    withBalance = " AND EXISTS (SELECT 1 FROM sx_badge_service_name_balances b WHERE b.registration_id = r.registration_id AND b.amount > 0)"

@@ -846,16 +887,22 @@ heldBy Balance {blHold} = case blHold of
  Just BalanceHold {bhOverdue = False} -> blHold
  _ -> Nothing

-- | A holder is overdue as getLiveOrders reads an order overdue: its invoice past its expiry, not paid, and holding no money.
+-- | A holder h with invoice i is overdue as getLiveOrders reads an order overdue: its invoice past its expiry, not paid, and holding no money.
+-- Takes the unpaid phase, the paid status and the time.
+holdOverdue :: Query
+holdOverdue = " h.phase = ? AND i.status <> ? AND i.expires_at < ?" <> unfunded
+
 getBalance :: DB.Connection -> RegistrationId -> UTCTime -> IO (Maybe Balance)
 getBalance db (RegistrationId rid) now =
  firstDecoded toBalance $
    DB.query
      db
      ( "SELECT b.registration_id, b.amount, b.credited, b.refunded, b.reserved_by, i.expires_at,"
-          <> " CASE WHEN h.phase = ? AND i.status <> ? AND i.expires_at < ?"
+          <> " CASE WHEN"
+          <> holdOverdue
+          <> " THEN 1 ELSE 0 END, CASE WHEN i.invoice_id IS NOT NULL"
          <> unfunded
-          <> " THEN 1 ELSE 0 END, b.refunded_at"
+          <> " THEN 0 ELSE 1 END, b.refunded_at"
          <> " FROM sx_badge_service_name_balances b"
          <> " LEFT JOIN sx_badge_service_name_registrations h ON h.registration_id = b.reserved_by"
          <> " LEFT JOIN sx_badge_service_name_invoices ni ON ni.registration_id = b.reserved_by"
@@ -864,11 +911,11 @@ getBalance db (RegistrationId rid) now =
      )
      (PUnpaid, invoiceStatusText ISPaid, truncateToSecond now, rid)

-toBalance :: (Text, Int, Int, Int, Maybe Text, Maybe UTCTime, BoolInt, Maybe UTCTime) -> Either Text Balance
-toBalance (rid, blAmount, blCredited, blRefunded, holder_, until_, BI overdue, blRefundedAt) = do
+toBalance :: (Text, Int, Int, Int, Maybe Text, Maybe UTCTime, BoolInt, BoolInt, Maybe UTCTime) -> Either Text Balance
+toBalance (rid, blAmount, blCredited, blRefunded, holder_, until_, BI bhOverdue, BI bhFunded, blRefundedAt) = do
  blHold <- case (holder_, until_) of
    (Nothing, _) -> Right Nothing
-    (Just holder, Just bhUntil) -> Right $ Just BalanceHold {bhHolder = RegistrationId holder, bhUntil, bhOverdue = overdue}
+    (Just holder, Just bhUntil) -> Right $ Just BalanceHold {bhHolder = RegistrationId holder, bhUntil, bhOverdue, bhFunded}
    (Just _, Nothing) -> Left $ "name_balances holder without an invoice: " <> rid
  pure Balance {blRegistration = RegistrationId rid, blAmount, blCredited, blRefunded, blHold, blRefundedAt}

@@ -1046,25 +1093,26 @@ receivedFigure = " CASE WHEN" <> cardInvoice <> " THEN p.amount ELSE COALESCE(p.

 lateColumns :: Query
 lateColumns =
-  "SELECT ni.invoice_id, ni.registration_id, r.phase, r.live, CASE WHEN" <> cardInvoice <> " THEN 1 ELSE 0 END, COALESCE(p.amount, 0), p.confirmed_amount,"
+  "SELECT ni.invoice_id, ni.registration_id, r.phase, r.live, i.payment_crypto_currency, ni.late_support, COALESCE(p.amount, 0), p.confirmed_amount,"
    <> " p.received_units, p.confirmed_units, p.invoice_rate,"
    <> creditedTotal "units"
    <> ","
    <> creditedTotal "cents"
    <> ", (SELECT COUNT(*) FROM sx_badge_service_name_late_credits c WHERE c.invoice_id = ni.invoice_id), p.created_at"

-type LateRow = (Text, Text, NamePhase, BoolInt, BoolInt, Int, Int, Maybe Int64, Maybe Int64, Maybe Text) :. (Int64, Int, Int, UTCTime)
+type LateRow = (Text, Text, NamePhase, BoolInt, Maybe Text, Maybe LateSupport, Int, Int, Maybe Int64, Maybe Int64) :. (Maybe Text, Int64, Int, Int, UTCTime)

-toLateState :: LateRow -> LateCreditState
+toLateState :: LateRow -> Either Text LateCreditState
 toLateState
-  ( (inv, reg, lsPhase, BI lsLive, BI lsCard, lsReceivedCents, lsConfirmedCents, lsReceivedUnits, lsConfirmedUnits, lsInvoiceRate)
-      :. (lsCreditedUnits, lsCreditedCents, lsCredits, lsPaymentCreatedAt)
-    ) =
-    LateCreditState {lsInvoice = InvoiceId inv, lsRegistration = RegistrationId reg, lsPhase, lsLive, lsCard, lsReceivedCents, lsConfirmedCents, lsReceivedUnits, lsConfirmedUnits, lsInvoiceRate, lsCreditedUnits, lsCreditedCents, lsCredits, lsPaymentCreatedAt}
+  ( (inv, reg, lsPhase, BI lsLive, coin_, lsSupport, lsReceivedCents, lsConfirmedCents, lsReceivedUnits, lsConfirmedUnits)
+      :. (lsInvoiceRate, lsCreditedUnits, lsCreditedCents, lsCredits, lsPaymentCreatedAt)
+    ) = do
+    lsCoin <- traverse (\c -> note ("invoices.payment_crypto_currency: " <> c) (textToCryptoCurrency c)) coin_
+    pure LateCreditState {lsInvoice = InvoiceId inv, lsRegistration = RegistrationId reg, lsPhase, lsLive, lsCoin, lsSupport, lsReceivedCents, lsConfirmedCents, lsReceivedUnits, lsConfirmedUnits, lsInvoiceRate, lsCreditedUnits, lsCreditedCents, lsCredits, lsPaymentCreatedAt}

 -- | Nothing without a payment row.
 lateCreditState :: DB.Connection -> InvoiceId -> IO (Maybe LateCreditState)
-lateCreditState db (InvoiceId invId) = maybeFirstRow toLateState $ DB.query db (lateColumns <> lateFrom <> " WHERE ni.invoice_id = ?") (Only invId)
+lateCreditState db (InvoiceId invId) = firstDecoded toLateState $ DB.query db (lateColumns <> lateFrom <> " WHERE ni.invoice_id = ?") (Only invId)

 -- | Run after the invoice's lock. The order's balance is credited only when the credit's row is new, so a taken credit number changes neither.
 creditLatePayment :: DB.Connection -> LateCredit -> UTCTime -> IO Bool
@@ -1089,11 +1137,29 @@ latePending db (InvoiceId invId) =
  maybe Nothing fromOnly . listToMaybe
    <$> DB.query db ("SELECT" <> pendingCase <> lateFrom <> " WHERE ni.invoice_id = ? AND" <> closedUnpaid) (invId, PUnpaid)

-- | Closed orders' invoices with confirmed money not all credited, for the poller's credit pass.
+-- | Nothing once all of the closed order's money is credited, whatever support reason was given before.
+lateWait :: DB.Connection -> InvoiceId -> IO (Maybe LateWait)
+lateWait db (InvoiceId invId) =
+  maybe Nothing waitOf . listToMaybe
+    <$> DB.query db ("SELECT" <> pendingCase <> ", ni.late_support" <> lateFrom <> " WHERE ni.invoice_id = ? AND" <> closedUnpaid) (invId, PUnpaid)
+  where
+    waitOf :: (Maybe LatePending, Maybe LateSupport) -> Maybe LateWait
+    waitOf = \case
+      (Nothing, _) -> Nothing
+      (Just _, Just _) -> Just LWSupport
+      (Just LPUncounted, Nothing) -> Just LWSupport
+      (Just LPUncredited, Nothing) -> Just LWCrediting
+      (Just LPConfirming, Nothing) -> Just LWConfirming
+      (Just LPUnconfirmed, Nothing) -> Just LWConfirming
+
+-- | Closed orders' invoices with confirmed money not all credited, for the poller's credit pass; none a rate below the floor sent to support.
 uncreditedLateInvoices :: DB.Connection -> IO [InvoiceId]
 uncreditedLateInvoices db =
  map (InvoiceId . fromOnly)
-    <$> DB.query db ("SELECT ni.invoice_id" <> lateFrom <> " WHERE" <> closedUnpaid <> " AND" <> uncreditedMoney <> " ORDER BY p.created_at, ni.invoice_id") (Only PUnpaid)
+    <$> DB.query
+      db
+      ("SELECT ni.invoice_id" <> lateFrom <> " WHERE" <> closedUnpaid <> " AND" <> uncreditedMoney <> " AND (ni.late_support IS NULL OR ni.late_support <> ?) ORDER BY p.created_at, ni.invoice_id")
+      (PUnpaid, LSRateFloor)

 -- | Pending money whose payment row was created before the cutoff, never alerted, or alerted for less money than now received.
 lateAlertDue :: DB.Connection -> UTCTime -> IO [LateAlert]
@@ -1120,22 +1186,29 @@ lateAlertDue db cutoff =
  where
    toAlert :: LateRow :. (Maybe LatePending, Maybe Int64, Maybe UTCTime, Maybe Int64) -> Either Text LateAlert
    toAlert (row :. (pending_, laReceived, laAlertedAt, laAlertedReceived)) = case pending_ of
-      Just laPending -> Right LateAlert {laState = toLateState row, laPending, laReceived, laAlertedAt, laAlertedReceived}
+      Just laPending -> (\laState -> LateAlert {laState, laPending, laReceived, laAlertedAt, laAlertedReceived}) <$> toLateState row
      Nothing -> Left "name invoice alert without pending money"

-- | Marks the alert sent, unless another instance marked it since it was read; only the instance that marks it logs it.
-claimLateAlert :: DB.Connection -> LateAlert -> UTCTime -> IO Bool
-claimLateAlert db LateAlert {laState = LateCreditState {lsInvoice = InvoiceId invId}, laReceived, laAlertedAt, laAlertedReceived} now =
+-- | Marks the alert sent, with the support reason it gives unless one is set, unless another instance marked it since it was read;
+-- only the instance that marks it logs it.
+claimLateAlert :: DB.Connection -> LateAlert -> Maybe LateSupport -> UTCTime -> IO Bool
+claimLateAlert db LateAlert {laState = LateCreditState {lsInvoice = InvoiceId invId}, laReceived, laAlertedAt, laAlertedReceived} support now =
  (> 0)
    <$> executeChanging
      db
-      ( "UPDATE sx_badge_service_name_invoices SET late_alerted_at = ?, late_alerted_units = ? WHERE invoice_id = ? AND late_alerted_at"
+      ( "UPDATE sx_badge_service_name_invoices SET late_alerted_at = ?, late_alerted_units = ?, late_support = COALESCE(late_support, ?)"
+          <> " WHERE invoice_id = ? AND late_alerted_at"
          <> notDistinctFrom
          <> "? AND late_alerted_units"
          <> notDistinctFrom
          <> "?"
      )
-      (truncateToSecond now, laReceived, invId, laAlertedAt, laAlertedReceived)
+      (truncateToSecond now, laReceived, support, invId, laAlertedAt, laAlertedReceived)
+
+-- | The first reason given stays.
+setLateSupport :: DB.Connection -> InvoiceId -> LateSupport -> IO ()
+setLateSupport db (InvoiceId invId) support =
+  DB.execute db "UPDATE sx_badge_service_name_invoices SET late_support = COALESCE(late_support, ?) WHERE invoice_id = ?" (support, invId)

 insertPrepaidCode :: DB.Connection -> NewPrepaidCode -> UTCTime -> IO (Either CodeHashTaken Int64)
 insertPrepaidCode db NewPrepaidCode {npcCodeHash, npcMinLength, npcYears, npcPaymentStatus, npcExpiresAt} now = do
@@ -36,7 +36,7 @@ import StoreService.Names.Abi (hex)
 import StoreService.Names.Chain (TxHash (..))
 import StoreService.Names.Contracts (Contracts, sponsorNonce)
 import StoreService.Names.Phases (RegistrationId (..))
-import StoreService.Names.Store (Balance (..), BalanceHold (..), NamePhase (..), NameRegistration (..), NameReveal (..), getBalance, getRegistration, heldBy)
+import StoreService.Names.Store (Balance (..), BalanceHold (..), LateWait (..), NamePhase (..), NameRegistration (..), NameReveal (..), RegistrationPayment (..), getBalance, getRegistration, heldBy, lateWait)

 -- | The view's chain reads; a field whose read failed is null and named in vrUnread.
 data ViewReads = ViewReads
@@ -45,11 +45,16 @@ data ViewReads = ViewReads
  }
  deriving (Eq, Show)

-- | The balance as it reads at the given time, when a hold may have become overdue.
+-- | The balance as it reads at the given time, when a hold may have become overdue, and what a closed order's late money waits on.
 registrationView :: DBStore -> NamesConfig -> Contracts -> UTCTime -> NameRegistration -> IO J.Value
 registrationView st cfg ct now r = do
-  balance <- withTransaction st $ \db -> getBalance db (nrId r) now
-  viewJSON cfg r balance <$> readViewChain ct r
+  (balance, late) <- withTransaction st $ \db -> do
+    balance <- getBalance db (nrId r) now
+    late <- case nrPayment r of
+      RPInvoice _ invId -> lateWait db invId
+      _ -> pure Nothing
+    pure (balance, late)
+  viewJSON cfg r balance late <$> readViewChain ct r

 -- | The intent nonce only in committed.
 readViewChain :: Contracts -> NameRegistration -> IO ViewReads
@@ -61,8 +66,8 @@ readViewChain ct NameRegistration {nrPhase, nrOwner} = case nrPhase of
  where
    none = ViewReads {vrIntentNonce = Nothing, vrUnread = []}

-viewJSON :: NamesConfig -> NameRegistration -> Maybe Balance -> ViewReads -> J.Value
-viewJSON NamesConfig {nTLD, nChain = ChainConfig {cChainId, cResolver, cSponsor}} r balance ViewReads {vrIntentNonce, vrUnread} =
+viewJSON :: NamesConfig -> NameRegistration -> Maybe Balance -> Maybe LateWait -> ViewReads -> J.Value
+viewJSON NamesConfig {nTLD, nChain = ChainConfig {cChainId, cResolver, cSponsor}} r balance late ViewReads {vrIntentNonce, vrUnread} =
  J.object
    [ "id" .= rid,
      "version" .= nrVersion,
@@ -83,6 +88,7 @@ viewJSON NamesConfig {nTLD, nChain = ChainConfig {cChainId, cResolver, cSponsor}
      "price" .= nrPrice,
      "fromBalance" .= nrBalanceUsed,
      "balance" .= (balanceJSON <$> balance),
+      "latePayment" .= ((\w -> J.object ["waiting" .= waitingText w]) <$> late),
      "commitTx" .= (txText <$> nrCommitTx),
      "registerTx" .= (txText <$> nrRegisterTx),
      "revealAfter" .= nrRevealAfter,
@@ -96,13 +102,19 @@ viewJSON NamesConfig {nTLD, nChain = ChainConfig {cChainId, cResolver, cSponsor}
    NameRegistration {nrId = RegistrationId rid, nrVersion, nrMoves, nrLinksRefusedAt, nrPhase, nrLabelHash = LabelHash lh, nrReveal, nrOwner, nrCommitment, nrSealed} = r
    NameRegistration {nrYears, nrDuration, nrPrice, nrBalanceUsed, nrCommitTx, nrRegisterTx, nrRevealAfter, nrRevealBefore, nrExpiresAt, nrError} = r
    txText (TxHash h) = hex h
+    waitingText :: LateWait -> Text
+    waitingText = \case
+      LWConfirming -> "confirming"
+      LWCrediting -> "crediting"
+      LWSupport -> "support"

-- | The holder is not named, so an order's link discloses no other order.
+-- | The holder is not named, so an order's link discloses no other order. A funded hold has no end time.
 balanceJSON :: Balance -> J.Value
 balanceJSON b@Balance {blAmount, blRefunded} =
-  J.object ["amount" .= blAmount, "held" .= isJust hold, "heldUntil" .= (bhUntil <$> hold), "refunded" .= blRefunded]
+  J.object ["amount" .= blAmount, "held" .= isJust hold, "heldUntil" .= (bhUntil <$> (hold >>= unfunded)), "refunded" .= blRefunded]
  where
    hold = heldBy b
+    unfunded h@BalanceHold {bhFunded} = if bhFunded then Nothing else Just h

 -- | EIP-55, as the page compares owners.
 addressText :: Address -> Text
@@ -49,7 +49,7 @@ import StoreService.Names.Reveal (intentOf)
 import StoreService.Names.Revert (RevertName (..))
 import StoreService.Names.Sender (PendingTx, SendError (..), Sender, awaitOutcome, inFlightTransaction, ptHash, submitTransaction)
 import StoreService.Names.Store
-import StoreService.Names.Turns (withLabelTurn)
+import StoreService.Names.Turns (withBalanceTurn, withLabelTurn)
 import StoreService.Names.View (lapseMoment, notSignedInTime, registrationAt, registrationVersion)

 data Worker = Worker
@@ -323,14 +323,16 @@ judge w@Worker {wkOrders = oe@OrdersEnv {oeContracts}} now r@NameRegistration {n
                | otherwise -> failed w now r reason
          Nothing -> failed w now r reason

-- | The payment is kept, and a code order's code released.
+-- | A paid order keeps its whole price as a balance of its own, credited in the taken write's transaction, registration before balance,
+-- in the balance's turn after the name's; a code order's code is released.
 taken :: Worker -> UTCTime -> NameRegistration -> IO (Maybe Int64, Next)
-taken Worker {wkOrders = OrdersEnv {oeStore, oeTurns}} now r@NameRegistration {nrId, nrPayment} = case nrPayment of
-  RPInvoice {} -> written r <$> withTransaction oeStore write
-  RPBalance -> written r <$> withTransaction oeStore write
+taken Worker {wkOrders = OrdersEnv {oeStore, oeTurns}} now r@NameRegistration {nrId, nrPayment, nrPrice} = case nrPayment of
+  RPInvoice {} -> credited
+  RPBalance -> credited
  RPCode codeId -> written r . fmap fst <$> releaseCode oeTurns oeStore codeId nrId write
  where
    write db = versionWritten <$> updateRegistration db r {nrPhase = PTaken, nrError = Nothing} now
+    credited = written r <$> withBalanceTurn oeTurns nrId (withTransaction oeStore $ \db -> write db >>= traverse (\v -> v <$ creditBalance db nrId nrPrice now))

 -- | A code order keeps its code for Try again.
 failed :: Worker -> UTCTime -> NameRegistration -> Maybe RevertName -> IO (Maybe Int64, Next)
@@ -14,11 +14,11 @@ module StoreService.Orders
  )
 where

-import StoreService.Log (logError, safelyWith)
+import StoreService.Log (logError, logInfo, safelyWith)
 import StoreService.Names.Phases (Phases, RegistrationId (..))
 import qualified StoreService.Names.Phases as Phases
-import StoreService.Names.Store (NamePhase (..), NameRegistration (..), VersionWrite (..), getRegistration, releaseHeldBalance, updateRegistration)
-import StoreService.Providers (Funded (..), PaymentSignal (..), Received (..))
+import StoreService.Names.Store (LateSupport (..), NamePhase (..), NameRegistration (..), VersionWrite (..), getRegistration, releaseHeldBalance, setLateSupport, spendHeldBalance, updateRegistration)
+import StoreService.Providers (Confirmed (..), Funded (..), PaymentSignal (..), Received (..), Uncreditable (..))
 import StoreService.Store.Invoices (InvoicePayment (..), InvoiceProduct (..), InvoiceRow (..), expireOverdueInvoice, lockInvoice, markCodePaid, paymentHolds, paymentStatusText, settlementCodeHash, settlementInvoice, truncateToSecond, updateInvoiceStatus, upsertPayment)
 import StoreService.Waiters (Waiters, publish, publishPayment)
 import Control.Concurrent.STM (STM, atomically)
@@ -85,8 +85,10 @@ data Published = PubNothing | PubStatus InvoiceStatus | PubPayment
 -- | What the invoice pays for, read before any write.
 data Product = PBadge (Maybe ByteString) | PName NameRegistration

-- | A name order's change at settlement: its new version, or money received after it closed, which stays unpaid.
-data NameOutcome = NOWritten RegistrationId Int64 | NOLate RegistrationId
+-- | A name order's change at settlement: its new version; money received after it closed, which stays unpaid and is credited to its balance;
+-- a holder queued whose held balance could not be spent (the holder, then the balance's order); or an order closed because another live order
+-- holds its commitment, or its owner and name.
+data NameOutcome = NOWritten RegistrationId Int64 | NOLate RegistrationId | NOHoldNotSpent RegistrationId RegistrationId | NOLiveOrderExists RegistrationId

 settleOrder :: DBStore -> Waiters -> Maybe Phases -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus)
 settleOrder st waiters phases invId signal now' = do
@@ -110,9 +112,11 @@ settleOrder st waiters phases invId signal now' = do
          PubNothing -> pure ()
        forM_ name $ \case
          NOWritten rid v -> publishRegistration phases (rid, v)
-          NOLate _ -> pure ()
+          _ -> pure ()
      forM_ name $ \case
        NOLate rid -> latePayment invId rid
+        NOHoldNotSpent holder source -> holdNotSpent invId holder source
+        NOLiveOrderExists rid -> liveOrderExists invId rid
        NOWritten {} -> pure ()
      pure (Right status)
  where
@@ -131,27 +135,34 @@ settleOrder st waiters phases invId signal now' = do
        | otherwise -> maybe (Left "settled invoice has no code hash") (Right . PBadge . Just) <$> settlementCodeHash db invId
      IPName rid -> maybe (Left "name invoice has no registration") (Right . PName) <$> getRegistration db rid
    newPayment :: InvoiceRow -> Write -> Bool
+    -- A rise of the confirmed money is a new payment with the totals unchanged, so a late payment that confirms is credited.
    newPayment InvoiceRow {irPayment} Write {wPayment}
      -- Monero reports an invoice as confirming while its figures are still zero, so a funded verdict earns a row
      | not (paidInFull signal) && rcvCrypto == Nothing && rcvAmount == CurrencyAmount 0 = False
      | otherwise = case irPayment of
          Nothing -> True
          -- the write is monotonic, so a lower figure or withdrawn verdict is not a new payment
-          Just InvoicePayment {ipAmount, ipCryptoPaid, ipPaidInFull, ipStatus}
+          Just InvoicePayment {ipAmount, ipCryptoPaid, ipPaidInFull, ipStatus, ipConfirmed = Confirmed {cfCents = CurrencyAmount heldCents, cfUnits = heldUnits}}
            | ipStatus == paymentStatusText PSSettled -> False
            | otherwise ->
                maybe True (\(CurrencyAmount held) -> held < minor) ipAmount
                  || (ipCryptoPaid == Nothing && rcvCrypto /= Nothing)
                  || (paidInFull signal && not ipPaidInFull)
                  || ipStatus /= paymentStatusText wPayment
+                  || confirmedCents > heldCents
+                  || maybe False (> fromMaybe 0 heldUnits) confirmedUnits
      where
-        Received {rcvAmount, rcvCrypto} = received signal
+        Received {rcvAmount, rcvCrypto, rcvConfirmed = Confirmed {cfCents = CurrencyAmount confirmedCents, cfUnits = confirmedUnits}} = received signal
        CurrencyAmount minor = rcvAmount
    settle :: DB.Connection -> InvoiceRow -> Write -> Product -> IO (Either Text (InvoiceStatus, Published, [NameOutcome]))
    settle db row@InvoiceRow {irStatus} w@Write {wStatus, wPayment} sold = do
-      let Received {rcvAmount, rcvCrypto, rcvDue} = received signal
+      let money@Received {rcvUncreditable} = received signal
          wrotePayment = newPayment row w
-      when wrotePayment $ upsertPayment db row wPayment rcvAmount rcvCrypto rcvDue (paidInFull signal) at
+      when wrotePayment $ do
+        upsertPayment db row wPayment money (paidInFull signal) at
+        case sold of
+          PName _ -> mapM_ (setLateSupport db invId . lateSupportOf) rcvUncreditable
+          PBadge _ -> pure ()
      moved <- maybe (pure True) (\new -> updateInvoiceStatus db invId irStatus new at) wStatus
      if moved
        then do
@@ -169,20 +180,26 @@ settleOrder st waiters phases invId signal now' = do
 -- BTCPay reports money paid into a closed invoice as Expired or Invalid, not Settled, so a new payment figure
 -- on a closed invoice is late too; the monotonic payment write reports each figure once.
 nameSettled :: DB.Connection -> InvoiceStatus -> Maybe InvoiceStatus -> Bool -> Bool -> NameRegistration -> UTCTime -> IO [NameOutcome]
-nameSettled db before after wrotePayment holdsMoney r@NameRegistration {nrId, nrPhase} now
+nameSettled db before after wrotePayment holdsMoney r@NameRegistration {nrId, nrPhase, nrBalanceSource, nrBalanceUsed} now
  | nrPhase /= PUnpaid = pure []
  | otherwise = case after of
      Just ISPaid
        | before /= ISOpen -> pure [NOLate nrId]
        | otherwise ->
            updateRegistration db r {nrPhase = PQueued} now >>= \case
-              Written v -> pure [NOWritten nrId v]
+              Written v -> (NOWritten nrId v :) <$> spendHold
              NotLive -> pure [NOLate nrId]
-              -- not expected while this order is live; kept so the payment is still recorded
-              LiveOrderExists -> pure [NOLate nrId]
+              -- an invariant broke; left live, the order would keep its hold for ever, as no sweep closes a paid invoice
+              LiveOrderExists -> (<> [NOLate nrId, NOLiveOrderExists nrId]) <$> closed
              _ -> E.throwIO (RegistrationChanged nrId)
-      Just ISExpired -> (<> [NOLate nrId | holdsMoney]) . maybe [] (\(rid, v) -> [NOWritten rid v]) <$> closeOrder db r now
+      Just ISExpired -> (<> [NOLate nrId | holdsMoney]) <$> closed
      _ -> pure [NOLate nrId | before /= ISOpen, wrotePayment]
+  where
+    closed = maybe [] (\(rid, v) -> [NOWritten rid v]) <$> closeOrder db r now
+    -- the buyer paid the difference, so the order stays queued even when its hold cannot be spent
+    spendHold = case nrBalanceSource of
+      Just source -> (\spent -> [NOHoldNotSpent nrId source | not spent]) <$> spendHeldBalance db nrId nrBalanceUsed now
+      Nothing -> pure []

 -- | Clears a live unpaid order's live flag, as its invoice closes in the same transaction, and releases a balance it held.
 closeOrder :: DB.Connection -> NameRegistration -> UTCTime -> IO (Maybe (RegistrationId, Int64))
@@ -200,9 +217,27 @@ closeInvoiceOrder db invId now =
    Just InvoiceRow {irProduct = IPName rid} -> getRegistration db rid >>= maybe (pure Nothing) (\r -> closeOrder db r now)
    _ -> pure Nothing

+lateSupportOf :: Uncreditable -> LateSupport
+lateSupportOf = \case
+  UCHighSpeed -> LSHighSpeed
+  UCUncounted -> LSUnits
+  UCNoConfirmationShown -> LSNoConfirmation
+
 latePayment :: InvoiceId -> RegistrationId -> IO ()
 latePayment (InvoiceId invText) (RegistrationId rid) =
-  logError ("names: invoice " <> invText <> " was paid after its order closed, so registration " <> rid <> " stays unpaid; refund the payment")
+  logInfo ("names: invoice " <> invText <> " received money after registration " <> rid <> " closed; it stays unpaid, and its money is credited to its balance once confirmed, else alerted")
+
+holdNotSpent :: InvoiceId -> RegistrationId -> RegistrationId -> IO ()
+holdNotSpent (InvoiceId invText) (RegistrationId holder) (RegistrationId source) =
+  logError $
+    "names: invoice " <> invText <> " queued registration " <> holder <> " as paid, but the balance of registration " <> source
+      <> " it held could not be spent; check that balance and release or spend its hold by hand"
+
+liveOrderExists :: InvoiceId -> RegistrationId -> IO ()
+liveOrderExists (InvoiceId invText) (RegistrationId rid) =
+  logError $
+    "names: invoice " <> invText <> " was paid while another live order held the commitment, or the owner and name, of registration " <> rid
+      <> "; it was closed and its money is credited to its balance; the unique live indexes should have prevented this"

 -- | False when the invoice was no longer open. Throws RegistrationChanged, changing nothing, when its order changed meanwhile.
 -- The provider has taken the cancel, so a name invoice a payment landed on meanwhile expires too, and its payment is late.
@@ -28,15 +28,18 @@ module StoreService.Poller
    cleanupReadsPerPass,
    unpaidRetention,
    cleanupUnpaid,
+    creditPass,
+    forgetRates,
  )
 where

 import StoreService.Config (PollConfig (..))
+import StoreService.Names.LateCredits (CreditOutcome (..), creditLateInvoice)
 import StoreService.Names.Phases (Phases, RegistrationId (..))
-import StoreService.Names.Store (CleanupKept (..), deleteUnpaidRegistration, unpaidCleanupCandidates)
+import StoreService.Names.Store (CleanupKept (..), LateAlert (..), LateCredit (..), LateCreditState (..), LatePending (..), LateSupport (..), claimLateAlert, deleteUnpaidRegistration, lateAlertDue, latePending, uncreditedLateInvoices, unpaidCleanupCandidates)
 import StoreService.Orders (decide, expireOverdue, settleOrder)
-import StoreService.Providers (ListPass (..), PaymentSignal (..), Provider (..), ProviderError (..), Received (..), expiresItself, settleWindow)
-import StoreService.Store.Invoices (InvoiceProduct (..), InvoiceRow (..), OverdueInvoice (..), getInvoice, getInvoiceByProviderRef, overdueInvoices, providerText, unpaidRefs)
+import StoreService.Providers (ListPass (..), PaymentSignal (..), Provider (..), ProviderError (..), Rate (..), Received (..), expiresItself, settleWindow, unitName)
+import StoreService.Store.Invoices (InvoiceProduct (..), InvoiceRow (..), OverdueInvoice (..), cryptoCurrencyText, getInvoice, getInvoiceByProviderRef, overdueInvoices, providerText, unpaidRefs)
 import StoreService.Waiters (Waiters, waitingCount, waitingCountSTM)
 import Control.Concurrent.STM
 import StoreService.Log (logError, logInfo, logWarn, safely, safelyWith)
@@ -50,7 +53,7 @@ import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
 import Numeric.Natural (Natural)
-import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus (..), PaymentProvider (..))
+import Simplex.Chat.PaymentService.Types (CryptoCurrency, InvoiceId (..), InvoiceStatus (..), PaymentProvider (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
 import Simplex.Messaging.Util (tshow)

@@ -120,7 +123,10 @@ data PollerEnv = PollerEnv
    peCancelFailed :: TVar (Map Text UTCTime),
    peCleanedAt :: TVar (Maybe UTCTime),
    -- | The orders of the day's cleanup not read yet.
-    peCleanupLeft :: TVar [(RegistrationId, InvoiceId)]
+    peCleanupLeft :: TVar [(RegistrationId, InvoiceId)],
+    peCreditedAt :: TVar (Maybe UTCTime),
+    -- | The rates read in this pass or hinted read, by provider and coin.
+    peRates :: TVar (Map (Text, Text) (Either ProviderError Rate))
  }

 newPollerEnv :: DBStore -> Waiters -> Maybe Phases -> ReadHints -> [Provider] -> PollConfig -> IO PollerEnv
@@ -130,13 +136,16 @@ newPollerEnv peStore peWaiters pePhases peHints peProviders pePoll = do
  peCancelFailed <- newTVarIO M.empty
  peCleanedAt <- newTVarIO Nothing
  peCleanupLeft <- newTVarIO []
-  pure PollerEnv {peStore, peWaiters, pePhases, peHints, peProviders, pePoll, peSkipped, peListedAt, peStrayEvery = strayListInterval, peCancelFailed, peCleanedAt, peCleanupLeft}
+  peCreditedAt <- newTVarIO Nothing
+  peRates <- newTVarIO M.empty
+  pure PollerEnv {peStore, peWaiters, pePhases, peHints, peProviders, pePoll, peSkipped, peListedAt, peStrayEvery = strayListInterval, peCancelFailed, peCleanedAt, peCleanupLeft, peCreditedAt, peRates}

 -- | Read providers before the sweep, and leave out of the sweep every invoice whose read or settlement failed,
 -- so an invoice with money in it is never expired. A list that cannot account for every invoice skips the sweep.
 runOnePass :: PollerEnv -> IO ()
 runOnePass env@PollerEnv {peStore, peProviders} = do
  now <- getCurrentTime
+  forgetRates env
  rows <- unpaidRefs peStore (addUTCTime (negate settleWindow) now)
  let bulk = length rows > readsPerPass
  listNow <- listDue env now bulk
@@ -152,6 +161,7 @@ runOnePass env@PollerEnv {peStore, peProviders} = do
  pruneSkipLog env now
  -- the cleanup runs whatever the sweep met
  unless (null peProviders) $ forM_ missed $ \refs -> safely "badge poller: the sweep" (sweepExpired env now refs)
+  void $ safely "names: the late credit pass" (creditPass env now)
  cleanupUnpaid env now

 -- | The cases the stray list catches are rare and not urgent, so minutes, not the pass cadence.
@@ -220,19 +230,27 @@ listPass env now p =
        skipWhat (ref, _) = "badge poller: reading the skipped " <> tshow (pProvider p) <> " invoice " <> fromMaybe "the provider did not name" ref

 -- | provider_ref is unique table-wide, not per provider, so check the provider too.
+-- A name invoice's late money is credited after the settlement that recorded it commits.
 settleMoved :: PollerEnv -> PaymentProvider -> UTCTime -> (Text, PaymentSignal) -> IO ()
-settleMoved env@PollerEnv {peStore, peWaiters, pePhases} provider now (ref, signal) =
+settleMoved env@PollerEnv {peStore, peWaiters, pePhases, peProviders} provider now (ref, signal) =
  getInvoiceByProviderRef peStore ref >>= \case
    Just InvoiceRow {irInvoiceId, irStatus, irProvider, irProduct} | irProvider == provider ->
      when (isJust (decide irStatus signal)) $
        settleOrder peStore peWaiters pePhases irInvoiceId signal now >>= \case
          Left e -> logError ("badge poller: settling order " <> ref <> " failed: " <> e)
-          Right status -> reportSettled irProduct irStatus status
+          Right status -> do
+            reportSettled irProduct irStatus status
+            case (irProduct, find ((== provider) . pProvider) peProviders) of
+              (IPName _, Just p) ->
+                creditLate env p now irInvoiceId >>= \case
+                  CONothingDue -> pendingLate env irInvoiceId
+                  _ -> pure ()
+              _ -> pure ()
    _ -> pure ()
  where
    reportSettled sold before after
      -- checked before the no-change case, so a refund still alerts when money lands after expiry;
-      -- settlement itself alerts once for a name order's late payment
+      -- a name order's late payment is credited to its balance instead
      | IPBadge {} <- sold, after == ISExpired, SigClosed Received {rcvCrypto = Just paid} <- signal = do
          let alert = "badge poller: order " <> ref <> " expired holding " <> paid <> ", which needs a refund"
          due <- dueToWarn env now alert
@@ -243,6 +261,7 @@ settleMoved env@PollerEnv {peStore, peWaiters, pePhases} provider now (ref, sign
 serveHint :: PollerEnv -> Text -> IO ()
 serveHint env ref = do
  now <- getCurrentTime
+  forgetRates env
  hintSafely env now ref

 readHint :: PollerEnv -> UTCTime -> Text -> IO ()
@@ -276,12 +295,14 @@ cleanupDue PollerEnv {peCleanedAt} now = atomically $ do
  pure due

 -- | The poller reads an invoice only within settleWindow of its creation, so each order's invoice is read once more
-- before the order goes: a payment whose webhook was lost is recorded then, and the order is kept for support.
-- Each pass reads at most cleanupReadsPerPass of the day's orders.
+-- before the order goes: a payment whose webhook was lost is recorded then, and the order is kept with its balance.
+-- Each pass reads at most cleanupReadsPerPass of the day's orders. The day's alerts on late money go with it.
 cleanupUnpaid :: PollerEnv -> UTCTime -> IO ()
 cleanupUnpaid env@PollerEnv {peStore, peCleanupLeft} now = do
  due <- cleanupDue env now
-  when due $ withTransaction peStore (`unpaidCleanupCandidates` addUTCTime (negate unpaidRetention) now) >>= atomically . writeTVar peCleanupLeft
+  when due $ do
+    withTransaction peStore (`unpaidCleanupCandidates` addUTCTime (negate unpaidRetention) now) >>= atomically . writeTVar peCleanupLeft
+    void $ safely "names: the late payment alerts" (alertLatePayments env now)
  candidates <- atomically $ stateTVar peCleanupLeft (splitAt cleanupReadsPerPass)
  deleted <- filterM (\c@(RegistrationId rid, _) -> safelyWith ("names cleanup: registration " <> rid) False (cleanOne c)) candidates
  unless (null deleted) $ logInfo ("names cleanup: deleted " <> tshow (length deleted) <> " unpaid order(s)")
@@ -298,11 +319,121 @@ cleanupUnpaid env@PollerEnv {peStore, peCleanupLeft} now = do
                mapM_ (\signal -> settleMoved env irProvider now (irProviderRef, signal)) signal_
                withTransaction peStore (`deleteUnpaidRegistration` rid) >>= \case
                  Right () -> pure True
-                  Left CKPaid -> False <$ logError ("names cleanup: unpaid registration " <> ridText <> " is kept because invoice " <> invText <> " received a payment; refund it")
+                  Left CKPaid -> False <$ logInfo ("names cleanup: unpaid registration " <> ridText <> " is kept with its balance, because invoice " <> invText <> " received a payment")
                  Left (CKHolder (RegistrationId source)) -> False <$ logError ("names cleanup: unpaid registration " <> ridText <> " is kept because it still holds the balance of registration " <> source)
      where
        keep why = False <$ logWarn ("names cleanup: unpaid registration " <> ridText <> " is kept until the next run, " <> why)

+-- | At the idle cadence, so a failing rate read costs one read per coin per pass while browsers wait.
+creditDue :: PollerEnv -> UTCTime -> IO Bool
+creditDue PollerEnv {peCreditedAt, pePoll = PollConfig {pIdleSeconds}} now = atomically $ do
+  due <- maybe True (\at -> diffUTCTime now at >= fromIntegral pIdleSeconds) <$> readTVar peCreditedAt
+  when due $ writeTVar peCreditedAt (Just now)
+  pure due
+
+-- | Credits every closed order's confirmed money not all credited, so a crash or a failed rate read after a settlement loses nothing.
+creditPass :: PollerEnv -> UTCTime -> IO ()
+creditPass env@PollerEnv {peStore, peProviders} now = do
+  due <- creditDue env now
+  when due $ do
+    invoices <- withTransaction peStore uncreditedLateInvoices
+    forM_ invoices $ \invId@(InvoiceId invText) ->
+      safely ("names: crediting invoice " <> invText) $
+        getInvoice peStore invId >>= \case
+          Just InvoiceRow {irProvider} | Just p <- find ((== irProvider) . pProvider) peProviders -> void $ creditLate env p now invId
+          _ -> do
+            due' <- dueToWarn env now ("no rate provider: " <> invText)
+            when due' $ logWarn ("names: invoice " <> invText <> " has late money to credit, but no provider is configured to read its rate")
+
+-- | The pass's rate of a coin at a provider, read at most once.
+cachedRate :: PollerEnv -> Provider -> CryptoCurrency -> IO (Either ProviderError Rate)
+cachedRate PollerEnv {peRates} Provider {pProvider, pCurrentRate} coin =
+  M.lookup key <$> readTVarIO peRates >>= \case
+    Just rate -> pure rate
+    Nothing -> do
+      rate <- maybe (pure $ Left $ ProviderError $ providerText pProvider <> " offers no rates") ($ coin) pCurrentRate
+      rate <$ atomically (modifyTVar' peRates (M.insert key rate))
+  where
+    key = (providerText pProvider, cryptoCurrencyText coin)
+
+-- | Each pass and hinted read reads the rates again.
+forgetRates :: PollerEnv -> IO ()
+forgetRates PollerEnv {peRates} = atomically $ writeTVar peRates M.empty
+
+creditLate :: PollerEnv -> Provider -> UTCTime -> InvoiceId -> IO CreditOutcome
+creditLate env@PollerEnv {peStore} p now invId@(InvoiceId invText) = do
+  outcome <- creditLateInvoice peStore (cachedRate env p) invId now
+  case outcome of
+    CONothingDue -> pure ()
+    COCredited LateCredit {lcRegistration = RegistrationId rid, lcUnits, lcInvoiceRate, lcCurrentRate, lcRateUsed, lcCents} ->
+      logInfo $
+        "names: invoice " <> invText <> " credited " <> tshow lcCents <> " cents to the balance of registration " <> rid
+          <> maybe "" (\units -> " for " <> tshow units <> " units at " <> fromMaybe "?" lcRateUsed <> " (invoice " <> fromMaybe "?" lcInvoiceRate <> ", current " <> fromMaybe "?" lcCurrentRate <> ")") lcUnits
+    CONoInvoiceRate -> do
+      due <- dueToWarn env now ("no invoice rate: " <> invText)
+      when due $ logError ("names: invoice " <> invText <> " has confirmed late money, but no invoice rate was recorded to credit it at; check it at the provider")
+    CORateFailed (ProviderError e) -> do
+      due <- dueToWarn env now ("rate read failed: " <> tshow (pProvider p))
+      when due $ logWarn ("names: late credits wait, as the current rate cannot be read; each pass tries again: " <> e)
+    CORateFloor invoiceRate Rate {rateText} -> do
+      due <- dueToWarn env now ("rate floor: " <> invText)
+      when due $ logError ("names: invoice " <> invText <> " is not credited: the current rate " <> rateText <> " is below half its rate " <> invoiceRate <> "; it is never credited by itself, and support refunds it by hand")
+    CORefused -> logError ("names: the credit of invoice " <> invText <> " was refused, its credit number taken meanwhile; the next pass tries again")
+  pure outcome
+
+-- | Money not yet confirmed waits for the settlement that confirms it.
+pendingLate :: PollerEnv -> InvoiceId -> IO ()
+pendingLate PollerEnv {peStore} invId@(InvoiceId invText) =
+  withTransaction peStore (`latePending` invId) >>= \case
+    Just pending | pending `elem` [LPConfirming, LPUnconfirmed] -> logInfo ("names: invoice " <> invText <> " holds money of its closed order not yet confirmed; it is credited once confirmed")
+    _ -> pure ()
+
+-- | Late money still not all credited when its payment row is older than the read window, once per invoice and again when more arrives;
+-- the claim keeps it to one instance.
+alertLatePayments :: PollerEnv -> UTCTime -> IO ()
+alertLatePayments env@PollerEnv {peStore} now = do
+  due <- withTransaction peStore (`lateAlertDue` addUTCTime (negate settleWindow) now)
+  forM_ due $ \alert@LateAlert {laState = LateCreditState {lsInvoice = InvoiceId invText}} ->
+    safely ("names: the alert on invoice " <> invText) $ do
+      (reason, support) <- lateReason env alert
+      claimed <- withTransaction peStore $ \db -> claimLateAlert db alert support now
+      when claimed $ logError (lateAlertText alert reason)
+
+-- | Confirmed money waiting comes before a stored reason, as in pendingCase, so its alert never asks for a refund by hand.
+lateReason :: PollerEnv -> LateAlert -> IO (Text, Maybe LateSupport)
+lateReason env@PollerEnv {peStore, peProviders} LateAlert {laPending, laState = LateCreditState {lsInvoice, lsCoin, lsSupport, lsInvoiceRate}} = case laPending of
+  LPUncounted -> pure (uncounted, Nothing)
+  LPUncredited -> case lsCoin of
+    Nothing -> pure (cardWaits, Nothing)
+    Just coin
+      | lsSupport == Just LSRateFloor ->
+          getInvoice peStore lsInvoice >>= \case
+            Just InvoiceRow {irProvider} | Just p <- find ((== irProvider) . pProvider) peProviders -> (\r -> (rateFloor (either (const "unread") rateText r), Nothing)) <$> cachedRate env p coin
+            _ -> pure (rateFloor "unread", Nothing)
+      | otherwise -> pure (rateRead, Nothing)
+  _ | lsSupport == Just LSHighSpeed -> pure (highSpeed, Nothing)
+  _ | lsSupport == Just LSNoConfirmation -> pure (noConfirmation, Nothing)
+  _ -> pure (unconfirmed, Just LSUnconfirmed)
+  where
+    unconfirmed = "refund by hand only a transaction confirmed on chain that BTCPay no longer monitors; one still Processing there waits"
+    highSpeed = "the invoice was made under HighSpeed, so its money is never credited by itself; refund by hand only a transaction confirmed on chain"
+    noConfirmation = "the Monero plugin shows no confirmation of this money, so it is never credited by itself; refund by hand only a transaction confirmed on chain"
+    rateRead = "confirmed, the credit waits on the rate read; do not refund; fix the rate read"
+    cardWaits = "confirmed, the credit waits on the poller's credit pass; do not refund; check the service log"
+    rateFloor current = "confirmed; the coin's price fell by more than half since the invoice (" <> fromMaybe "?" lsInvoiceRate <> ", " <> current <> "); it is never credited by itself; refund by hand only a transaction confirmed on chain"
+    uncounted = "an amount BTCPay reported with more decimals than its unit; check it at the provider"
+
+lateAlertText :: LateAlert -> Text -> Text
+lateAlertText LateAlert {laState = LateCreditState {lsInvoice = InvoiceId invText, lsRegistration = RegistrationId rid, lsCoin, lsReceivedCents, lsConfirmedCents, lsCreditedCents, lsReceivedUnits, lsConfirmedUnits, lsCreditedUnits}} reason =
+  "names: invoice " <> invText <> " of order " <> rid <> ": " <> figures <> "; " <> reason
+  where
+    figures = case (lsCoin, lsReceivedUnits) of
+      (Nothing, _) -> amounts "cents" (toInteger lsReceivedCents) (toInteger lsConfirmedCents) (toInteger lsCreditedCents)
+      (Just coin, Just received) -> amounts (unitName coin) (toInteger received) (maybe 0 toInteger lsConfirmedUnits) (toInteger lsCreditedUnits)
+      (Just _, Nothing) -> tshow lsReceivedCents <> " cents received at the invoice's rate, not counted in units"
+    amounts unit received confirmed credited =
+      tshow received <> " " <> unit <> " received, " <> tshow confirmed <> " " <> unit <> " confirmed, " <> tshow credited <> " " <> unit <> " credited"
+
 -- | Cancel the order at the provider first, so the buyer can no longer pay it.
 closedAtProvider :: PollerEnv -> UTCTime -> OverdueInvoice -> IO Bool
 closedAtProvider env@PollerEnv {peProviders} now oi@OverdueInvoice {oiProvider, oiProviderRef = ref} =
@@ -1,10 +1,16 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}

 module StoreService.Providers
  ( ProviderError (..),
    WebhookError (..),
    Received (..),
+    Confirmed (..),
+    Uncreditable (..),
+    Rate (..),
+    unitDecimals,
+    unitName,
    PaymentSignal (..),
    ProviderInvoice (..),
    Funded (..),
@@ -17,10 +23,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,9 +37,43 @@ 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,
+-- its crypto could not be counted in atomic units, or the provider shows no confirmation of it. Such money confirms nothing.
+data Uncreditable = UCHighSpeed | UCUncounted | UCNoConfirmationShown
+  deriving (Eq, Show)
+
+-- | A coin's current price in the service's currency, above 0: as the provider wrote it, and as a decimal to compute with.
+data Rate = Rate {rateText :: Text, rateValue :: Scientific}
+  deriving (Eq, Show)
+
+-- | The decimals of each coin's atomic unit.
+unitDecimals :: CryptoCurrency -> Int
+unitDecimals = \case
+  CCBtc -> 8
+  CCXmr -> 12
+
+unitName :: CryptoCurrency -> Text
+unitName = \case
+  CCBtc -> "satoshi"
+  CCXmr -> "piconero"
+
 -- The provider applies its own tolerance, so this cannot be recomputed from the amounts.
 data Funded = PaidInFull | PaidInPart
  deriving (Eq, Show)
@@ -77,5 +119,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)
  }
@@ -16,22 +16,27 @@ 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,
+    unitDecimals,
    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,33 @@ 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
+--   InvoiceSettledConfirmationThreshold, which settles a payment at that many confirmations. Greenfield's payment model
+--   (Controllers/GreenField/GreenfieldInvoiceController.cs, ToPaymentModel) carries no payment's confirmations; the method's
+--   additionalData (Payments/MoneroLikeOnChainPaymentMethodDetails.cs, camel-cased by Data/BlobSerializer.cs) carries the invoice's
+--   invoiceSettledConfirmationThreshold, so a Settled XMR payment shows a confirmation only when it is at least 1;
+-- - the store's rates, GET stores/{storeId}/rates?currencyPair=BTC_USD: Controllers/GreenField/GreenfieldStoreRatesController.cs and
+--   Models/StoreRateResult.cs, a list of {currencyPair, errors, rate}, rate null when errors is not empty; it needs canviewstoresettings.
 btcMethodId, xmrMethodId :: Text
 btcMethodId = "BTC-CHAIN"
 xmrMethodId = "XMR-CHAIN"

+methodCurrencies :: [(Text, CryptoCurrency)]
+methodCurrencies = [(btcMethodId, CCBtc), (xmrMethodId, CCXmr)]
+
 knownMethodIds :: [Text]
-knownMethodIds = [btcMethodId, xmrMethodId]
+knownMethodIds = map fst methodCurrencies
+
+-- | 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 +174,7 @@ data GInvoice = GInvoice
  { giId :: Text,
    giStatus :: Text,
    giAdditionalStatus :: Maybe Text,
+    giSpeedPolicy :: Maybe Text,
    giPaymentMethods :: Maybe [GPaymentMethod]
  }
  deriving (Show)
@@ -158,6 +185,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
@@ -169,7 +197,8 @@ data GPaymentMethod = GPaymentMethod
    gpmRate :: Maybe WireNum,
    gpmPaid :: Maybe WireNum,
    gpmDue :: Maybe WireNum,
-    gpmPayments :: [GPayment]
+    gpmPayments :: [GPayment],
+    gpmSettledThreshold :: Maybe Int
  }
  deriving (Show)

@@ -183,16 +212,34 @@ instance J.FromJSON GPaymentMethod where
      <*> o J..:? "paymentMethodPaid"
      <*> o J..:? "due"
      <*> (fromMaybe [] <$> o J..:? "payments")
+      <*> (settledThreshold <$> o J..:? "additionalData")
+    where
+      -- read leniently: another plugin's additionalData must not fail the read
+      settledThreshold = \case
+        Just (J.Object d) | Just (J.Number n) <- KM.lookup "invoiceSettledConfirmationThreshold" d -> toBoundedInteger n
+        _ -> Nothing

+-- | A payment without a value is read, and only its units cannot be counted.
 data GPayment = GPayment
  { 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 +273,7 @@ btcpayProvider cfg = do
        pReadInvoice = readInvoice env,
        pCancelInvoice = cancelInvoice env,
        pListOpen = listOpen env,
+        pCurrentRate = Just (currentRate env),
        pVerifyWebhook = const (verifyBTCPaySig (bWebhookSecret cfg))
      }

@@ -305,11 +353,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 +404,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 +425,21 @@ 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, gpmSettledThreshold}, 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
+      shown = cc /= CCXmr || maybe False (>= 1) gpmSettledThreshold
+      received = receivedOf decimals confirming shown (status == "Settled") rate paid gpmDue gpmPayments
  case status of
    "Settled" -> Right (Just (SigSettled received (fromMaybe now (latestSettledAt m))))
    "Processing" -> Right (Just (SigFunded received PaidInFull))
@@ -399,9 +451,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 +479,53 @@ 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 -> Bool -> WireNum -> WireNum -> Maybe WireNum -> [GPayment] -> Received
+receivedOf decimals confirming shown invoiceSettled rate paid due payments =
  Received
    { rcvAmount = toMinorUnits (wnValue paid * wnValue rate),
      rcvCrypto = if wnValue paid > 0 then Just (wnText paid) else Nothing,
-      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
+      | not shown = Just UCNoConfirmationShown
+      | 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
@@ -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.
@@ -37,6 +37,7 @@ module StoreService.Store.Invoices
    upsertPayment,
    paymentStatusText,
    cryptoCurrencyText,
+    textToCryptoCurrency,
    textToInvoiceStatus,
    invoiceStatusText,
    updateInvoiceStatus,
@@ -49,6 +50,7 @@ import qualified Control.Exception as E
 import Crypto.Random (getRandomBytes)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as B64U
+import Data.Int (Int64)
 import qualified Data.ByteString.Char8 as BC8
 import Data.String (fromString)
 import Data.Text (Text)
@@ -66,6 +68,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Encoding.String (textEncode)
 import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
 import StoreService.Names.Phases (RegistrationId (..))
+import StoreService.Providers (Confirmed (..), Received (..))

 #if defined(dbPostgres)
 import StoreService.Store.Postgres.Migrations (servicePrefix, withPrefix)
@@ -108,7 +111,8 @@ data InvoicePayment = InvoicePayment
    ipCryptoDue :: Maybe Text,
    ipPaidInFull :: Bool,
    ipStatus :: Text,
-    ipUpdatedAt :: UTCTime
+    ipUpdatedAt :: UTCTime,
+    ipConfirmed :: Confirmed
  }
  deriving (Eq, Show)

@@ -206,7 +210,7 @@ invoiceRowSelect =
    <> ", bc.badge_type, bc.months, ni.registration_id, "
    <> "i.price, i.amount, i.currency, i.payment_url, i.payment_address, i.payment_crypto_currency, "
    <> "i.payment_crypto_amount, i.expires_at, i.status, i.created_at, "
-    <> "p.amount, p.crypto_paid, p.crypto_due, p.paid_in_full, p.status, p.updated_at "
+    <> "p.amount, p.crypto_paid, p.crypto_due, p.paid_in_full, p.status, p.updated_at, p.confirmed_amount, p.confirmed_units "
    <> "FROM @invoices i "
    <> productJoins
    <> "LEFT JOIN @payments p ON p.invoice_id = i.invoice_id "
@@ -281,17 +285,27 @@ largerOf = "GREATEST"
 largerOf = "MAX"
 #endif

-- Once a row is settled it stays settled, so a later pending update cannot overwrite it.
+-- Once a row is settled it stays settled, so a later pending update cannot overwrite it. The confirmed figures and received units
+-- only rise, so a settled sum that falls (a payment turned invalid, a reorg) leaves them; the invoice's rate is written once.
 qUpsertPayment :: Query
 qUpsertPayment =
  mkQuery $
    "INSERT INTO @payments "
-      <> "(payment_id, invoice_id, provider, provider_ref, amount, currency, crypto_paid, crypto_due, paid_in_full, status, created_at, updated_at) "
-      <> "VALUES (?,?,?,?,?,?,?,?,?,?,?,?) "
+      <> "(payment_id, invoice_id, provider, provider_ref, amount, currency, crypto_paid, crypto_due, paid_in_full, status, "
+      <> "received_units, confirmed_amount, confirmed_units, invoice_rate, created_at, updated_at) "
+      <> "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) "
      <> "ON CONFLICT (payment_id) DO UPDATE SET "
      <> "amount = "
      <> largerOf
      <> "(COALESCE(@payments.amount, 0), excluded.amount), "
+      <> "received_units = "
+      <> largerOfNullable "received_units"
+      <> ", confirmed_amount = "
+      <> largerOf
+      <> "(@payments.confirmed_amount, excluded.confirmed_amount), "
+      <> "confirmed_units = "
+      <> largerOfNullable "confirmed_units"
+      <> ", invoice_rate = COALESCE(@payments.invoice_rate, excluded.invoice_rate), "
      <> "crypto_paid = CASE WHEN excluded.amount > COALESCE(@payments.amount, 0) OR @payments.crypto_paid IS NULL "
      <> "THEN excluded.crypto_paid ELSE @payments.crypto_paid END, "
      <> "crypto_due = COALESCE(excluded.crypto_due, @payments.crypto_due), "
@@ -306,6 +320,8 @@ qUpsertPayment =
      <> " THEN @payments.updated_at ELSE excluded.updated_at END"
  where
    alreadySettled = "@payments.status = '" <> paymentStatusText PSSettled <> "'"
+    -- SQLite's MAX of a NULL is NULL, so each side falls back to the other
+    largerOfNullable column = largerOf <> "(COALESCE(@payments." <> column <> ", excluded." <> column <> "), COALESCE(excluded." <> column <> ", @payments." <> column <> "))"

 qLockInvoice :: Query
 qLockInvoice = mkQuery "UPDATE @invoices SET updated_at = ? WHERE invoice_id = ?"
@@ -425,14 +441,14 @@ type InvoiceCols =
  (Text, Text, Text, Maybe BadgeType, Maybe Word32, Maybe Text)
    :. (Word32, Word32, Text, Maybe Text, Maybe Text, Maybe Text)
    :. (Maybe Text, UTCTime, Text, UTCTime)
-    :. (Maybe Word32, Maybe Text, Maybe Text, Maybe Int, Maybe Text, Maybe UTCTime)
+    :. (Maybe Word32, Maybe Text, Maybe Text, Maybe Int, Maybe Text, Maybe UTCTime, Maybe Word32, Maybe Int64)

 mkInvoiceRow :: InvoiceCols -> Either Text InvoiceRow
 mkInvoiceRow
  ( (invId, providerTxt, providerRef, badgeType, months, registrationId)
      :. (price, amount, currency, url, addr, cryptoCur)
      :. (cryptoAmt, expiresAt, statusTxt, createdAt)
-      :. (pAmount, pCryptoPaid, pCryptoDue, pPaidInFull, pStatus, pUpdatedAt)
+      :. (pAmount, pCryptoPaid, pCryptoDue, pPaidInFull, pStatus, pUpdatedAt, pConfirmedAmount, pConfirmedUnits)
    ) = do
    provider <- note "invoices.provider" (textToProvider providerTxt)
    invoiceProduct <- case (badgeType, months, registrationId) of
@@ -454,12 +470,15 @@ mkInvoiceRow
          irExpiresAt = expiresAt,
          irStatus = status,
          irCreatedAt = createdAt,
-          irPayment = mkPayment pAmount pCryptoPaid pCryptoDue pPaidInFull pStatus pUpdatedAt
+          irPayment = mkPayment pAmount pCryptoPaid pCryptoDue pPaidInFull pStatus pUpdatedAt pConfirmedAmount pConfirmedUnits
        }

-mkPayment :: Maybe Word32 -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Text -> Maybe UTCTime -> Maybe InvoicePayment
-mkPayment amt cryptoPaid cryptoDue paidInFull status updatedAt =
-  InvoicePayment (CurrencyAmount <$> amt) cryptoPaid cryptoDue (paidInFull == Just 1) <$> status <*> updatedAt
+mkPayment :: Maybe Word32 -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Text -> Maybe UTCTime -> Maybe Word32 -> Maybe Int64 -> Maybe InvoicePayment
+mkPayment amt cryptoPaid cryptoDue paidInFull status updatedAt confirmedAmount confirmedUnits =
+  InvoicePayment (CurrencyAmount <$> amt) cryptoPaid cryptoDue (paidInFull == Just 1)
+    <$> status
+    <*> updatedAt
+    <*> ((\cents -> Confirmed {cfCents = CurrencyAmount cents, cfUnits = confirmedUnits}) <$> confirmedAmount)

 selectInvoiceRow :: DB.Connection -> Query -> Text -> IO (Maybe InvoiceRow)
 selectInvoiceRow db q param = do
@@ -659,16 +678,18 @@ settlementCodeHash db (InvoiceId invId) = do
    (Only codeHash : _) -> DB.fromBinary <$> codeHash
    [] -> Nothing

-upsertPayment :: DB.Connection -> InvoiceRow -> PaymentStatus -> CurrencyAmount -> Maybe Text -> Maybe Text -> Bool -> UTCTime -> IO ()
-upsertPayment db InvoiceRow {irInvoiceId, irProvider, irProviderRef, irCurrency} status (CurrencyAmount amount) cryptoAmount cryptoDue paidInFull at' =
+upsertPayment :: DB.Connection -> InvoiceRow -> PaymentStatus -> Received -> Bool -> UTCTime -> IO ()
+upsertPayment db InvoiceRow {irInvoiceId, irProvider, irProviderRef, irCurrency} status received paidInFull at' =
  DB.execute
    db
    qUpsertPayment
    ( (invId, invId, providerText irProvider, irProviderRef, amount)
-        :. (irCurrency, cryptoAmount, cryptoDue, if paidInFull then 1 :: Int else 0, paymentStatusText status, at, at)
+        :. (irCurrency, rcvCrypto, rcvDue, if paidInFull then 1 :: Int else 0, paymentStatusText status)
+        :. (rcvUnits, confirmedCents, cfUnits, rcvRate, at, at)
    )
  where
    InvoiceId invId = irInvoiceId
+    Received {rcvAmount = CurrencyAmount amount, rcvCrypto, rcvDue, rcvUnits, rcvRate, rcvConfirmed = Confirmed {cfCents = CurrencyAmount confirmedCents, cfUnits}} = received
    at = truncateToSecond at'

 -- | Takes the invoice row's lock for the rest of the transaction; SQLite's transactions hold the whole database already.
@@ -21,7 +21,8 @@ schemaMigrations =
    ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops),
    ("20261010_names", m20261010_names, Just down_m20261010_names),
    ("20261022_drop_taken_codes", m20261022_drop_taken_codes, Just down_m20261022_drop_taken_codes),
-    ("20261022_name_balances", m20261022_name_balances, Just down_m20261022_name_balances)
+    ("20261022_name_balances", m20261022_name_balances, Just down_m20261022_name_balances),
+    ("20261022_name_late_wait", m20261022_name_late_wait, Just down_m20261022_name_late_wait)
  ]

 -- | The client tables share this database, so the service tables are the same names behind a prefix.
@@ -441,6 +442,23 @@ DROP INDEX @idx_name_balances_reserved_by;
 DROP TABLE @name_balances;
 |]

+-- Why a closed order's late money will not be credited by itself: high_speed, units, rate_floor, unconfirmed or no_confirmation. Never cleared.
+m20261022_name_late_wait :: Text
+m20261022_name_late_wait =
+  withPrefix
+    servicePrefix
+    [r|
+ALTER TABLE @name_invoices ADD COLUMN late_support TEXT;
+|]
+
+down_m20261022_name_late_wait :: Text
+down_m20261022_name_late_wait =
+  withPrefix
+    servicePrefix
+    [r|
+ALTER TABLE @name_invoices DROP COLUMN late_support;
+|]
+
 {- TODO [badges] deferred with the draft in M20260915_user_badges, service only.

 ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA;
@@ -22,7 +22,8 @@ schemaMigrations =
    ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops),
    ("20261010_names", m20261010_names, Just down_m20261010_names),
    ("20261022_drop_taken_codes", m20261022_drop_taken_codes, Just down_m20261022_drop_taken_codes),
-    ("20261022_name_balances", m20261022_name_balances, Just down_m20261022_name_balances)
+    ("20261022_name_balances", m20261022_name_balances, Just down_m20261022_name_balances),
+    ("20261022_name_late_wait", m20261022_name_late_wait, Just down_m20261022_name_late_wait)
  ]

 -- | The client tables share this database, so the service tables are the same names behind a prefix.
@@ -443,6 +444,23 @@ DROP INDEX @idx_name_balances_reserved_by;
 DROP TABLE @name_balances;
 |]

+-- Why a closed order's late money will not be credited by itself: high_speed, units, rate_floor, unconfirmed or no_confirmation. Never cleared.
+m20261022_name_late_wait :: Query
+m20261022_name_late_wait =
+  withPrefix
+    servicePrefix
+    [sql|
+ALTER TABLE @name_invoices ADD COLUMN late_support TEXT;
+|]
+
+down_m20261022_name_late_wait :: Query
+down_m20261022_name_late_wait =
+  withPrefix
+    servicePrefix
+    [sql|
+ALTER TABLE @name_invoices DROP COLUMN late_support;
+|]
+
 {- TODO [badges] deferred with the draft in M20260915_user_badges, service only.

 ALTER TABLE @payments ADD COLUMN receipt_hash BLOB;
@@ -53,9 +53,9 @@ findHandler OrdersEnv {oeStore, oeNow} req respond =
      firstRefusal [checkSigner frOwner (findMessage frOwner frTimestamp) frSignature, pure $ checkTimestamp now frTimestamp] >>= \case
        Just refusal -> refuse refusal
        Nothing ->
-          withTransaction oeStore (`findRegistrations` frOwner) >>= \case
+          withTransaction oeStore (\db -> findRegistrations db frOwner now) >>= \case
            [] -> pure $ answerNow notFound
-            rs -> pure $ answerNow $ jsonResponse status200 $ J.object ["registrations" .= map (foundJSON . registrationAt now) rs]
+            rs -> pure $ answerNow $ jsonResponse status200 $ J.object ["registrations" .= map (\(r, holder) -> foundJSON (registrationAt now r) holder) rs]
    refuse = refused "POST /api/registration/find"

 parseFind :: J.Object -> Maybe FindRequest
@@ -65,17 +65,21 @@ parseFind o = do
  frSignature <- eitherToMaybe . parseSignature =<< textField o "signature"
  pure FindRequest {frOwner, frTimestamp, frSignature}

-foundJSON :: NameRegistration -> J.Value
-foundJSON NameRegistration {nrId = RegistrationId rid, nrPayment, nrPhase, nrCreatedAt, nrLabelHash = LabelHash lh, nrSealed} =
+-- | balanceSource: the order whose balance paid this one; heldBy: the order whose invoice holds this one's balance.
+foundJSON :: NameRegistration -> Maybe RegistrationId -> J.Value
+foundJSON NameRegistration {nrId = RegistrationId rid, nrPayment, nrPhase, nrCreatedAt, nrLabelHash = LabelHash lh, nrSealed, nrBalanceSource} holder =
  J.object
    [ "registrationId" .= rid,
      "invoiceId" .= invoiceId,
      "phase" .= (textEncode nrPhase :: Text),
      "createdAt" .= nrCreatedAt,
      "labelHash" .= hex lh,
-      "sealed" .= nrSealed
+      "sealed" .= nrSealed,
+      "balanceSource" .= (idText <$> nrBalanceSource),
+      "heldBy" .= (idText <$> holder)
    ]
  where
+    idText (RegistrationId t) = t
    invoiceId = case nrPayment of
      RPInvoice _ (InvoiceId t) -> Just t
      RPCode _ -> Nothing
@@ -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": [
            {
@@ -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": [
            {
@@ -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": [
            {
@@ -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": {}
@@ -11,7 +11,7 @@
      "totalPaid": "9.99999999",
      "due": "0.00000000",
      "amount": "0.00050000",
-      "networkFee": "0.00000500",
+      "paymentMethodFee": "0.00000500",
      "activated": true,
      "payments": [
        {
@@ -10,7 +10,7 @@
      "paymentMethodPaid": "0.00000000",
      "totalPaid": "0.00000000",
      "due": "0.00050000",
-      "networkFee": "0.00000500",
+      "paymentMethodFee": "0.00000500",
      "activated": true,
      "payments": [],
      "additionalData": {}
@@ -9,7 +9,7 @@
      "totalPaid": "0.00000000",
      "due": "0.00050000",
      "amount": "0.00050000",
-      "networkFee": "0.00000500",
+      "paymentMethodFee": "0.00000500",
      "activated": false,
      "payments": [],
      "additionalData": {}
@@ -11,7 +11,7 @@
      "totalPaid": "9.99999999",
      "due": "0.00000000",
      "amount": "0.32095000",
-      "networkFee": "0.00000500",
+      "paymentMethodFee": "0.00000500",
      "activated": true,
      "payments": [
        {
@@ -449,6 +449,7 @@ executable simplex-store-service
      StoreService.Names.Contracts
      StoreService.Names.Env
      StoreService.Names.Label
+      StoreService.Names.LateCredits
      StoreService.Names.Links
      StoreService.Names.Orders
      StoreService.Names.Phases
@@ -773,6 +774,7 @@ test-suite simplex-chat-test
      Bots.StoreService.NamesCodesTests
      Bots.StoreService.NamesContractsTests
      Bots.StoreService.NamesLabelTests
+      Bots.StoreService.NamesLateCreditTests
      Bots.StoreService.NamesLinksTests
      Bots.StoreService.NamesOrdersTests
      Bots.StoreService.NamesOwnerTests
@@ -814,6 +816,7 @@ test-suite simplex-chat-test
      StoreService.Names.Contracts
      StoreService.Names.Env
      StoreService.Names.Label
+      StoreService.Names.LateCredits
      StoreService.Names.Links
      StoreService.Names.Orders
      StoreService.Names.Phases
@@ -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,15 @@ 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 XMR only when the invoice's settled-confirmation threshold is at least 1, never with 0 or none" testXmrConfirmations
+    it "confirms nothing under HighSpeed, or with no or an unknown speed policy, an invoice-level Settled included" testHighSpeedConfirmsNothing
+    it "accepts trailing zeros past the unit" testTrailingZeros
+    it "drops only the units of an amount with a non-zero digit past its unit, the signal and its cents as before" testDigitPastUnit
  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 +121,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 +134,95 @@ 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)
+    ]
+
+-- | The Monero plugin's method, its additionalData carrying the invoice's settled-confirmation threshold when given.
+xmrPaid :: Maybe Int -> Text -> [J.Value] -> J.Value
+xmrPaid threshold paid payments =
+  J.object
+    [ "paymentMethodId" .= xmrMethodId,
+      "destination" .= ("44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A" :: Text),
+      "amount" .= ("0.32095000" :: Text),
+      "rate" .= ("168.25" :: Text),
+      "paymentMethodPaid" .= paid,
+      "due" .= ("0.00000000" :: Text),
+      "payments" .= payments,
+      "additionalData" .= J.object (maybe [] (\n -> ["invoiceSettledConfirmationThreshold" .= n]) threshold)
+    ]
+
+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 (Just 1) "0.32095000" [paymentOf "Settled" "0.32095000"]]
+    `shouldBe` Right (Just (SigSettled xmrConfirmed (posixSecondsToUTCTime 1700000000)))
+
+xmrConfirmed :: Received
+xmrConfirmed = xmrReceived {rcvConfirmed = Confirmed {cfCents = CurrencyAmount 5400, cfUnits = Just 320950000000}, rcvUncreditable = Nothing}
+
+-- | A Monero payment's own confirmations are not in Greenfield's payment model, so only the invoice's threshold shows one.
+testXmrConfirmations :: IO ()
+testXmrConfirmations = do
+  let settledWith threshold = signalOf "Settled" [xmrPaid threshold "0.32095000" [paymentOf "Settled" "0.32095000"]]
+      settled r = Right (Just (SigSettled r (posixSecondsToUTCTime 1700000000)))
+  settledWith (Just 0) `shouldBe` settled xmrReceived
+  settledWith Nothing `shouldBe` settled xmrReceived
+  mapM_ (\n -> settledWith (Just n) `shouldBe` settled xmrConfirmed) [1, 10]
+
+rcvUnitsOf :: PaymentSignal -> Maybe Int64
+rcvUnitsOf = \case
+  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 +244,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 +271,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 +312,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 +357,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 +379,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 +399,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 +413,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 +457,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 +547,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 +625,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 = Just UCNoConfirmationShown
+    }

 fiftyFourDollars :: OrderDraft
 fiftyFourDollars =
@@ -600,21 +738,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 +862,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 +871,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 +881,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
@@ -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])

@@ -5,7 +5,7 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}

-module Bots.StoreService.NamesBalancesTests (namesBalancesTests) where
+module Bots.StoreService.NamesBalancesTests (namesBalancesTests, fieldsN, figures, holdPrice, holder, invariantHolds, placeOrderRow, source) where

 import Bots.StoreService.NamesOrdersTests (Ctx (..), withOrders)
 import Bots.StoreService.NamesStoreTests (at, btc, invoiceStatus, newReg, ownerA, ownerB, paidOrder, reg, signature, t0, write)
@@ -20,7 +20,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime, addUTCTime)
-import Simplex.Chat.PaymentService.Types (CardProvider (..), InvoiceId (..), InvoiceStatus (..), ServicePaymentMethod (..))
+import Simplex.Chat.PaymentService.Types (CardProvider (..), CryptoCurrency (..), InvoiceId (..), InvoiceStatus (..), ServicePaymentMethod (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
@@ -150,7 +150,7 @@ holder st r src seen expiresAt = withTransaction st $ \db -> do
  createPaidRegistration db (newReg r ownerA (fieldsN r)) (holdTerms src seen) (paidOrder ("inv-" <> r)) {poPrice = holdPrice} t0

 hold :: Text -> UTCTime -> Bool -> BalanceHold
-hold h bhUntil bhOverdue = BalanceHold {bhHolder = RegistrationId h, bhUntil, bhOverdue}
+hold h bhUntil bhOverdue = BalanceHold {bhHolder = RegistrationId h, bhUntil, bhOverdue, bhFunded = False}

 coveredSpend :: DBStore -> Text -> Text -> Int -> Int -> IO (Either RegistrationRefused ())
 coveredSpend st r src price seen = withTransaction st $ \db -> createBalanceRegistration db (newReg r ownerA (fieldsN r)) (RegistrationId src) price seen t0
@@ -462,7 +462,7 @@ testFindBalances = withServiceStore $ \st -> do
  credit st "r1" 5000
  credit st "r2" 3000
  refund st "r2" 3000 `shouldReturn` True
-  map nrId <$> withTransaction st (`findRegistrations` ownerA) `shouldReturn` map (RegistrationId . rid) ([52, 51 .. 3] <> [1])
+  map (nrId . fst) <$> withTransaction st (\db -> findRegistrations db ownerA t0) `shouldReturn` map (RegistrationId . rid) ([52, 51 .. 3] <> [1])

 -- closes

@@ -517,7 +517,7 @@ testNamedHolders = withOrders $ \Ctx {cStore = st, cOrders, cWeb} -> do
  h2 <- reg st "h2"
  payment st "inv-h2" (cardPaid 100 0) (at 61)
  Just funded <- withTransaction st $ \db -> getBalance db (RegistrationId "s2") now
-  blHold funded `shouldBe` Just (hold "h2" (at 60) False)
+  blHold funded `shouldBe` Just (hold "h2" (at 60) False) {bhFunded = True}
  closedIds <$> Orders.placeOrder cOrders (orderRequest "c2") [h2] (spendInsert "c2" "s2" 6000 10000) `shouldReturn` Left (ORBalanceChanged $ Just funded)
  absent st "c2"
  nrLive <$> reg st "h2" `shouldReturn` True
@@ -620,7 +620,8 @@ testLateScans = withServiceStore $ \st -> do
          lsRegistration = RegistrationId "part",
          lsPhase = PUnpaid,
          lsLive = False,
-          lsCard = False,
+          lsCoin = Just CCBtc,
+          lsSupport = Nothing,
          lsReceivedCents = 20000,
          lsConfirmedCents = 0,
          lsReceivedUnits = Just 300000,
@@ -665,7 +666,7 @@ testLateAlerts = withServiceStore $ \st -> do
      marks :: LateAlert -> (InvoiceId, LatePending, Maybe Int64, Maybe UTCTime, Maybe Int64)
      marks LateAlert {laState = LateCreditState {lsInvoice}, laPending, laReceived, laAlertedAt, laAlertedReceived} = (lsInvoice, laPending, laReceived, laAlertedAt, laAlertedReceived)
      claim :: LateAlert -> UTCTime -> IO Bool
-      claim alert t = withTransaction st $ \db -> claimLateAlert db alert t
+      claim alert t = withTransaction st $ \db -> claimLateAlert db alert Nothing t
  [old, card] <- due
  map marks [old, card]
    `shouldBe` [(InvoiceId "inv-old", LPUnconfirmed, Just 300000, Nothing, Nothing), (InvoiceId "inv-card", LPUnconfirmed, Just 5000, Nothing, Nothing)]
@@ -688,7 +689,7 @@ testUncountedAlertRepeats = withServiceStore $ \st -> do
      due = withTransaction st $ \db -> lateAlertDue db (at 60)
  [alert] <- due
  (laPending alert, laReceived alert) `shouldBe` (LPUncounted, Just 5000)
-  withTransaction st (\db -> claimLateAlert db alert (at 61)) `shouldReturn` True
+  withTransaction st (\db -> claimLateAlert db alert Nothing (at 61)) `shouldReturn` True
  due `shouldReturn` []
  withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_payments SET amount = ? WHERE invoice_id = ?" (6000 :: Int, "inv-x" :: Text)
  map (\LateAlert {laPending, laReceived, laAlertedReceived} -> (laPending, laReceived, laAlertedReceived)) <$> due `shouldReturn` [(LPUncounted, Just 6000, Just 5000)]
@@ -0,0 +1,757 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Bots.StoreService.NamesLateCreditTests (namesLateCreditTests) where
+
+import Bots.StoreService.NamesBalancesTests (fieldsN, figures, holder, invariantHolds, placeOrderRow, source)
+import Bots.StoreService.NamesStoreTests (at, newReg, ownerA, reg, t0)
+import Bots.StoreService.WebTests (StubCall (..), StubState (..), capturingStderr, newStubState, sampleProviderInvoice, setSignals, stubCalls, stubProvider, withServiceStore)
+import Control.Monad (void)
+import qualified Data.Aeson as J
+import Data.Int (Int64)
+import Data.IORef (IORef, atomicModifyIORef', newIORef)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
+import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..))
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import StoreService.Config (PollConfig (..))
+import StoreService.Names.Balances (RefundRefusal (..), recordRefund)
+import StoreService.Names.LateCredits (CreditOutcome (..), creditLateInvoice)
+import StoreService.Names.Phases (RegistrationId (..))
+import StoreService.Names.Store
+import StoreService.Names.Turns (newTurns)
+import StoreService.Names.View (balanceJSON)
+import StoreService.Orders (cancelOpenInvoice, settleOrder)
+import StoreService.Poller (PollerEnv, ReadHints, cleanupUnpaid, creditPass, drainHints, forgetRates, newPollerEnv, newReadHints, queueReadHint)
+import StoreService.Providers (Confirmed (..), Funded (..), PaymentSignal (..), Provider (..), ProviderError (..), Rate (..), Received (..), Uncreditable (..), settleWindow)
+import StoreService.Store.Invoices (unpaidRefs)
+import StoreService.Waiters (Waiters, newWaiters)
+import Test.Hspec
+
+#if defined(dbPostgres)
+import Bots.StoreService.WebTests (withServiceStores)
+import Control.Concurrent.Async (concurrently)
+import Control.Concurrent.STM (TVar, atomically, check, modifyTVar', newTVarIO, readTVar)
+import Control.Monad (forM, forM_)
+import Data.Maybe (fromJust, fromMaybe)
+import Simplex.Chat.PaymentService.Types (CryptoCurrency)
+import StoreService.Names.LateCredits (lateCreditOf)
+import StoreService.Store.Invoices (lockInvoice)
+import Database.PostgreSQL.Simple (Only (..))
+#else
+import Database.SQLite.Simple (Only (..))
+#endif
+
+namesLateCreditTests :: Spec
+namesLateCreditTests = describe "StoreService names: balance life" $ do
+  describe "settlement" $ do
+    it "queues a held order and spends its hold, the source's amount down by fromBalance" testHeldSettled
+    it "queues a difference order funded before its expiry and settled after it, still open in the database, spending its hold" testFundedThenSettledLate
+    it "queues an order whose hold was removed by hand and alerts naming the order and the balance's order" testHoldNotSpent
+    it "closes an order meeting another live order at settlement, alerts, and credits its payment after" testLiveOrderExists
+    it "releases a difference order's hold in that settlement's transaction and credits its own balance after, by the credit step" testLiveOrderExistsHolder
+    it "refuses a refund while the hold is open and spends the balance at settlement" testSettlementBeforeRefund
+  describe "late credits" $ do
+    it "credits a late payment to the closed order's balance at the lower rate, the released source's balance untouched, logged at info" testLateCredited
+    it "credits at the invoice's rate when the price rose, storing both rates and the rate used" testRisingPrice
+    it "credits a payment confirming over two reports by its increase, and a repeated report once" testGrowingReports
+    it "credits a confirmed part payment the provider's close meets, and a cancel's at the pass, the cancel reading no rate" testCloseAndCancel
+    it "credits nothing for unconfirmed money, logged as pending, then once when it reads Settled with the totals unchanged" testUnconfirmedThenSettled
+    it "never credits a replaced or dropped payment, alerting it once past the window from its payment row, never again" testNeverConfirmed
+    it "alerts a part credit with an unconfirmed rest once, naming its units" testPartCreditAlerted
+    it "logs Monero's zero figure as pending and does not alert it within the window" testMoneroZero
+    it "credits nothing while the rate read fails, warning once, then credits at the next pass" testRateFails
+    it "credits nothing below the rate floor and never after, logging an error, and alerts support naming both rates" testRateFloor
+    it "logs the rate floor of an invoice once while the price moves below it" testFloorLoggedOnce
+    it "alerts confirmed money waiting on the rate read as such, whatever reason was stored before" testWaitingOutranksStoredReason
+    it "warns once of an invoice no provider reads a rate for, and names an invoice with no recorded rate" testRateProblemsNamed
+    it "reads one rate per coin per pass for several invoices, and none when nothing is due" testOneRateReadPerPass
+    it "never credits a late Settled payment on an invoice made under HighSpeed, alerting it past the window" testHighSpeed
+    it "credits at the next pass a late Settled invoice and a settlement whose credit step did not run" testCreditedByPass
+    it "refuses to credit an order that is live again by the time it takes the invoice's lock" testLiveAgain
+    it "alerts once of two instances, and again when more money arrives" testTwoInstancesAlert
+    it "keeps the confirmed figure and the credit when the settled sum falls, crediting nothing on the same sum again" testFallingSum
+    it "credits an invoice past the read window after a hinted read" testHintPastWindow
+    it "credits Stripe's succeeded amount without reading a rate" testStripeCredited
+    it "credits late XMR in piconero when the plugin shows a confirmation, and alerts it to support when it shows none" testXmrLate
+  describe "balances with late credits" $ do
+    it "keeps a credit made while the balance is held, the held spend settling" testCreditWhileHeld
+    it "refuses a covered spend that read the amount before a credit" testSpendBeforeCredit
+    it "sums the refunds over credit, refund, late credit, refund" testCreditRefundTwice
+    it "spends a late credit with a covered spend and refunds the rest" testSpendAndRefundLate
+  describe "the view" $ do
+    it "shows a funded holder past its expiry held with no end time, and an unfunded one before it with its expiry" testHeldUntil
+    it "shows a balance spent to 0 and a refunded one as objects with amount 0" testZeroBalances
+    it "waits confirming, crediting, or support for each reason, on nothing once all is credited, and on support for good below the rate floor" testLateWaits
+    it "finds the order a balance paid and the order holding a balance, none for an overdue unfunded holder" testFindLinks
+#if defined(dbPostgres)
+  describe "two connections" $ do
+    it "credits once of two credit steps on one invoice, cleanly, where a step reading before the lock is refused" testConcurrentCredits
+    it "credits the confirmed units once against a settlement raising them" testCreditAgainstSettlement
+#endif
+
+-- fixtures
+
+data Late = Late
+  { lStore :: DBStore,
+    lStub :: IORef StubState,
+    lPoller :: PollerEnv,
+    lHints :: ReadHints,
+    lWaiters :: Waiters
+  }
+
+withLate :: (Late -> IO a) -> IO a
+withLate action = withServiceStore (`withLateOn` action)
+
+-- | Another poller over the store, as another instance or a restarted service runs.
+withLateOn :: DBStore -> (Late -> IO a) -> IO a
+withLateOn lStore action = do
+  lStub <- newIORef (newStubState (Right sampleProviderInvoice))
+  lWaiters <- newWaiters
+  lHints <- newReadHints
+  let crypto = stubProvider lStub
+      card = crypto {pProvider = PPStripe, pCurrentRate = Nothing}
+  lPoller <- newPollerEnv lStore lWaiters Nothing lHints [crypto, card] PollConfig {pWaitingSeconds = 1, pIdleSeconds = 1}
+  action Late {lStore, lStub, lPoller, lHints, lWaiters}
+
+-- | The invoices' rate, 62500 dollars a bitcoin, is 0.0625 cents a satoshi.
+satCents :: Int64 -> Int
+satCents units = fromIntegral (units * 625 `div` 10000)
+
+-- | Bitcoin received and confirmed, in satoshi, at the invoices' rate.
+btcPaid :: Int64 -> Int64 -> Received
+btcPaid units confirmed =
+  Received
+    { rcvAmount = CurrencyAmount (fromIntegral $ satCents units),
+      rcvCrypto = Just (T.pack $ show units),
+      rcvDue = Nothing,
+      rcvUnits = Just units,
+      rcvRate = Just "62500",
+      rcvConfirmed = Confirmed {cfCents = CurrencyAmount (fromIntegral $ satCents confirmed), cfUnits = Just confirmed},
+      rcvUncreditable = Nothing
+    }
+
+cardPaid :: Int -> Int -> Received
+cardPaid cents confirmed =
+  Received
+    { rcvAmount = CurrencyAmount (fromIntegral cents),
+      rcvCrypto = Nothing,
+      rcvDue = Nothing,
+      rcvUnits = Nothing,
+      rcvRate = Nothing,
+      rcvConfirmed = Confirmed {cfCents = CurrencyAmount (fromIntegral confirmed), cfUnits = Nothing},
+      rcvUncreditable = Nothing
+    }
+
+nothingPaid :: Received
+nothingPaid = cardPaid 0 0
+
+-- | 320000 satoshi: 20000 cents at the invoice's rate, 19200 at the stub's current rate of 60000.5.
+lateUnits :: Int64
+lateUnits = 320000
+
+invOf :: Text -> InvoiceId
+invOf r = InvoiceId ("inv-" <> r)
+
+refOf :: Text -> Text
+refOf r = "ref-inv-" <> r
+
+setRate :: Late -> Either ProviderError Rate -> IO ()
+setRate Late {lStub} r = atomicModifyIORef' lStub $ \s -> (s {ssRate = r}, ())
+
+rateOf :: Text -> Rational -> Rate
+rateOf t v = Rate {rateText = t, rateValue = fromRational v}
+
+stubRate :: Rate
+stubRate = rateOf "60000.5" 60000.5
+
+-- | An unpaid order of 20000 cents, crypto unless card, whose invoice the provider closed with nothing received.
+closedOrder :: Late -> Text -> Bool -> IO ()
+closedOrder l@Late {lStore} r card = do
+  placeOrderRow lStore r card 20000 (at 60)
+  settleAt l r (SigClosed nothingPaid) (at 61) `shouldReturn` Right ISExpired
+  NameRegistration {nrPhase, nrLive} <- reg lStore r
+  (nrPhase, nrLive) `shouldBe` (PUnpaid, False)
+
+-- | The provider reports the signal for the order's invoice, and the poller reads it on a hint, as a webhook asks; the logs.
+readSignal :: Late -> Text -> PaymentSignal -> IO Text
+readSignal Late {lStub, lHints, lPoller} r signal = do
+  setSignals lStub [(refOf r, signal)]
+  capturingStderr $ void (queueReadHint lHints (refOf r)) >> drainHints lPoller
+
+-- | Settled straight in the store at the given time, with no credit step after it.
+settleAt :: Late -> Text -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus)
+settleAt Late {lStore, lWaiters} r = settleOrder lStore lWaiters Nothing (invOf r)
+
+-- | A new pass's credits; the logs.
+passAt :: Late -> UTCTime -> IO Text
+passAt Late {lPoller} now = capturingStderr $ forgetRates lPoller >> creditPass lPoller now
+
+-- | The daily alerts of a newly started instance at the given time, with its rates; the logs.
+alertsAt :: Late -> Either ProviderError Rate -> UTCTime -> IO Text
+alertsAt Late {lStore} r now = withLateOn lStore $ \l@Late {lPoller} -> setRate l r >> capturingStderr (cleanupUnpaid lPoller now)
+
+-- | Amount, credited and refunded of the order's balance.
+balanceOf :: DBStore -> Text -> IO (Maybe (Int, Int, Int))
+balanceOf st r = fmap (\(amount, credited, refunded, _) -> (amount, credited, refunded)) <$> figures st r t0
+
+-- | Units, the invoice's, current and used rates, and cents of each credit of the order's invoice.
+creditsOf :: DBStore -> Text -> IO [(Maybe Int64, Maybe Text, Maybe Text, Maybe Text, Int)]
+creditsOf st r =
+  withTransaction st $ \db ->
+    DB.query db "SELECT units, invoice_rate, current_rate, rate_used, cents FROM sx_badge_service_name_late_credits WHERE invoice_id = ? ORDER BY credit_no" (Only $ "inv-" <> r)
+
+rateCalls :: Late -> IO Int
+rateCalls Late {lStub} = length . filter isRate <$> stubCalls lStub
+  where
+    isRate = \case
+      StubRate _ -> True
+      _ -> False
+
+lateWaitOf :: DBStore -> Text -> IO (Maybe LateWait)
+lateWaitOf st r = withTransaction st $ \db -> lateWait db (invOf r)
+
+-- | A log line of the level holding the text.
+logged :: Text -> Text -> Text -> Bool
+logged level needle = any (\ln -> ("[" <> level) `T.isPrefixOf` ln && needle `T.isInfixOf` ln) . T.lines
+
+count :: Text -> Text -> Int
+count needle = length . T.breakOnAll needle
+
+-- | The payment rows' created_at, past the read window by the seconds given.
+pastWindow :: UTCTime -> Integer -> UTCTime
+pastWindow createdAt by = addUTCTime (settleWindow + fromInteger by) createdAt
+
+-- settlement
+
+testHeldSettled :: IO ()
+testHeldSettled = withLate $ \l@Late {lStore = st} -> do
+  source st "s" 10000
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  settleAt l "h" (SigSettled (btcPaid 480000 480000) (at 10)) (at 10) `shouldReturn` Right ISPaid
+  NameRegistration {nrPhase, nrLive, nrBalanceUsed} <- reg st "h"
+  (nrPhase, nrLive, nrBalanceUsed) `shouldBe` (PQueued, True, 10000)
+  figures st "s" (at 10) `shouldReturn` Just (0, 10000, 0, Nothing)
+  invariantHolds st "s"
+
+testFundedThenSettledLate :: IO ()
+testFundedThenSettledLate = withLate $ \l@Late {lStore = st} -> do
+  source st "s" 10000
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  settleAt l "h" (SigFunded (btcPaid 480000 0) PaidInFull) (at 50) `shouldReturn` Right ISOpen
+  settleAt l "h" (SigSettled (btcPaid 480000 480000) (at 120)) (at 120) `shouldReturn` Right ISPaid
+  nrPhase <$> reg st "h" `shouldReturn` PQueued
+  figures st "s" (at 120) `shouldReturn` Just (0, 10000, 0, Nothing)
+
+testHoldNotSpent :: IO ()
+testHoldNotSpent = withLate $ \l@Late {lStore = st} -> do
+  source st "unspentsrc" 10000
+  holder st "unspent" "unspentsrc" 10000 (at 60) `shouldReturn` Right ()
+  withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_name_balances SET reserved_by = NULL WHERE registration_id = ?" (Only ("unspentsrc" :: Text))
+  logs <- capturingStderr $ settleAt l "unspent" (SigSettled (btcPaid 480000 480000) (at 10)) (at 10) `shouldReturn` Right ISPaid
+  logs `shouldSatisfy` logged "ERROR" "queued registration unspent as paid, but the balance of registration unspentsrc it held could not be spent"
+  nrPhase <$> reg st "unspent" `shouldReturn` PQueued
+  balanceOf st "unspentsrc" `shouldReturn` Just (10000, 10000, 0)
+
+-- | The unique index keeping one live order per commitment is dropped, so a second live order can meet the first at settlement.
+meetsLiveOrder :: DBStore -> Text -> IO ()
+meetsLiveOrder st r = do
+  withTransaction st $ \db -> DB.execute_ db "DROP INDEX sx_badge_service_idx_name_registrations_live_commitment"
+  NameRegistration {nrCommitment} <- reg st r
+  placeOrderRow st "twin" False 20000 (at 60)
+  withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_name_registrations SET commitment = ? WHERE registration_id = 'twin'" (Only $ DB.Binary nrCommitment)
+
+testLiveOrderExists :: IO ()
+testLiveOrderExists = withLate $ \l@Late {lStore = st} -> do
+  placeOrderRow st "a" False 20000 (at 60)
+  meetsLiveOrder st "a"
+  logs <- readSignal l "a" (SigSettled (btcPaid lateUnits lateUnits) (at 10))
+  logs `shouldSatisfy` logged "ERROR" "was paid while another live order held the commitment, or the owner and name, of registration a"
+  NameRegistration {nrPhase, nrLive} <- reg st "a"
+  (nrPhase, nrLive) `shouldBe` (PUnpaid, False)
+  balanceOf st "a" `shouldReturn` Just (19200, 19200, 0)
+
+testLiveOrderExistsHolder :: IO ()
+testLiveOrderExistsHolder = withLate $ \l@Late {lStore = st} -> do
+  source st "s" 10000
+  holder st "a" "s" 10000 (at 60) `shouldReturn` Right ()
+  meetsLiveOrder st "a"
+  setRate l (Left $ ProviderError "rates down")
+  void $ readSignal l "a" (SigSettled (btcPaid lateUnits lateUnits) (at 10))
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Nothing)
+  balanceOf st "a" `shouldReturn` Nothing
+  setRate l (Right stubRate)
+  void $ passAt l (at 20)
+  balanceOf st "a" `shouldReturn` Just (19200, 19200, 0)
+  invariantHolds st "s"
+
+testSettlementBeforeRefund :: IO ()
+testSettlementBeforeRefund = withLate $ \l@Late {lStore = st} -> do
+  turns <- newTurns
+  source st "s" 10000
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  recordRefund turns st "s" 10000 (at 5) >>= (`shouldSatisfy` \case Left (RefundHeld _) -> True; _ -> False)
+  settleAt l "h" (SigSettled (btcPaid 480000 480000) (at 10)) (at 10) `shouldReturn` Right ISPaid
+  recordRefund turns st "s" 10000 (at 11) >>= (`shouldSatisfy` \case Left _ -> True; Right _ -> False)
+  balanceOf st "s" `shouldReturn` Just (0, 10000, 0)
+
+-- late credits
+
+testLateCredited :: IO ()
+testLateCredited = withLate $ \l@Late {lStore = st} -> do
+  source st "paid" 10000
+  holder st "credited" "paid" 10000 (at 60) `shouldReturn` Right ()
+  settleAt l "credited" (SigClosed nothingPaid) (at 61) `shouldReturn` Right ISExpired
+  figures st "paid" t0 `shouldReturn` Just (10000, 10000, 0, Nothing)
+  logs <- readSignal l "credited" (SigClosed (btcPaid lateUnits lateUnits))
+  logs `shouldSatisfy` logged "INFO" "invoice inv-credited credited 19200 cents to the balance of registration credited for 320000 units at 60000.5 (invoice 62500, current 60000.5)"
+  logs `shouldNotSatisfy` logged "ERROR" "inv-credited"
+  balanceOf st "credited" `shouldReturn` Just (19200, 19200, 0)
+  creditsOf st "credited" `shouldReturn` [(Just lateUnits, Just "62500", Just "60000.5", Just "60000.5", 19200)]
+  figures st "paid" t0 `shouldReturn` Just (10000, 10000, 0, Nothing)
+
+testRisingPrice :: IO ()
+testRisingPrice = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  setRate l (Right $ rateOf "70000" 70000)
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  creditsOf st "x" `shouldReturn` [(Just lateUnits, Just "62500", Just "70000", Just "62500", 20000)]
+  balanceOf st "x" `shouldReturn` Just (20000, 20000, 0)
+
+testGrowingReports :: IO ()
+testGrowingReports = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000))
+  balanceOf st "x" `shouldReturn` Just (9600, 9600, 0)
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  map (\(units, _, _, _, cents) -> (units, cents)) <$> creditsOf st "x" `shouldReturn` [(Just 160000, 9600), (Just 160000, 9600)]
+  balanceOf st "x" `shouldReturn` Just (19200, 19200, 0)
+
+testCloseAndCancel :: IO ()
+testCloseAndCancel = withLate $ \l@Late {lStore = st, lWaiters} -> do
+  placeOrderRow st "p" False 20000 (at 60)
+  settleAt l "p" (SigFunded (btcPaid lateUnits 160000) PaidInPart) (at 10) `shouldReturn` Right ISOpen
+  void $ readSignal l "p" (SigClosed (btcPaid lateUnits 160000))
+  nrLive <$> reg st "p" `shouldReturn` False
+  balanceOf st "p" `shouldReturn` Just (9600, 9600, 0)
+  placeOrderRow st "c" False 20000 (at 60)
+  settleAt l "c" (SigFunded (btcPaid lateUnits lateUnits) PaidInFull) (at 10) `shouldReturn` Right ISOpen
+  calls <- rateCalls l
+  cancelOpenInvoice st lWaiters Nothing (invOf "c") (at 20) `shouldReturn` True
+  rateCalls l `shouldReturn` calls
+  balanceOf st "c" `shouldReturn` Nothing
+  void $ passAt l (at 21)
+  balanceOf st "c" `shouldReturn` Just (19200, 19200, 0)
+
+testUnconfirmedThenSettled :: IO ()
+testUnconfirmedThenSettled = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  logs <- readSignal l "x" (SigClosed (btcPaid lateUnits 0))
+  logs `shouldSatisfy` logged "INFO" "invoice inv-x holds money of its closed order not yet confirmed"
+  balanceOf st "x" `shouldReturn` Nothing
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  length <$> creditsOf st "x" `shouldReturn` 1
+  balanceOf st "x" `shouldReturn` Just (19200, 19200, 0)
+
+-- | The order was placed long before the payment, whose own row the window counts from.
+testNeverConfirmed :: IO ()
+testNeverConfirmed = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "never" False
+  let seenAt = at (60 * 24 * 5)
+      alert = "invoice inv-never of order never: 320000 satoshi received, 0 satoshi confirmed, 0 satoshi credited; refund by hand only a transaction confirmed on chain that BTCPay no longer monitors; one still Processing there waits"
+  settleAt l "never" (SigClosed (btcPaid lateUnits 0)) seenAt `shouldReturn` Right ISExpired
+  alertsAt l (Right stubRate) (pastWindow seenAt (-60)) >>= (`shouldNotSatisfy` T.isInfixOf "invoice inv-never of order never")
+  lateWaitOf st "never" `shouldReturn` Just LWConfirming
+  logs <- alertsAt l (Right stubRate) (pastWindow seenAt 60)
+  (count alert logs, logged "ERROR" alert logs) `shouldBe` (1, True)
+  lateWaitOf st "never" `shouldReturn` Just LWSupport
+  alertsAt l (Right stubRate) (pastWindow seenAt (24 * 3600 + 60)) >>= (`shouldNotSatisfy` T.isInfixOf "invoice inv-never of order never")
+  balanceOf st "never" `shouldReturn` Nothing
+
+testPartCreditAlerted :: IO ()
+testPartCreditAlerted = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "part" False
+  settleAt l "part" (SigClosed (btcPaid lateUnits 160000)) (at 100) `shouldReturn` Right ISExpired
+  void $ passAt l (at 101)
+  balanceOf st "part" `shouldReturn` Just (9600, 9600, 0)
+  logs <- alertsAt l (Right stubRate) (pastWindow (at 100) 60)
+  count "invoice inv-part of order part: 320000 satoshi received, 160000 satoshi confirmed, 160000 satoshi credited; refund by hand only" logs `shouldBe` 1
+  alertsAt l (Right stubRate) (pastWindow (at 100) (24 * 3600 + 60)) >>= (`shouldNotSatisfy` T.isInfixOf "invoice inv-part of order part")
+
+testMoneroZero :: IO ()
+testMoneroZero = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "monero" False
+  logs <- readSignal l "monero" (SigFunded (btcPaid 0 0) {rcvCrypto = Nothing} PaidInFull)
+  logs `shouldSatisfy` logged "INFO" "invoice inv-monero holds money of its closed order not yet confirmed"
+  withTransaction st (\db -> latePending db (invOf "monero")) `shouldReturn` Just LPConfirming
+  now <- getCurrentTime
+  alertsAt l (Right stubRate) (addUTCTime 3600 now) >>= (`shouldNotSatisfy` T.isInfixOf "invoice inv-monero of order monero")
+  balanceOf st "monero" `shouldReturn` Nothing
+
+testRateFails :: IO ()
+testRateFails = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "fail1" False
+  closedOrder l "fail2" False
+  setRate l (Left $ ProviderError "rates down for fail1")
+  logs <- readSignal l "fail1" (SigClosed (btcPaid lateUnits lateUnits))
+  settleAt l "fail2" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  more <- passAt l (at 71)
+  count "late credits wait, as the current rate cannot be read; each pass tries again: rates down for fail1" (logs <> more) `shouldBe` 1
+  lateWaitOf st "fail1" `shouldReturn` Just LWCrediting
+  mapM (balanceOf st) ["fail1", "fail2"] `shouldReturn` [Nothing, Nothing]
+  setRate l (Right stubRate)
+  void $ passAt l (at 72)
+  mapM (balanceOf st) ["fail1", "fail2"] `shouldReturn` replicate 2 (Just (19200, 19200, 0))
+  lateWaitOf st "fail1" `shouldReturn` Nothing
+
+testRateFloor :: IO ()
+testRateFloor = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "floored" False
+  let floored = rateOf "31000" 31000
+  setRate l (Right floored)
+  settleAt l "floored" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  logs <- passAt l (at 71)
+  logs `shouldSatisfy` logged "ERROR" "invoice inv-floored is not credited: the current rate 31000 is below half its rate 62500"
+  balanceOf st "floored" `shouldReturn` Nothing
+  lateWaitOf st "floored" `shouldReturn` Just LWSupport
+  alertsAt l (Right floored) (pastWindow (at 70) 60)
+    >>= (`shouldSatisfy` logged "ERROR" "invoice inv-floored of order floored: 320000 satoshi received, 320000 satoshi confirmed, 0 satoshi credited; confirmed; the coin's price fell by more than half since the invoice (62500, 31000); it is never credited by itself; refund by hand only a transaction confirmed on chain")
+  setRate l (Right stubRate)
+  void $ passAt l (at 72)
+  creditsOf st "floored" `shouldReturn` []
+  withTransaction st uncreditedLateInvoices >>= (`shouldNotSatisfy` elem (invOf "floored"))
+  lateWaitOf st "floored" `shouldReturn` Just LWSupport
+
+testFloorLoggedOnce :: IO ()
+testFloorLoggedOnce = withLate $ \l -> do
+  closedOrder l "floorlog" False
+  settleAt l "floorlog" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  setRate l (Right $ rateOf "31000" 31000)
+  first <- passAt l (at 71)
+  setRate l (Right $ rateOf "30000" 30000)
+  second <- passAt l (at 72)
+  count "invoice inv-floorlog is not credited" (first <> second) `shouldBe` 1
+
+-- | A reason stored by an earlier read, as one without the invoice's policy would store HighSpeed.
+testWaitingOutranksStoredReason :: IO ()
+testWaitingOutranksStoredReason = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "outranked" False
+  withTransaction st $ \db -> setLateSupport db (invOf "outranked") LSHighSpeed
+  settleAt l "outranked" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  alertsAt l (Left $ ProviderError "rates down for outranked") (pastWindow (at 70) 60)
+    >>= (`shouldSatisfy` logged "ERROR" "invoice inv-outranked of order outranked: 320000 satoshi received, 320000 satoshi confirmed, 0 satoshi credited; confirmed, the credit waits on the rate read; do not refund; fix the rate read")
+
+testRateProblemsNamed :: IO ()
+testRateProblemsNamed = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "noprovider" False
+  settleAt l "noprovider" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  withTransaction st $ \db -> DB.execute_ db "UPDATE sx_badge_service_invoices SET provider = 'apple' WHERE invoice_id = 'inv-noprovider'"
+  closedOrder l "norate" False
+  settleAt l "norate" (SigClosed (btcPaid lateUnits lateUnits) {rcvRate = Nothing}) (at 70) `shouldReturn` Right ISExpired
+  logs <- (<>) <$> passAt l (at 71) <*> passAt l (at 72)
+  count "invoice inv-noprovider has late money to credit, but no provider" logs `shouldBe` 1
+  logs `shouldSatisfy` logged "ERROR" "invoice inv-norate has confirmed late money, but no invoice rate was recorded to credit it at"
+
+testOneRateReadPerPass :: IO ()
+testOneRateReadPerPass = withLate $ \l@Late {lStore = st} -> do
+  mapM_ (\r -> closedOrder l r False >> settleAt l r (SigClosed (btcPaid lateUnits lateUnits)) (at 70)) ["x", "y", "z"]
+  closedOrder l "card" True
+  settleAt l "card" (SigSettled (cardPaid 20000 20000) (at 70)) (at 70) `shouldReturn` Right ISPaid
+  void $ passAt l (at 71)
+  rateCalls l `shouldReturn` 1
+  mapM (balanceOf st) ["x", "y", "z", "card"] `shouldReturn` replicate 3 (Just (19200, 19200, 0)) <> [Just (20000, 20000, 0)]
+  void $ passAt l (at 72)
+  rateCalls l `shouldReturn` 1
+
+testHighSpeed :: IO ()
+testHighSpeed = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "hs" False
+  let highSpeed = (btcPaid lateUnits 0) {rcvUncreditable = Just UCHighSpeed}
+  settleAt l "hs" (SigSettled highSpeed (at 70)) (at 70) `shouldReturn` Right ISPaid
+  void $ passAt l (at 71)
+  balanceOf st "hs" `shouldReturn` Nothing
+  lateWaitOf st "hs" `shouldReturn` Just LWSupport
+  alertsAt l (Right stubRate) (pastWindow (at 70) 60)
+    >>= (`shouldSatisfy` logged "ERROR" "invoice inv-hs of order hs: 320000 satoshi received, 0 satoshi confirmed, 0 satoshi credited; the invoice was made under HighSpeed")
+
+testCreditedByPass :: IO ()
+testCreditedByPass = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "settled" False
+  settleAt l "settled" (SigSettled (btcPaid lateUnits lateUnits) (at 70)) (at 70) `shouldReturn` Right ISPaid
+  closedOrder l "crashed" False
+  settleAt l "crashed" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  mapM (balanceOf st) ["settled", "crashed"] `shouldReturn` [Nothing, Nothing]
+  void $ passAt l (at 71)
+  mapM (balanceOf st) ["settled", "crashed"] `shouldReturn` replicate 2 (Just (19200, 19200, 0))
+
+testLiveAgain :: IO ()
+testLiveAgain = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  settleAt l "x" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  let liveAgain _ = do
+        withTransaction st $ \db -> DB.execute_ db "UPDATE sx_badge_service_name_registrations SET live = 1 WHERE registration_id = 'x'"
+        pure (Right stubRate)
+  creditLateInvoice st liveAgain (invOf "x") (at 71) `shouldReturn` CONothingDue
+  balanceOf st "x" `shouldReturn` Nothing
+  creditsOf st "x" `shouldReturn` []
+
+testTwoInstancesAlert :: IO ()
+testTwoInstancesAlert = withLate $ \l -> do
+  closedOrder l "twice" False
+  settleAt l "twice" (SigClosed (btcPaid lateUnits 0)) (at 70) `shouldReturn` Right ISExpired
+  let first = "invoice inv-twice of order twice: 320000 satoshi received"
+  logs <- (<>) <$> alertsAt l (Right stubRate) (pastWindow (at 70) 60) <*> alertsAt l (Right stubRate) (pastWindow (at 70) 60)
+  count first logs `shouldBe` 1
+  settleAt l "twice" (SigClosed (btcPaid 400000 0)) (at 80) `shouldReturn` Right ISExpired
+  alertsAt l (Right stubRate) (pastWindow (at 70) 120) >>= (`shouldSatisfy` logged "ERROR" "invoice inv-twice of order twice: 400000 satoshi received, 0 satoshi confirmed")
+
+testFallingSum :: IO ()
+testFallingSum = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000))
+  confirmed <- withTransaction st $ \db -> DB.query db "SELECT confirmed_units FROM sx_badge_service_payments WHERE invoice_id = 'inv-x'" ()
+  confirmed `shouldBe` [Only (Just lateUnits)]
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  length <$> creditsOf st "x" `shouldReturn` 1
+  balanceOf st "x" `shouldReturn` Just (19200, 19200, 0)
+
+testHintPastWindow :: IO ()
+testHintPastWindow = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  now <- getCurrentTime
+  let longAgo = addUTCTime (negate $ settleWindow + 3600) now
+  withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_invoices SET created_at = ? WHERE invoice_id = 'inv-x'" (Only longAgo)
+  unpaidRefs st (addUTCTime (negate settleWindow) now) >>= (`shouldNotSatisfy` elem ("crypto", refOf "x"))
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  balanceOf st "x" `shouldReturn` Just (19200, 19200, 0)
+
+testStripeCredited :: IO ()
+testStripeCredited = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "c" True
+  void $ readSignal l "c" (SigSettled (cardPaid 20000 20000) (at 70))
+  creditsOf st "c" `shouldReturn` [(Nothing, Nothing, Nothing, Nothing, 20000)]
+  balanceOf st "c" `shouldReturn` Just (20000, 20000, 0)
+  rateCalls l `shouldReturn` 0
+
+-- | 0.32095 XMR at the invoice's rate of 168.25, all of it Settled; uncreditable unless the plugin shows a confirmation.
+xmrPaid :: Maybe Uncreditable -> Received
+xmrPaid uncreditable =
+  Received
+    { rcvAmount = CurrencyAmount 5400,
+      rcvCrypto = Just "0.32095000",
+      rcvDue = Nothing,
+      rcvUnits = Just xmrUnits,
+      rcvRate = Just "168.25",
+      rcvConfirmed = maybe (Confirmed {cfCents = CurrencyAmount 5400, cfUnits = Just xmrUnits}) (const Confirmed {cfCents = CurrencyAmount 0, cfUnits = Just 0}) uncreditable,
+      rcvUncreditable = uncreditable
+    }
+  where
+    xmrUnits = 320950000000
+
+testXmrLate :: IO ()
+testXmrLate = withLate $ \l@Late {lStore = st} -> do
+  mapM_ (\r -> closedOrder l r False) ["xmrshown", "xmrnone"]
+  withTransaction st $ \db -> DB.execute_ db "UPDATE sx_badge_service_invoices SET payment_crypto_currency = 'xmr' WHERE invoice_id IN ('inv-xmrshown', 'inv-xmrnone')"
+  setRate l (Right $ rateOf "150" 150)
+  void $ readSignal l "xmrshown" (SigSettled (xmrPaid Nothing) (at 70))
+  creditsOf st "xmrshown" `shouldReturn` [(Just 320950000000, Just "168.25", Just "150", Just "150", 4814)]
+  void $ readSignal l "xmrnone" (SigSettled (xmrPaid $ Just UCNoConfirmationShown) (at 70))
+  balanceOf st "xmrnone" `shouldReturn` Nothing
+  lateWaitOf st "xmrnone" `shouldReturn` Just LWSupport
+  now <- getCurrentTime
+  alertsAt l (Right stubRate) (pastWindow now 60)
+    >>= (`shouldSatisfy` logged "ERROR" "invoice inv-xmrnone of order xmrnone: 320950000000 piconero received, 0 piconero confirmed, 0 piconero credited; the Monero plugin shows no confirmation of this money, so it is never credited by itself; refund by hand only a transaction confirmed on chain")
+
+-- balances with late credits
+
+testCreditWhileHeld :: IO ()
+testCreditWhileHeld = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  holder st "h" "x" 19200 (at 60) `shouldReturn` Right ()
+  void $ readSignal l "x" (SigClosed (btcPaid 400000 400000))
+  figures st "x" (at 10) `shouldReturn` Just (24000, 24000, 0, Just BalanceHold {bhHolder = RegistrationId "h", bhUntil = at 60, bhOverdue = False, bhFunded = False})
+  settleAt l "h" (SigSettled (btcPaid 330000 330000) (at 10)) (at 10) `shouldReturn` Right ISPaid
+  figures st "x" (at 10) `shouldReturn` Just (4800, 24000, 0, Nothing)
+  invariantHolds st "x"
+
+coveredSpend :: DBStore -> Text -> Text -> Int -> Int -> IO (Either RegistrationRefused ())
+coveredSpend st r src price seen = withTransaction st $ \db -> createBalanceRegistration db (newReg r ownerA (fieldsN r)) (RegistrationId src) price seen t0
+
+testSpendBeforeCredit :: IO ()
+testSpendBeforeCredit = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ readSignal l "x" (SigClosed (btcPaid 400000 400000))
+  coveredSpend st "c" "x" 10000 19200 `shouldReturn` Left RRBalanceChanged
+  coveredSpend st "c" "x" 10000 24000 `shouldReturn` Right ()
+  balanceOf st "x" `shouldReturn` Just (14000, 24000, 0)
+
+testCreditRefundTwice :: IO ()
+testCreditRefundTwice = withLate $ \l@Late {lStore = st} -> do
+  turns <- newTurns
+  closedOrder l "x" False
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits 160000))
+  void (recordRefund turns st "x" 9600 (at 80) >>= either (fail . show) pure)
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  void (recordRefund turns st "inv-x" 9600 (at 81) >>= either (fail . show) pure)
+  balanceOf st "x" `shouldReturn` Just (0, 19200, 19200)
+  invariantHolds st "x"
+
+testSpendAndRefundLate :: IO ()
+testSpendAndRefundLate = withLate $ \l@Late {lStore = st} -> do
+  turns <- newTurns
+  closedOrder l "x" False
+  void $ readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  coveredSpend st "c" "x" 10000 19200 `shouldReturn` Right ()
+  nrBalanceSource <$> reg st "c" `shouldReturn` Just (RegistrationId "x")
+  recordRefund turns st "x" 10000 (at 80) >>= (`shouldSatisfy` \case Left (RefundAmount 9200) -> True; _ -> False)
+  void (recordRefund turns st "x" 9200 (at 80) >>= either (fail . show) pure)
+  balanceOf st "x" `shouldReturn` Just (0, 19200, 9200)
+
+-- the view
+
+balanceAt :: DBStore -> Text -> UTCTime -> IO (Maybe J.Value)
+balanceAt st r now = fmap balanceJSON <$> withTransaction st (\db -> getBalance db (RegistrationId r) now)
+
+balanceObject :: Int -> Bool -> Maybe UTCTime -> Int -> J.Value
+balanceObject amount held heldUntil refunded = J.object ["amount" J..= amount, "held" J..= held, "heldUntil" J..= heldUntil, "refunded" J..= refunded]
+
+testHeldUntil :: IO ()
+testHeldUntil = withLate $ \l@Late {lStore = st} -> do
+  source st "funded" 10000
+  holder st "fh" "funded" 10000 (at 60) `shouldReturn` Right ()
+  source st "unfunded" 10000
+  holder st "uh" "unfunded" 10000 (at 60) `shouldReturn` Right ()
+  balanceAt st "funded" (at 30) `shouldReturn` Just (balanceObject 10000 True (Just $ at 60) 0)
+  settleAt l "fh" (SigFunded (btcPaid 100 0) PaidInPart) (at 30) `shouldReturn` Right ISOpen
+  balanceAt st "funded" (at 30) `shouldReturn` Just (balanceObject 10000 True Nothing 0)
+  balanceAt st "funded" (at 120) `shouldReturn` Just (balanceObject 10000 True Nothing 0)
+  balanceAt st "unfunded" (at 30) `shouldReturn` Just (balanceObject 10000 True (Just $ at 60) 0)
+  balanceAt st "unfunded" (at 120) `shouldReturn` Just (balanceObject 10000 False Nothing 0)
+
+testZeroBalances :: IO ()
+testZeroBalances = withLate $ \Late {lStore = st} -> do
+  turns <- newTurns
+  source st "spent" 10000
+  coveredSpend st "c" "spent" 10000 10000 `shouldReturn` Right ()
+  balanceAt st "spent" t0 `shouldReturn` Just (balanceObject 0 False Nothing 0)
+  source st "refunded" 10000
+  void (recordRefund turns st "refunded" 10000 (at 5) >>= either (fail . show) pure)
+  balanceAt st "refunded" t0 `shouldReturn` Just (balanceObject 0 False Nothing 10000)
+  placeOrderRow st "none" False 20000 (at 60)
+  balanceAt st "none" t0 `shouldReturn` Nothing
+
+testLateWaits :: IO ()
+testLateWaits = withLate $ \l@Late {lStore = st} -> do
+  mapM_ (\r -> closedOrder l r False) ["confirming", "crediting", "highspeed", "units", "floor", "alerted"]
+  settleAt l "crediting" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "highspeed" (SigClosed (btcPaid lateUnits 0) {rcvUncreditable = Just UCHighSpeed}) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "units" (SigClosed (btcPaid 0 0) {rcvAmount = CurrencyAmount 20000, rcvCrypto = Just "0.003200001", rcvUnits = Nothing, rcvUncreditable = Just UCUncounted}) (at 70) `shouldReturn` Right ISExpired
+  settleAt l "alerted" (SigClosed (btcPaid lateUnits 0)) (at 70) `shouldReturn` Right ISExpired
+  void $ alertsAt l (Right stubRate) (pastWindow (at 70) 60)
+  settleAt l "confirming" (SigClosed (btcPaid lateUnits 0)) (pastWindow (at 70) 60) `shouldReturn` Right ISExpired
+  setRate l (Right $ rateOf "31000" 31000)
+  void $ readSignal l "floor" (SigClosed (btcPaid lateUnits lateUnits))
+  placeOrderRow st "open" False 20000 (at 60)
+  settleAt l "open" (SigFunded (btcPaid lateUnits 0) PaidInFull) (at 70) `shouldReturn` Right ISOpen
+  let waits = mapM (\r -> (r,) <$> lateWaitOf st r)
+  waits ["confirming", "crediting", "highspeed", "units", "floor", "alerted", "open"]
+    `shouldReturn` [ ("confirming", Just LWConfirming),
+                     ("crediting", Just LWCrediting),
+                     ("highspeed", Just LWSupport),
+                     ("units", Just LWSupport),
+                     ("floor", Just LWSupport),
+                     ("alerted", Just LWSupport),
+                     ("open", Nothing)
+                   ]
+  setRate l (Right stubRate)
+  void $ readSignal l "alerted" (SigClosed (btcPaid lateUnits lateUnits))
+  void $ passAt l (at 71)
+  waits ["crediting", "floor", "alerted"] `shouldReturn` [("crediting", Nothing), ("floor", Just LWSupport), ("alerted", Nothing)]
+
+testFindLinks :: IO ()
+testFindLinks = withLate $ \Late {lStore = st} -> do
+  source st "paying" 10000
+  coveredSpend st "spend" "paying" 10000 10000 `shouldReturn` Right ()
+  source st "held" 10000
+  holder st "holder" "held" 10000 (at 60) `shouldReturn` Right ()
+  let links now = map (\(NameRegistration {nrId = RegistrationId r, nrBalanceSource}, heldBy') -> (r, nrBalanceSource, heldBy')) <$> withTransaction st (\db -> findRegistrations db ownerA now)
+      linked rows = filter (\(_, src, h) -> src /= Nothing || h /= Nothing) rows
+  linked <$> links (at 30) `shouldReturn` [("spend", Just (RegistrationId "paying"), Nothing), ("holder", Just (RegistrationId "held"), Nothing), ("held", Nothing, Just (RegistrationId "holder"))]
+  linked <$> links (at 120) `shouldReturn` [("spend", Just (RegistrationId "paying"), Nothing), ("holder", Just (RegistrationId "held"), Nothing)]
+
+#if defined(dbPostgres)
+-- | Each thread waits here until both arrive, after its unlocked read and before its locked transaction.
+meet :: TVar Int -> IO ()
+meet arrived = atomically (modifyTVar' arrived (+ 1)) >> atomically (readTVar arrived >>= check . (== 2))
+
+rounds :: Int
+rounds = 20
+
+testConcurrentCredits :: IO ()
+testConcurrentCredits = withServiceStores $ \open -> do
+  st <- open
+  other <- open
+  withLateOn st $ \l -> do
+    let due :: Text -> IO ()
+        due r = do
+          closedOrder l r False
+          settleAt l r (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+    forM_ [1 .. rounds] $ \n -> do
+      let r = "x" <> T.pack (show n)
+      due r
+      arrived <- newTVarIO 0
+      let readRate :: CryptoCurrency -> IO (Either ProviderError Rate)
+          readRate _ = Right stubRate <$ meet arrived
+      (a, b) <- concurrently (creditLateInvoice st readRate (invOf r) (at 80)) (creditLateInvoice other readRate (invOf r) (at 80))
+      (n, length [() | COCredited _ <- [a, b]], length [() | CONothingDue <- [a, b]]) `shouldBe` (n, 1, 1)
+      length <$> creditsOf st r `shouldReturn` 1
+      balanceOf st r `shouldReturn` Just (19200, 19200, 0)
+    refused <- forM [1 .. rounds] $ \n -> do
+      let r = "stale" <> T.pack (show n)
+      due r
+      arrived <- newTVarIO 0
+      let staleStep :: DBStore -> IO Bool
+          staleStep store = do
+            Just s <- withTransaction store (`lateCreditState` invOf r)
+            meet arrived
+            withTransaction store $ \db -> do
+              lockInvoice db (invOf r) (at 80)
+              creditLatePayment db (fromJust $ lateCreditOf s (Just stubRate)) (at 80)
+      (a, b) <- concurrently (staleStep st) (staleStep other)
+      balanceOf st r `shouldReturn` Just (19200, 19200, 0)
+      pure $ length (filter not [a, b])
+    sum refused `shouldSatisfy` (> 0)
+
+testCreditAgainstSettlement :: IO ()
+testCreditAgainstSettlement = withServiceStores $ \open -> do
+  st <- open
+  other <- open
+  otherWaiters <- newWaiters
+  withLateOn st $ \l -> forM_ [1 .. rounds] $ \n -> do
+    let r = "x" <> T.pack (show n)
+    closedOrder l r False
+    settleAt l r (SigClosed (btcPaid lateUnits 160000)) (at 70) `shouldReturn` Right ISExpired
+    arrived <- newTVarIO 0
+    let readRate :: CryptoCurrency -> IO (Either ProviderError Rate)
+        readRate _ = Right stubRate <$ meet arrived
+        raise :: IO (Either Text InvoiceStatus)
+        raise = meet arrived >> settleOrder other otherWaiters Nothing (invOf r) (SigClosed (btcPaid lateUnits lateUnits)) (at 80)
+    (credited, raised) <- concurrently (creditLateInvoice st readRate (invOf r) (at 80)) raise
+    (n, raised) `shouldBe` (n, Right ISExpired)
+    credited `shouldSatisfy` \case COCredited _ -> True; _ -> False
+    creditLateInvoice st (const $ pure $ Right stubRate) (invOf r) (at 81) >>= (`shouldSatisfy` (/= CORefused))
+    units <- map (\(u, _, _, _, _) -> u) <$> creditsOf st r
+    (n, sum (map (fromMaybe 0) units)) `shouldBe` (n, lateUnits)
+    balanceOf st r `shouldReturn` Just (19200, 19200, 0)
+#endif
@@ -392,7 +392,7 @@ advance :: Ctx -> NominalDiffTime -> IO ()
 advance Ctx {cClock} by = modifyIORef' cClock (addUTCTime by)

 registrationsOf :: Ctx -> Address -> IO [NameRegistration]
-registrationsOf Ctx {cStore} owner = withTransaction cStore (`findRegistrations` owner)
+registrationsOf Ctx {cStore, cClock} owner = readIORef cClock >>= \now -> map fst <$> withTransaction cStore (\db -> findRegistrations db owner now)

 invoiceRegistration :: Ctx -> InvoiceId -> IO NameRegistration
 invoiceRegistration Ctx {cStore} invId =
@@ -1021,7 +1021,7 @@ testLatePaymentAfterNewOrder = withOrders $ \ctx -> do
  now <- readIORef (cClock ctx)
  (newInv, _) <- placed ctx aliceOrder {oCommitment = commitmentOf 2, oTimestamp = seconds now, oDuration = durationAt now}
  logs <- capturingStderr $ settleNow ctx oldInv settled `shouldReturn` Right ISPaid
-  logs `shouldSatisfy` T.isInfixOf "refund"
+  logs `shouldSatisfy` T.isInfixOf "credited to its balance"
  old <- invoiceRegistration ctx oldInv
  (nrPhase old, nrLive old) `shouldBe` (PUnpaid, False)
  new <- invoiceRegistration ctx newInv
@@ -1055,28 +1055,28 @@ testLateBTCPayPayments = withFakeBTCPay $ \fake -> do
    let refOf inv = maybe (error "no invoice") irProviderRef <$> getInvoice st inv
        readAt ref = queueReadHint (weHints cWeb) ref >> drainHints poller
        paidLate ref fields = capturingStderr $ setInvoiceState fake ref fields >> readAt ref
-        alerted logs = T.isInfixOf "stays unpaid; refund the payment" logs
+        alerted (InvoiceId t) logs = T.isInfixOf ("invoice " <> t <> " received money after registration") logs
        later = addUTCTime 3600 orderTime
    (expired, _) <- placed ctx aliceOrder
    expiredRef <- refOf expired
    setInvoiceState fake expiredRef ["status" .= ("Expired" :: Text)]
    readAt expiredRef
    (irStatus <$>) <$> getInvoice st expired `shouldReturn` Just ISExpired
-    paidLate expiredRef ["additionalStatus" .= ("PaidLate" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)] >>= (`shouldSatisfy` alerted)
-    capturingStderr (readAt expiredRef) >>= (`shouldNotSatisfy` alerted)
+    paidLate expiredRef ["additionalStatus" .= ("PaidLate" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)] >>= (`shouldSatisfy` alerted expired)
+    capturingStderr (readAt expiredRef) >>= (`shouldNotSatisfy` alerted expired)
    (cancelled, _) <- placed ctx aliceOrder {oLabel = "dynamis", oPrice = 20000, oCommitment = commitmentOf 2}
    cancelledRef <- refOf cancelled
    cancelOpenInvoice st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) cancelled later `shouldReturn` True
-    paidLate cancelledRef ["status" .= ("Invalid" :: Text), "paymentMethodPaid" .= ("0.00078000" :: Text)] >>= (`shouldSatisfy` alerted)
+    paidLate cancelledRef ["status" .= ("Invalid" :: Text), "paymentMethodPaid" .= ("0.00078000" :: Text)] >>= (`shouldSatisfy` alerted cancelled)
    (swept, _) <- placed ctx aliceOrder {oOwner = ownerBText, oKey = keyB, oCommitment = commitmentOf 3}
    sweptRef <- refOf swept
    expireOverdue st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) later later [swept] `shouldReturn` [swept]
-    paidLate sweptRef ["paymentMethodPaid" .= ("0.00025000" :: Text)] >>= (`shouldSatisfy` alerted)
+    paidLate sweptRef ["paymentMethodPaid" .= ("0.00025000" :: Text)] >>= (`shouldSatisfy` alerted swept)
    forM_ [expired, cancelled, swept] $ \inv -> do
      r <- invoiceRegistration ctx inv
      (nrPhase r, nrLive r) `shouldBe` (PUnpaid, False)

-- | Paid in part while open, then expired by BTCPay with the same figures: one refund line, none from a restarted poller.
+-- | Paid in part while open, then expired by BTCPay with the same figures: one late payment line, none from a restarted poller.
 testOneLateAlert :: IO ()
 testOneLateAlert = withOrders $ \ctx@Ctx {cStore = st, cWeb} -> do
  (inv, _) <- placed ctx aliceOrder
@@ -1084,14 +1084,15 @@ testOneLateAlert = withOrders $ \ctx@Ctx {cStore = st, cWeb} -> do
  let paid = rcv 5000 (Just "0.00078")
      newPoller = newPollerEnv st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) (weHints cWeb) (weProviders cWeb) (poll $ weConfig cWeb)
      readWith poller = capturingStderr $ queueReadHint (weHints cWeb) ref >> drainHints poller
-      refunds = length . T.breakOnAll "refund"
+      InvoiceId invText = inv
+      refunds = length . T.breakOnAll ("invoice " <> invText <> " received money after")
  poller <- newPoller
  setSignals (cStub ctx) [(ref, SigFunded paid PaidInPart)]
  refunds <$> readWith poller `shouldReturn` 0
  setSignals (cStub ctx) [(ref, SigClosed paid)]
  logs <- readWith poller
  refunds logs `shouldBe` 1
-  logs `shouldSatisfy` T.isInfixOf "stays unpaid; refund the payment"
+  logs `shouldSatisfy` T.isInfixOf "it stays unpaid, and its money is credited to its balance once confirmed, else alerted"
  restarted <- newPoller
  refunds <$> readWith restarted `shouldReturn` 0
  (nrPhase &&& nrLive) <$> invoiceRegistration ctx inv `shouldReturn` (PUnpaid, False)
@@ -1133,7 +1134,7 @@ testCancelAlertsFunded = withOrdersCancelling (SigFunded paid PaidInPart) $ \ctx
  where
    paid = rcv 5000 (Just "0.00078")
    invoiceText (InvoiceId t) = t
-    alertOf invId = "invoice " <> invoiceText invId <> " was paid after its order closed"
+    alertOf invId = "invoice " <> invoiceText invId <> " received money after"

 testNamesOff :: IO ()
 testNamesOff = withOrders $ \ctx -> do
@@ -1168,7 +1169,7 @@ testLatePayment = withOrders $ \ctx -> do
  fst <$> post ctx ("/api/invoice/" <> T.unpack t <> "/cancel") "" `shouldReturn` 200
  closed <- invoiceRegistration ctx invId
  logs <- capturingStderr $ settleNow ctx invId settled `shouldReturn` Right ISPaid
-  logs `shouldSatisfy` T.isInfixOf ("registration " <> (\(RegistrationId r) -> r) (nrId closed) <> " stays unpaid")
+  logs `shouldSatisfy` T.isInfixOf ("registration " <> (\(RegistrationId r) -> r) (nrId closed) <> " closed; it stays unpaid")
  invoiceRegistration ctx invId `shouldReturn` closed
  r <- webGet (cClient ctx) ("/api/invoice/" <> T.unpack t)
  v <- jsonObject r
@@ -1269,7 +1270,7 @@ testCleanupIn ctx@Ctx {cStore = st} = do
  isNothing <$> getInvoice st (InvoiceId "inv-gone") `shouldReturn` True
  Just InvoiceRow {irPayment = latePayment} <- getInvoice st (InvoiceId "inv-late")
  (ipCryptoPaid <$> latePayment) `shouldBe` Just (Just "0.00078")
-  logs `shouldSatisfy` T.isInfixOf "registration late is kept because invoice inv-late received a payment"
+  logs `shouldSatisfy` T.isInfixOf "registration late is kept with its balance, because invoice inv-late received a payment"
  logs `shouldSatisfy` T.isInfixOf "registration unread is kept until the next run"
  reads' <- stubReads
  sort reads' `shouldBe` [ref "gone", ref "late"]
@@ -1345,12 +1346,15 @@ testViewFields :: IO ()
 testViewFields = withServiceStore $ \st -> withFakeEthNode $ \node -> do
  Right () <- placePaid st "r1" ownerA (order "alicebakery" 1) (addUTCTime 3600 t0)
  r <- withTransaction st $ \db -> fromJust <$> getRegistration db (RegistrationId "r1")
-  let v = objectOf $ viewJSON (testNamesConfig node) r Nothing ViewReads {vrIntentNonce = Nothing, vrUnread = []}
+  let v = objectOf $ viewJSON (testNamesConfig node) r Nothing Nothing ViewReads {vrIntentNonce = Nothing, vrUnread = []}
  sort (KM.keys v)
    `shouldBe` sort
      [ "id", "version", "moves", "linksRefused", "phase", "labelHash", "label", "owner", "commitment", "sealed", "resolver", "sponsor", "chainId", "tld",
-        "years", "duration", "price", "fromBalance", "balance", "commitTx", "registerTx", "revealAfter", "revealBefore", "intentNonce", "unread", "expiresAt", "error"
+        "years", "duration", "price", "fromBalance", "balance", "latePayment", "commitTx", "registerTx", "revealAfter", "revealBefore", "intentNonce", "unread", "expiresAt", "error"
      ]
+  field "latePayment" v `shouldBe` Just J.Null
+  let waiting w = field "latePayment" $ objectOf $ viewJSON (testNamesConfig node) r Nothing (Just w) ViewReads {vrIntentNonce = Nothing, vrUnread = []}
+  map waiting [LWConfirming, LWCrediting, LWSupport] `shouldBe` map (\t -> Just $ J.object ["waiting" .= (t :: Text)]) ["confirming", "crediting", "support"]
  map (`field` v) ["id", "phase", "owner", "tld", "chainId", "linksRefused", "label", "unread", "sponsor", "fromBalance", "balance"]
    `shouldBe` map
      Just
@@ -1391,7 +1395,7 @@ testViewUnread = withServiceStore $ \st -> withFakeEthNode $ \node -> do
  r <- withTransaction st $ \db -> fromJust <$> getRegistration db (RegistrationId "paid")
  readViewChain ct r {nrPhase = PCommitted} `shouldReturn` ViewReads Nothing ["intentNonce"]
  readViewChain ct r {nrPhase = PTaken} `shouldReturn` ViewReads Nothing []
-  let v = objectOf $ viewJSON (testNamesConfig node) r {nrPhase = PCommitted} Nothing (ViewReads Nothing ["intentNonce"])
+  let v = objectOf $ viewJSON (testNamesConfig node) r {nrPhase = PCommitted} Nothing Nothing (ViewReads Nothing ["intentNonce"])
  (field "intentNonce" v, field "unread" v) `shouldBe` (Just J.Null, Just (J.toJSON ["intentNonce" :: Text]))

 testViewBalance :: IO ()
@@ -29,7 +29,7 @@ where
 import Bots.StoreService.FakeEthNode
 import Bots.StoreService.NamesContractsTests (registrarOf, unhex)
 import Bots.StoreService.NamesOrdersTests
-import Bots.StoreService.NamesStoreTests (order, ownerA, t0)
+import Bots.StoreService.NamesStoreTests (btc, insertInvoiceRow, order, ownerA, paidOrder, t0)
 import Bots.StoreService.WebTests (capturingStderr, digestFixture, jsonObject, statusOf, webGet)
 import Control.Applicative ((<|>))
 import Control.Arrow ((&&&))
@@ -83,7 +83,7 @@ namesOwnerTests = describe "StoreService names: owner" $ do
    it "lists the owner's orders newest first, a moved, an unpaid and a lapsed one read failed included, at most 50, and 404 for none" testFind
    it "refuses another signer's signature, a stale timestamp and a malformed body" testFindRefused
  describe "another name" $ do
-    it "refuses a move from registered, queued, and committed without a refused reveal" testMoveRefusedPhases
+    it "refuses a move from registered, queued, taken, and committed without a refused reveal" testMoveRefusedPhases
    it "moves a failed order, a lapsed one, and a committed one whose links were refused, to the same name with other links too" testMoveAccepted
    it "answers a body equal to the current fields with the view unchanged, counting no move, whatever its timestamp" testMoveRepeat
    it "answers the fourth move move_limit with the current view, changing nothing" testMoveLimit
@@ -92,7 +92,9 @@ namesOwnerTests = describe "StoreService names: owner" $ do
    it "registers a failed order whose register went through, by its mined register or by ownerOf, answering registration_changed and spending a code" testMoveLanded
    it "answers name_check_unavailable when the register check cannot read the chain, changing nothing" testMoveLandedUnread
    it "spends a released code still unused when its failed order turns out registered, and alerts once when it was spent elsewhere meanwhile" testMoveLandedReleasedCode
-    it "answers a dearer name price_too_high with its price, and moves to a cheaper one at its price" testMovePrice
+    it "answers a dearer name price_too_high with its price, and moves to a cheaper one at its price, crediting the difference to its balance" testMovePrice
+    it "credits nothing for a cheaper move whose compare-and-set loses" testCheaperMoveLostRace
+    it "keeps fromBalance through a move to a cheaper name" testMoveKeepsFromBalance
    it "checks a code order's code again: code_not_covering for a shorter name, a held code kept though revoked and expired since" testMoveCodeOrder
    it "reserves a released code again while unused, else answers code_used, code_reserved, code_invalid or code_expired" testMoveReleasedCode
    it "refuses sealed over 11095 characters, a body over 16384 bytes and malformed fields, accepting the longest" testMoveSizes
@@ -209,6 +211,10 @@ rewrite Ctx {cStore, cClock} NameRegistration {nrId} change = do
      Written _ -> fromJust <$> getRegistration db nrId
      refused -> error $ "not written: " <> show refused

+-- | The amount and credited of the order's balance.
+balanceOf :: Ctx -> NameRegistration -> IO (Maybe (Int, Int))
+balanceOf Ctx {cStore} NameRegistration {nrId} = fmap (\Balance {blAmount, blCredited} -> (blAmount, blCredited)) <$> withTransaction cStore (\db -> getBalance db nrId orderTime)
+
 stored :: Ctx -> NameRegistration -> IO NameRegistration
 stored ctx = registrationById ctx . nrId

@@ -337,7 +343,7 @@ testFind = withOwner $ \ctx@Ctx {cStore} -> do
      case entries of
        lapsedEntry : unpaidEntry : moveEntry : _ -> do
          (field "phase" lapsedEntry, nrPhase lapsed) `shouldBe` (Just "failed", PCommitted)
-          sort (KM.keys unpaidEntry) `shouldBe` sort ["registrationId", "invoiceId", "phase", "createdAt", "labelHash", "sealed"]
+          sort (KM.keys unpaidEntry) `shouldBe` sort ["registrationId", "invoiceId", "phase", "createdAt", "labelHash", "sealed", "balanceSource", "heldBy"]
          unpaidEntry
            `shouldBe` KM.fromList
              [ ("registrationId", idText $ nrId paid),
@@ -345,7 +351,9 @@ testFind = withOwner $ \ctx@Ctx {cStore} -> do
                ("phase", "unpaid"),
                ("createdAt", J.toJSON orderTime),
                ("labelHash", labelHashText "alicebakery"),
-                ("sealed", "sealed-alicebakery-1")
+                ("sealed", "sealed-alicebakery-1"),
+                ("balanceSource", J.Null),
+                ("heldBy", J.Null)
              ]
          moveEntry
            `shouldBe` KM.fromList
@@ -354,7 +362,9 @@ testFind = withOwner $ \ctx@Ctx {cStore} -> do
                ("phase", "queued"),
                ("createdAt", J.toJSON $ addUTCTime 50 t0),
                ("labelHash", labelHashText "alicebakers"),
-                ("sealed", "sealed-alicebakers-10")
+                ("sealed", "sealed-alicebakers-10"),
+                ("balanceSource", J.Null),
+                ("heldBy", J.Null)
              ]
        _ -> expectationFailure "fewer than three entries"
    other -> expectationFailure $ "find refused: " <> show other
@@ -386,7 +396,8 @@ testMoveRefusedPhases = withOwner $ \ctx -> do
  registeredOrder <- paidIn ctx aliceOrder registeredPhase
  committedOrder <- paidIn ctx aliceOrder {oCommitment = commitmentOf 2, oTimestamp = seconds orderTime + 1} committedPhase
  queuedOrder <- paidIn ctx dynamisOrder id
-  forM_ [registeredOrder, committedOrder, queuedOrder] $ \r -> do
+  takenOrder <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 4} takenPhase
+  forM_ [registeredOrder, committedOrder, queuedOrder, takenOrder] $ \r -> do
    (nrPhase r,) <$> move ctx keyA r to `shouldReturn` (nrPhase r, refusedWith 400 "bad_request")
    stored ctx r `shouldReturn` r

@@ -562,11 +573,46 @@ testMovePrice = withOwner $ \ctx -> do
  toDynamis <- moveTo ctx "dynamis" 10
  move ctx keyA cheap toDynamis `shouldReturn` (409, Just $ KM.fromList [("error", "price_too_high"), ("price", J.Number 20000)])
  stored ctx cheap `shouldReturn` cheap
-  dear <- paidIn ctx (byB dynamisOrder) takenPhase
+  balanceOf ctx cheap `shouldReturn` Nothing
+  dear <- paidIn ctx (byB dynamisOrder) failedPhase
  toCheaper <- moveTo ctx "alicebakers" 11
  v <- moved ctx keyB dear toCheaper
-  (field "price" v, field "phase" v) `shouldBe` (Just (J.Number 10000), Just "queued")
+  (field "price" v, field "phase" v, field "fromBalance" v) `shouldBe` (Just (J.Number 10000), Just "queued", Just (J.Number 0))
+  field "balance" v `shouldBe` Just (J.object ["amount" J..= (10000 :: Int), "held" J..= False, "heldUntil" J..= J.Null, "refunded" J..= (0 :: Int)])
  nrPrice <$> stored ctx dear `shouldReturn` 10000
+  balanceOf ctx dear `shouldReturn` Just (10000, 10000)
+
+testCheaperMoveLostRace :: IO ()
+testCheaperMoveLostRace = withOwner $ \ctx@Ctx {cNode} -> do
+  answerFree ctx "alicebakers"
+  r <- paidIn ctx dynamisOrder failedPhase
+  to <- moveTo ctx "alicebakers" 10
+  -- held at the register check's ownerOf read, inside the turns
+  (moving, gate) <- pausedAt cNode "eth_call" $ move ctx keyA r to
+  changed <- rewrite ctx r id
+  releaseGate gate
+  fst <$> within "the move" (wait moving) `shouldReturn` 409
+  stored ctx r `shouldReturn` changed
+  balanceOf ctx r `shouldReturn` Nothing
+
+-- | dynamis for 20000, 5000 of it from another order's balance, moved to alicebakers for 10000.
+testMoveKeepsFromBalance :: IO ()
+testMoveKeepsFromBalance = withOwner $ \ctx@Ctx {cStore} -> do
+  answerFree ctx "alicebakers"
+  paying <- paidIn ctx (byB aliceOrder) failedPhase
+  withTransaction cStore $ \db -> creditBalance db (nrId paying) 5000 orderTime
+  let fields = OrderFields {ofLabelHash = labelHash "dynamis", ofLength = 7, ofDuration = yearsDuration 2 orderTime, ofCommitment = commitmentOf 3, ofSealed = "sealed-dynamis-3"}
+      new = NewRegistration {nrgId = RegistrationId "diff", nrgOwner = ownerA, nrgOrder = fields, nrgYears = 2}
+  withTransaction cStore $ \db -> do
+    insertInvoiceRow db "inv-diff" (addUTCTime 3600 orderTime) "open"
+    createPaidRegistration db new (OTBalance (nrId paying) 20000 5000 (Just btc)) (paidOrder "inv-diff") {poPrice = 20000} orderTime `shouldReturn` Right ()
+  settleNow ctx (InvoiceId "inv-diff") settled `shouldReturn` Right ISPaid
+  r <- registrationById ctx (RegistrationId "diff") >>= \d -> rewrite ctx d failedPhase
+  to <- moveTo ctx "alicebakers" 11
+  v <- moved ctx keyA r to
+  (field "price" v, field "fromBalance" v) `shouldBe` (Just (J.Number 10000), Just (J.Number 5000))
+  balanceOf ctx r `shouldReturn` Just (10000, 10000)
+  balanceOf ctx paying `shouldReturn` Just (0, 5000)

 testMoveCodeOrder :: IO ()
 testMoveCodeOrder = withOwner $ \ctx@Ctx {cStore} -> do
@@ -183,7 +183,7 @@ testNamesColumns = withServiceStore $ \st -> do
      "years", "duration", "expires_at", "price", "name_prepaid_code_id", "registered_at", "failed_at", "error", "created_at",
      "updated_at", "version", "live", "order_hash", "method", "moves", "links_refused_at", "balance_source", "balance_used"
    ]
-  has "sx_badge_service_name_invoices" ["invoice_id", "registration_id", "provider_ref", "late_alerted_at", "late_alerted_units"]
+  has "sx_badge_service_name_invoices" ["invoice_id", "registration_id", "provider_ref", "late_alerted_at", "late_alerted_units", "late_support"]
  has "sx_badge_service_name_balances" ["registration_id", "amount", "credited", "refunded", "reserved_by", "refunded_at", "created_at", "updated_at"]
  has "sx_badge_service_name_late_credits" ["invoice_id", "credit_no", "registration_id", "units", "invoice_rate", "current_rate", "rate_used", "cents", "created_at"]
  has "sx_badge_service_payments" balancePaymentColumns
@@ -194,7 +194,7 @@ testNamesDownUp :: IO ()
 testNamesDownUp = withServiceStore $ \st -> do
  let names = dropWhile ((/= "20261010_names") . name) storeServiceSchemaMigrations
      badgeColumns = mapM (fmap sort . columnsOf st) badgeTables
-  map name names `shouldBe` ["20261010_names", "20261022_drop_taken_codes", "20261022_name_balances"]
+  map name names `shouldBe` ["20261010_names", "20261022_drop_taken_codes", "20261022_name_balances", "20261022_name_late_wait"]
  badgeBefore <- badgeColumns
  code <- issue st 1 usable
  placeCode st "r1" ownerA (order "alicebakery" 1) code `shouldReturn` Right ()
@@ -503,9 +503,10 @@ testLiveFollowsPhase = withServiceStore $ \st -> do
        write st r {nrPhase = phase} `shouldReturn` Written (nrVersion r + 1)
        (nrPhase &&& nrLive) <$> reg st rid `shouldReturn` (phase, expected)
  step "r1" PQueued True
-  step "r1" PTaken True
  step "r1" PFailed True
-  step "r1" PTaken True
+  step "r1" PTaken False
+  r1 <- reg st "r1"
+  write st r1 {nrPhase = PFailed} `shouldReturn` NotLive
  step "r2" PRegistering True
  step "r2" PTaken False
  placePaid st "r3" ownerA (order "carolsbakery" 3) (at 60) `shouldReturn` Right ()
@@ -520,7 +521,7 @@ testOrderLive = withServiceStore $ \st -> do
  let code = paid {nrPayment = RPCode 1}
      liveIn r phase = (phase, orderLive r {nrPhase = phase})
  map (liveIn paid) [minBound .. maxBound]
-    `shouldBe` [(PUnpaid, True), (PQueued, True), (PCommitting, True), (PCommitted, True), (PRegistering, True), (PRegistered, False), (PTaken, True), (PFailed, True)]
+    `shouldBe` [(PUnpaid, True), (PQueued, True), (PCommitting, True), (PCommitted, True), (PRegistering, True), (PRegistered, False), (PTaken, False), (PFailed, True)]
  map (liveIn code) [PTaken, PFailed, PRegistered] `shouldBe` [(PTaken, False), (PFailed, True), (PRegistered, False)]
  orderLive paid {nrLive = False} `shouldBe` False
  orderLive paid {nrLive = False, nrPhase = PQueued} `shouldBe` True
@@ -559,13 +560,13 @@ testWriteMeetsLiveOrder = withServiceStore $ \st -> do
  placePaid st "r2" ownerA held (at 60) `shouldReturn` Right ()
  placePaid st "r3" ownerB (order "carolsbakery" 3) (at 60) `shouldReturn` Right ()
  r1 <- reg st "r1"
-  write st r1 {nrPhase = PTaken} `shouldReturn` Written 2
-  taken <- reg st "r1"
-  let retarget o = withTransaction st $ \db -> retargetRegistration db taken o 10000 (at 6)
+  write st r1 {nrPhase = PFailed} `shouldReturn` Written 2
+  failed <- reg st "r1"
+  let retarget o = withTransaction st $ \db -> retargetRegistration db failed o 10000 (at 6)
  retarget held {ofCommitment = digestFixture 4} `shouldReturn` LiveOrderExists
  r3 <- reg st "r3"
  retarget (order "carolsbakery" 5) {ofCommitment = nrCommitment r3} `shouldReturn` LiveOrderExists
-  reg st "r1" `shouldReturn` taken
+  reg st "r1" `shouldReturn` failed
  retarget (order "davesbakery" 6) `shouldReturn` Written 3

 testRetarget :: IO ()
@@ -574,9 +575,9 @@ testRetarget = withServiceStore $ \st -> do
      o' = order "alicebakers" 2
  placePaid st "r1" ownerA o (at 60) `shouldReturn` Right ()
  r <- reg st "r1"
-  let taken =
+  let failed =
        r
-          { nrPhase = PTaken,
+          { nrPhase = PFailed,
            nrReveal = Just reveal,
            nrCommitTx = Just (TxHash $ digestFixture 8),
            nrCommitBlock = Just 100,
@@ -588,8 +589,8 @@ testRetarget = withServiceStore $ \st -> do
            nrFailedAt = Just (at 5),
            nrError = Just "failed"
          }
-  write st taken `shouldReturn` Written 2
-  withTransaction st (\db -> retargetRegistration db taken {nrVersion = 2} o' 10000 (at 6)) `shouldReturn` Written 3
+  write st failed `shouldReturn` Written 2
+  withTransaction st (\db -> retargetRegistration db failed {nrVersion = 2} o' 10000 (at 6)) `shouldReturn` Written 3
  r' <- reg st "r1"
  r'
    `shouldBe` r
@@ -602,7 +603,7 @@ testRetarget = withServiceStore $ \st -> do
        nrMoves = 1,
        nrUpdatedAt = at 6
      }
-  withTransaction st (\db -> retargetRegistration db taken {nrVersion = 2} o 10000 (at 7)) `shouldReturn` VersionChanged
+  withTransaction st (\db -> retargetRegistration db failed {nrVersion = 2} o 10000 (at 7)) `shouldReturn` VersionChanged

 testFind :: IO ()
 testFind = withServiceStore $ \st -> do
@@ -612,9 +613,9 @@ testFind = withServiceStore $ \st -> do
    insertInvoiceRow db ("inv-" <> rid) (at 60) "open"
    createPaidRegistration db (newReg rid ownerA o) (OTInvoice btc price) (paidOrder $ "inv-" <> rid) (at i) `shouldReturn` Right ()
  placePaid st "other" ownerB (order "bobsbakery" 99) (at 60) `shouldReturn` Right ()
-  found <- withTransaction st $ \db -> findRegistrations db ownerA
-  map nrId found `shouldBe` [RegistrationId $ "r" <> T.pack (show i) | i <- [52, 51 .. 3 :: Int]]
-  withTransaction st (\db -> findRegistrations db (address "0x0000000000000000000000000000000000000001")) `shouldReturn` []
+  found <- withTransaction st $ \db -> findRegistrations db ownerA t0
+  map (nrId . fst) found `shouldBe` [RegistrationId $ "r" <> T.pack (show i) | i <- [52, 51 .. 3 :: Int]]
+  withTransaction st (\db -> findRegistrations db (address "0x0000000000000000000000000000000000000001") t0) `shouldReturn` []

 testSameSecondOrder :: IO ()
 testSameSecondOrder = withServiceStore $ \st -> do
@@ -624,7 +625,7 @@ testSameSecondOrder = withServiceStore $ \st -> do
    placePaid st rid ownerA (order ("alicebakery" <> rid) n) (at 60) `shouldReturn` Right ()
    r <- reg st rid
    write st r {nrPhase = PQueued} `shouldReturn` Written 2
-  map nrId <$> withTransaction st (`findRegistrations` ownerA) `shouldReturn` map RegistrationId ["r3", "r2", "r1"]
+  map (nrId . fst) <$> withTransaction st (\db -> findRegistrations db ownerA t0) `shouldReturn` map RegistrationId ["r3", "r2", "r1"]
  map nrId <$> withTransaction st activeRegistrations `shouldReturn` map RegistrationId ["r1", "r2", "r3"]
  forM_ ["r5", "r4"] $ \rid -> do
    placePaid st rid ownerB o (at 60) `shouldReturn` Right ()
@@ -10,11 +10,14 @@ import Bots.StoreService.NamesContractsTests (availableCall, maxCommitmentAgeCal
 import Bots.StoreService.NamesOrdersTests
 import Bots.StoreService.NamesOwnerTests (answerExpiry, answerFree, answerOwner, answerUnowned, byB, codeIn, committedPhase, dynamisOrder, failedPhase, labelBytes, ownerOfSelector, paidIn, rewrite, sentRegister, stored)
 import Bots.StoreService.NamesPhasesTests (held, prompt, registrationPath, woken)
-import Bots.StoreService.NamesStoreTests (reveal)
+import Bots.StoreService.NamesStoreTests (btc, insertInvoiceRow, ownerA, paidOrder, reveal)
 import Bots.StoreService.WebTests (capturingStderr, jsonObject, statusOf, webGet, webRequestBody)
 import Control.Applicative ((<|>))
 import Control.Arrow ((&&&))
+import Control.Concurrent (threadDelay)
+import qualified Control.Concurrent.Async as Async
 import Control.Concurrent.Async (wait, withAsync)
+import qualified Control.Exception as E
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
 import Control.Concurrent.STM (atomically, check)
 import Control.Monad (forM_, replicateM, replicateM_, void)
@@ -30,6 +33,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Data.Word (Word64)
 import Network.HTTP.Client (defaultManagerSettings, newManager)
 import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus (..))
 import Simplex.Messaging.Agent.Store.Common (withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Crypto (keccak256)
@@ -43,6 +47,7 @@ import StoreService.Names.Phases (RegistrationId (..), awaitChange)
 import StoreService.Names.Registration (RegisterIntent (..), commitCalldata, registerIntentDigest, registerWithCreditCalldata, sponsorDomain)
 import StoreService.Names.Reveal (intentOf)
 import StoreService.Names.Sender
+import StoreService.Names.Signatures (OrderFields (..))
 import StoreService.Names.Store
 import StoreService.Names.Turns (labelTurnCount, withLabelTurn)
 import StoreService.Names.Worker
@@ -54,7 +59,16 @@ import System.Timeout (timeout)
 import Test.Hspec

 namesWorkerTests :: Spec
-namesWorkerTests = describe "StoreService names: worker" $ do
+namesWorkerTests = workerTests >> takenBalanceTests
+
+takenBalanceTests :: Spec
+takenBalanceTests = describe "StoreService names: balance life" $ describe "taken" $ do
+  it "credits a taken order paid wholly from a balance, and one paid partly, its whole price as a balance of its own, the source's left as it was" testTakenFromBalance
+  it "leaves the order as it was when the taken write's credit is refused, in one transaction" testTakenCreditRefused
+  it "wakes a held poll with the taken write, and not with a change of the order's balance" testTakenWakesPoll
+
+workerTests :: Spec
+workerTests = describe "StoreService names: worker" $ do
  describe "commit" $ do
    it "commits, waits for the reveal and revealAfter, and registers a code order, spending its code and publishing each change" testCommitWaitRegister
    it "waits for a pending commit without sending another, following its fee-bumped replacement" testPendingCommit
@@ -68,8 +82,8 @@ namesWorkerTests = describe "StoreService names: worker" $ do
    it "writes nothing when the registration changed since it was read" testLostRace
    it "writes in the name's turn" testInNameTurn
  describe "register" $ do
-    it "ends the later of two wallets' paid orders for one name taken, with its value kept" testTwoWallets
-    it "ends taken on any revert while the name is not available, releasing a code" testRevertTaken
+    it "ends the later of two wallets' paid orders for one name taken, not live, with a balance of its price" testTwoWallets
+    it "ends taken on any revert while the name is not available, releasing a code and keeping no balance" testRevertTaken
    it "keeps the phase on NameNotAvailable while the name still reads available, as for a pending competitor" testPendingCompetitor
    it "ends failed on a revert while the name is available, alerting on InsufficientAllowance and keeping a code" testRevertFailed
    it "clears the reveal on InvalidNonce, staying committed" testInvalidNonce
@@ -484,9 +498,78 @@ testTwoWallets = withWorker $ \w@W {wCtx = ctx} -> do
  dryRunsRevert w "NameNotAvailable(string)" $ abiTuple [Dynamic $ abiBytes "alicebakery"]
  published w b (steps w b) >>= done
  x <- stored ctx b
-  (nrPhase x, nrLive x, nrPrice x, nrPayment x, nrError x) `shouldBe` (PTaken, True, nrPrice b, nrPayment b, Nothing)
+  (nrPhase x, nrLive x, nrPrice x, nrPayment x, nrError x) `shouldBe` (PTaken, False, nrPrice b, nrPayment b, Nothing)
+  fmap (\Balance {blAmount, blCredited, blHold} -> (blAmount, blCredited, blHold)) <$> withTransaction (cStore ctx) (\db -> getBalance db (nrId b) orderTime)
+    `shouldReturn` Just (nrPrice b, nrPrice b, Nothing)
  length <$> sent w `shouldReturn` 1

+-- | The order of alicebakery, by owner A, with this commitment.
+aliceFields :: Int -> OrderFields
+aliceFields n = OrderFields {ofLabelHash = labelHash "alicebakery", ofLength = 11, ofDuration = yearsDuration 2 orderTime, ofCommitment = commitmentOf n, ofSealed = "sealed-alicebakery-" <> tshow n}
+
+aliceRegistration :: Text -> Int -> NewRegistration
+aliceRegistration rid n = NewRegistration {nrgId = RegistrationId rid, nrgOwner = ownerA, nrgOrder = aliceFields n, nrgYears = 2}
+
+-- | The amount and credited of the order's balance.
+balanceFigures :: Ctx -> RegistrationId -> IO (Maybe (Int, Int))
+balanceFigures Ctx {cStore} rid = fmap (\Balance {blAmount, blCredited} -> (blAmount, blCredited)) <$> withTransaction cStore (\db -> getBalance db rid orderTime)
+
+-- | The register's dry run reverts on a name someone else holds, so the registration ends taken.
+endsTaken :: W -> NameRegistration -> IO ()
+endsTaken w@W {wCtx = Ctx {cNode}} r = do
+  answerAvailable w False
+  setFault cNode "eth_estimateGas" $ RpcError 3 "execution reverted: ERC721: invalid token ID" Nothing
+  published w r (steps w r) >>= done
+
+testTakenFromBalance :: IO ()
+testTakenFromBalance = withWorker $ \w@W {wCtx = ctx@Ctx {cStore}} -> do
+  let price = oPrice aliceOrder
+  wholly <- paidIn ctx (byB dynamisOrder) failedPhase
+  partly <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 5} failedPhase
+  withTransaction cStore $ \db -> creditBalance db (nrId wholly) 30000 orderTime >> creditBalance db (nrId partly) 4000 orderTime
+  withTransaction cStore (\db -> createBalanceRegistration db (aliceRegistration "covered" 1) (nrId wholly) price 30000 orderTime) `shouldReturn` Right ()
+  covered <- registrationById ctx (RegistrationId "covered") >>= \r -> rewrite ctx r openPhase >>= revealed ctx keyA "alicebakery"
+  endsTaken w covered
+  (\x -> (nrPhase x, nrLive x, nrPayment x)) <$> stored ctx covered `shouldReturn` (PTaken, False, RPBalance)
+  balanceFigures ctx (nrId covered) `shouldReturn` Just (price, price)
+  balanceFigures ctx (nrId wholly) `shouldReturn` Just (30000 - price, 30000)
+  withTransaction cStore $ \db -> do
+    insertInvoiceRow db "inv-diff" (addUTCTime 3600 orderTime) "open"
+    createPaidRegistration db (aliceRegistration "diff" 2) (OTBalance (nrId partly) price 4000 (Just btc)) (paidOrder "inv-diff") {poPrice = price} orderTime `shouldReturn` Right ()
+  settleNow ctx (InvoiceId "inv-diff") settled `shouldReturn` Right ISPaid
+  balanceFigures ctx (nrId partly) `shouldReturn` Just (0, 4000)
+  diff <- registrationById ctx (RegistrationId "diff") >>= \r -> rewrite ctx r openPhase >>= revealed ctx keyA "alicebakery"
+  endsTaken w diff
+  nrPhase <$> stored ctx diff `shouldReturn` PTaken
+  balanceFigures ctx (nrId diff) `shouldReturn` Just (price, price)
+  balanceFigures ctx (nrId partly) `shouldReturn` Just (0, 4000)
+
+-- | A price the balance's CHECK refuses makes the credit fail inside the taken write's transaction.
+testTakenCreditRefused :: IO ()
+testTakenCreditRefused = withWorker $ \w@W {wCtx = ctx@Ctx {cStore, cNode}} -> do
+  r <- paidIn ctx aliceOrder openPhase >>= revealed ctx keyA "alicebakery"
+  withTransaction cStore $ \db -> DB.execute db "UPDATE sx_badge_service_name_registrations SET price = -1 WHERE registration_id = ?" [(\(RegistrationId t) -> t) $ nrId r]
+  unchanged <- stored ctx r
+  answerAvailable w False
+  setFault cNode "eth_estimateGas" $ RpcError 3 "execution reverted: ERC721: invalid token ID" Nothing
+  void (E.try (steps w r) :: IO (Either E.SomeException Next))
+  stored ctx r `shouldReturn` unchanged
+  balanceFigures ctx (nrId r) `shouldReturn` Nothing
+
+testTakenWakesPoll :: IO ()
+testTakenWakesPoll = withWorker $ \w@W {wCtx = ctx@Ctx {cStore}} -> do
+  r <- paidIn ctx aliceOrder openPhase >>= revealed ctx keyA "alicebakery"
+  waiting <- held ctx (0, 1) $ registrationPath (nrId r) <> "?seenVersion=" <> show (nrVersion r)
+  withTransaction cStore $ \db -> creditBalance db (nrId r) 500 orderTime
+  threadDelay shortWait
+  isJust <$> Async.poll waiting `shouldReturn` False
+  endsTaken w r
+  (status, view) <- woken "the registration poll" waiting
+  (status, field "phase" view) `shouldBe` (200, Just "taken")
+  balanceFigures ctx (nrId r) `shouldReturn` Just (500 + oPrice aliceOrder, 500 + oPrice aliceOrder)
+  where
+    shortWait = 500000
+
 testPendingCompetitor :: IO ()
 testPendingCompetitor = withWorker $ \w@W {wCtx = ctx} -> do
  (r, code) <- codeIn ctx 8 aliceOrder openPhase >>= traverseFst (revealed ctx keyA "alicebakery")
@@ -512,6 +595,7 @@ testRevertTaken = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}} -> do
  (nrPhase x, nrLive x) `shouldBe` (PTaken, False)
  PrepaidCode {pcReservedBy, pcSpentAt} <- codeOf ctx code
  (pcReservedBy, pcSpentAt) `shouldBe` (Nothing, Nothing)
+  balanceFigures ctx (nrId r) `shouldReturn` Nothing
  sent w `shouldReturn` []

 testRevertFailed :: IO ()
@@ -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.
@@ -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
@@ -2435,8 +2455,8 @@ testSettledPaymentIsNotDowngraded :: IO ()
 testSettledPaymentIsNotDowngraded = bounded "settled is not downgraded" $ withServiceStore $ \st -> do
  iid <- seedOpen st
  row <- getInvoice st iid >>= maybe (failWith "no invoice row") pure
-  withTransaction st $ \db -> upsertPayment db row PSSettled (CurrencyAmount 500) (Just "0.00050000") Nothing False settleAt
-  withTransaction st $ \db -> upsertPayment db row PSPending (CurrencyAmount 200) (Just "0.00020000") Nothing False replayAt
+  withTransaction st $ \db -> upsertPayment db row PSSettled (rcv 500 (Just "0.00050000")) False settleAt
+  withTransaction st $ \db -> upsertPayment db row PSPending (rcv 200 (Just "0.00020000")) False replayAt
  p <- paymentRow st iid
  ipStatus p `shouldBe` "settled"
  ipUpdatedAt p `shouldBe` settleAt
@@ -2445,8 +2465,8 @@ testSettledPaymentIsNotDowngraded = bounded "settled is not downgraded" $ withSe
  let second' = sampleInvoice {niInvoiceId = InvoiceId "inv-pending", niProviderRef = "p-pending", niCodeHash = digestFixture 16}
  createInvoiceRows st second' `shouldReturn` Right ()
  row' <- getInvoice st (niInvoiceId second') >>= maybe (failWith "no invoice row") pure
-  withTransaction st $ \db -> upsertPayment db row' PSPending (CurrencyAmount 100) Nothing Nothing False settleAt
-  withTransaction st $ \db -> upsertPayment db row' PSSettled (CurrencyAmount 500) (Just "0.00050000") Nothing False replayAt
+  withTransaction st $ \db -> upsertPayment db row' PSPending (rcv 100 Nothing) False settleAt
+  withTransaction st $ \db -> upsertPayment db row' PSSettled (rcv 500 (Just "0.00050000")) False replayAt
  p' <- paymentRow st (niInvoiceId second')
  ipStatus p' `shouldBe` "settled"
  ipUpdatedAt p' `shouldBe` replayAt
@@ -11,6 +11,7 @@ import Bots.StoreService.GroupIntegrationTests
 import Bots.StoreService.GroupTests
 import Bots.StoreService.NameRegistrationTests
 import Bots.StoreService.NamesBalancesTests
+import Bots.StoreService.NamesLateCreditTests
 import Bots.StoreService.NamesChainTests
 import Bots.StoreService.NamesCodesTests
 import Bots.StoreService.NamesContractsTests
@@ -106,6 +107,7 @@ main = do
        badgeNameRegistrationTests
      namesConfigTests
      namesBalancesTests
+      namesLateCreditTests
      namesChainTests
      namesCodesTests
      namesContractsTests