store: spend holds and credit late payments

2026-11-04 06:32:59 +00:00 · 2026-10-22 15:29:37 +00:00
1 parent bb7c954d18
commit 586351d924
@@ -0,0 +1,94 @@
+{-# 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 (..))
+import StoreService.Providers.BTCPay (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
+
+-- | CORefused: the credit's number was taken meanwhile, which the invoice's lock rules out.
+data CreditOutcome
+  = CONothingDue
+  | COCredited LateCredit
+  | 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 | closedUnpaid s && moneyDue s -> case lsCoin s of
+      Nothing -> credit Nothing
+      Just coin ->
+        readRate coin >>= \case
+          Left e -> pure $ CORateFailed e
+          Right rate -> case invoiceRate s of
+            Nothing -> pure $ CORateFailed $ ProviderError "the invoice's rate is not stored"
+            Just (invoiceText, invoiceValue)
+              | 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 | closedUnpaid s, Just c <- lateCreditOf s rate -> do
+          applied <- creditLatePayment db c now
+          pure $ if applied then COCredited c else CORefused
+        _ -> pure CONothingDue
+
+closedUnpaid :: LateCreditState -> Bool
+closedUnpaid LateCreditState {lsPhase, lsLive} = lsPhase == PUnpaid && not lsLive
+
+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}
@@ -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, (:.) (..))
@@ -293,13 +297,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 +333,27 @@ 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, or unconfirmed money alerted past the read window.
+data LateSupport = LSHighSpeed | LSUnits | LSRateFloor | LSUnconfirmed
+  deriving (Eq, Show, Enum, Bounded)
+
+instance TextEncoding LateSupport where
+  textEncode = \case
+    LSHighSpeed -> "high_speed"
+    LSUnits -> "units"
+    LSRateFloor -> "rate_floor"
+    LSUnconfirmed -> "unconfirmed"
+  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,
@@ -1043,25 +1070,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
@@ -1086,6 +1114,21 @@ latePending db (InvoiceId invId) =
  maybe Nothing fromOnly . listToMaybe
    <$> DB.query db ("SELECT" <> pendingCase <> lateFrom <> " WHERE ni.invoice_id = ? AND" <> closedUnpaid) (invId, PUnpaid)

+-- | 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.
 uncreditedLateInvoices :: DB.Connection -> IO [InvoiceId]
 uncreditedLateInvoices db =
@@ -1117,22 +1160,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,6 +102,11 @@ 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.
 balanceJSON :: Balance -> J.Value
@@ -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,26 @@ 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
+
 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 confirmed money is credited to its balance")
+
+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)
+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,117 @@ 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
+          _ -> 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
+    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
+      let alert = "names: invoice " <> invText <> " is not credited: the current rate " <> rateText <> " is below half its rate " <> invoiceRate <> "; a glitch, or a real fall the owner decides on"
+      due <- dueToWarn env now alert
+      when due $ logError alert
+    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)
+
+lateReason :: PollerEnv -> LateAlert -> IO (Text, Maybe LateSupport)
+lateReason env@PollerEnv {peStore, peProviders} LateAlert {laPending, laState = LateCreditState {lsInvoice, lsCoin, lsSupport, lsInvoiceRate}} = case laPending of
+  LPUncounted -> pure (uncounted, Nothing)
+  _ | lsSupport == Just LSHighSpeed -> pure (highSpeed, Nothing)
+  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 -> either (const (rateRead, Nothing)) (\Rate {rateText} -> (rateFloor rateText, Nothing)) <$> cachedRate env p coin
+            _ -> pure (rateRead, Nothing)
+      | otherwise -> pure (rateRead, 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"
+    rateRead = "confirmed, the credit waits on the rate read; do not refund; fix the rate read"
+    cardWaits = "confirmed, the credit waits on the poller's credit pass; do not refund; check the service log"
+    rateFloor current = "confirmed; the coin's price fell by more than half since the invoice (" <> fromMaybe "?" lsInvoiceRate <> ", " <> current <> "); the owner decides: credit at the current rate, or refund by hand"
+    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"
+    unitName = \case
+      CCBtc -> "satoshi"
+      CCXmr -> "piconero"
+
 -- | 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} =
@@ -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.
@@ -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
@@ -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
@@ -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,664 @@
+{-# 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, logging an error, and alerts naming both rates and the owner's decision" testRateFloor
+    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
+  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 balance spent to 0 and a refunded one as objects with amount 0" testZeroBalances
+    it "waits confirming, crediting, or support for each reason, and on nothing once all is credited" testLateWaits
+#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 "s" 10000
+  holder st "h" "s" 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 ("s" :: Text))
+  logs <- capturingStderr $ settleAt l "h" (SigSettled (btcPaid 480000 480000) (at 10)) (at 10) `shouldReturn` Right ISPaid
+  logs `shouldSatisfy` logged "ERROR" "queued registration h as paid, but the balance of registration s it held could not be spent"
+  nrPhase <$> reg st "h" `shouldReturn` PQueued
+  balanceOf st "s" `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 "s" 10000
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  settleAt l "h" (SigClosed nothingPaid) (at 61) `shouldReturn` Right ISExpired
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Nothing)
+  logs <- readSignal l "h" (SigClosed (btcPaid lateUnits lateUnits))
+  logs `shouldSatisfy` logged "INFO" "invoice inv-h credited 19200 cents to the balance of registration h for 320000 units at 60000.5 (invoice 62500, current 60000.5)"
+  logs `shouldNotSatisfy` T.isInfixOf "[ERROR"
+  balanceOf st "h" `shouldReturn` Just (19200, 19200, 0)
+  creditsOf st "h" `shouldReturn` [(Just lateUnits, Just "62500", Just "60000.5", Just "60000.5", 19200)]
+  figures st "s" 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 "x" False
+  let seenAt = at (60 * 24 * 5)
+      alert = "invoice inv-x of order x: 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 "x" (SigClosed (btcPaid lateUnits 0)) seenAt `shouldReturn` Right ISExpired
+  alertsAt l (Right stubRate) (pastWindow seenAt (-60)) >>= (`shouldNotSatisfy` T.isInfixOf "invoice inv-x of order x")
+  lateWaitOf st "x" `shouldReturn` Just LWConfirming
+  logs <- alertsAt l (Right stubRate) (pastWindow seenAt 60)
+  (count alert logs, logged "ERROR" alert logs) `shouldBe` (1, True)
+  lateWaitOf st "x" `shouldReturn` Just LWSupport
+  alertsAt l (Right stubRate) (pastWindow seenAt (24 * 3600 + 60)) >>= (`shouldNotSatisfy` T.isInfixOf "invoice inv-x of order x")
+  balanceOf st "x" `shouldReturn` Nothing
+
+testPartCreditAlerted :: IO ()
+testPartCreditAlerted = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  settleAt l "x" (SigClosed (btcPaid lateUnits 160000)) (at 100) `shouldReturn` Right ISExpired
+  void $ passAt l (at 101)
+  balanceOf st "x" `shouldReturn` Just (9600, 9600, 0)
+  logs <- alertsAt l (Right stubRate) (pastWindow (at 100) 60)
+  count "invoice inv-x of order x: 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-x")
+
+testMoneroZero :: IO ()
+testMoneroZero = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  logs <- readSignal l "x" (SigFunded (btcPaid 0 0) {rcvCrypto = Nothing} PaidInFull)
+  logs `shouldSatisfy` logged "INFO" "invoice inv-x holds money of its closed order not yet confirmed"
+  withTransaction st (\db -> latePending db (invOf "x")) `shouldReturn` Just LPConfirming
+  now <- getCurrentTime
+  alertsAt l (Right stubRate) (addUTCTime 3600 now) >>= (`shouldNotSatisfy` T.isInfixOf "invoice inv-x")
+  balanceOf st "x" `shouldReturn` Nothing
+
+testRateFails :: IO ()
+testRateFails = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  closedOrder l "y" False
+  setRate l (Left $ ProviderError "rates down")
+  logs <- readSignal l "x" (SigClosed (btcPaid lateUnits lateUnits))
+  settleAt l "y" (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" (logs <> more) `shouldBe` 1
+  lateWaitOf st "x" `shouldReturn` Just LWCrediting
+  mapM (balanceOf st) ["x", "y"] `shouldReturn` [Nothing, Nothing]
+  setRate l (Right stubRate)
+  void $ passAt l (at 72)
+  mapM (balanceOf st) ["x", "y"] `shouldReturn` replicate 2 (Just (19200, 19200, 0))
+  lateWaitOf st "x" `shouldReturn` Nothing
+
+testRateFloor :: IO ()
+testRateFloor = withLate $ \l@Late {lStore = st} -> do
+  closedOrder l "x" False
+  let floored = rateOf "31000" 31000
+  setRate l (Right floored)
+  settleAt l "x" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired
+  logs <- passAt l (at 71)
+  logs `shouldSatisfy` logged "ERROR" "invoice inv-x is not credited: the current rate 31000 is below half its rate 62500"
+  balanceOf st "x" `shouldReturn` Nothing
+  lateWaitOf st "x" `shouldReturn` Just LWSupport
+  alertsAt l (Right floored) (pastWindow (at 70) 60)
+    >>= (`shouldSatisfy` logged "ERROR" "invoice inv-x of order x: 320000 satoshi received, 320000 satoshi confirmed, 0 satoshi credited; confirmed; the coin's price fell by more than half since the invoice (62500, 31000); the owner decides: credit at the current rate, or refund by hand")
+  setRate l (Right $ rateOf "31250" 31250)
+  void $ passAt l (at 72)
+  creditsOf st "x" `shouldReturn` [(Just lateUnits, Just "62500", Just "31250", Just "31250", 10000)]
+  lateWaitOf st "x" `shouldReturn` Nothing
+
+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 "x" False
+  let highSpeed = (btcPaid lateUnits 0) {rcvUncreditable = Just UCHighSpeed}
+  settleAt l "x" (SigSettled highSpeed (at 70)) (at 70) `shouldReturn` Right ISPaid
+  void $ passAt l (at 71)
+  balanceOf st "x" `shouldReturn` Nothing
+  lateWaitOf st "x" `shouldReturn` Just LWSupport
+  alertsAt l (Right stubRate) (pastWindow (at 70) 60)
+    >>= (`shouldSatisfy` logged "ERROR" "invoice inv-x of order x: 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 "x" False
+  settleAt l "x" (SigClosed (btcPaid lateUnits 0)) (at 70) `shouldReturn` Right ISExpired
+  let first = "invoice inv-x of order x: 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 "x" (SigClosed (btcPaid 400000 0)) (at 80) `shouldReturn` Right ISExpired
+  alertsAt l (Right stubRate) (pastWindow (at 70) 120) >>= (`shouldSatisfy` logged "ERROR" "invoice inv-x of order x: 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
+
+-- 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})
+  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]
+
+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", Nothing), ("alerted", 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 r = 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
@@ -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,7 +1055,7 @@ 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 logs = T.isInfixOf "credited to its balance" logs
        later = addUTCTime 3600 orderTime
    (expired, _) <- placed ctx aliceOrder
    expiredRef <- refOf expired
@@ -1076,7 +1076,7 @@ testLateBTCPayPayments = withFakeBTCPay $ \fake -> 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,14 @@ 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"
+      refunds = length . T.breakOnAll "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 confirmed money is credited to its balance"
  restarted <- newPoller
  refunds <$> readWith restarted `shouldReturn` 0
  (nrPhase &&& nrLive) <$> invoiceRegistration ctx inv `shouldReturn` (PUnpaid, False)
@@ -1133,7 +1133,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 +1168,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 +1269,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 +1345,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 +1394,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 ()
@@ -2455,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
@@ -2465,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