store: store name balances and late credits

apps/simplex-store-service/src/StoreService/Names/Orders.hs

@@ -48,7 +48,7 @@ import qualified Data.Aeson.KeyMap as KM
 import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import Data.Int (Int64)
-import Data.Maybe (isJust)
+import Data.Maybe (catMaybes, isJust)
 import Data.Scientific (toBoundedInteger)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -70,7 +70,7 @@ import StoreService.Names.Env (NamesEnv (..))
 import StoreService.Names.Phases (Phases, RegistrationId (..))
 import StoreService.Names.Abi (bytes32FromHex, hex)
 import StoreService.Names.Signatures (OrderFields (..), orderMessage, parseChecksumAddress, parseSignature, personalDigest)
-import StoreService.Names.Store (LiveOrder (..), NamePhase (..), NameRegistration (..), NewRegistration (..), PrepaidCode (..), RegistrationPayment (..), RegistrationRefused (..), NameTransaction (..), TxFor (..), TxStatus (..), VersionWrite (..), closeOverdue, createCodeRegistration, getLiveOrders, getPrepaidCode, getPrepaidCodeById, getRegistrationByOrderHash, isLabelRegistering, registrationTransactions, retargetRegistration, updateRegistration)
+import StoreService.Names.Store (Balance, LiveOrder (..), NamePhase (..), NameRegistration (..), NewRegistration (..), PrepaidCode (..), RegistrationPayment (..), RegistrationRefused (..), NameTransaction (..), TxFor (..), TxStatus (..), VersionWrite (..), closeOverdue, createCodeRegistration, getBalance, getLiveOrders, getPrepaidCode, getPrepaidCodeById, getRegistration, getRegistrationByOrderHash, isLabelRegistering, registrationTransactions, retargetRegistration, updateRegistration)
 import StoreService.Names.Turns (Turns, withCodeTurn)
 
 data OrdersEnv = OrdersEnv
@@ -103,6 +103,7 @@ data OrderRefusal
   | ORCatalogChanged Int
   | ORCode CodeRefusal
   | ORPriceTooHigh Int
+  | ORBalanceChanged (Maybe Balance)
   deriving (Eq, Show)
 
 newtype OrderRefused = OrderRefused OrderRefusal
@@ -193,10 +194,11 @@ overdueOrdersMet db OrderRequest {orOwner, orFields = OrderFields {ofLabelHash,
     closable LiveOrder {loRegistration = NameRegistration {nrOwner, nrLabelHash}, loOverdue} =
       loOverdue && nrOwner == orOwner && nrLabelHash == ofLabelHash
 
--- | In one transaction, the overdue orders the request meets are closed, then the order is inserted.
+-- | In one transaction, the overdue orders the request meets and the balance holders the caller names are closed, then the order is inserted.
+-- A named holder no longer live is skipped, and one still live that cannot be closed refuses with the balance it holds.
 -- Refused, changing nothing, when it meets an order it cannot close, or the insert refuses.
-placeOrder :: OrdersEnv -> OrderRequest -> (DB.Connection -> UTCTime -> IO (Either OrderRefusal ())) -> IO (Either OrderRefusal [ClosedOrder])
-placeOrder OrdersEnv {oeStore, oeNow} req insert = do
+placeOrder :: OrdersEnv -> OrderRequest -> [NameRegistration] -> (DB.Connection -> UTCTime -> IO (Either OrderRefusal ())) -> IO (Either OrderRefusal [ClosedOrder])
+placeOrder OrdersEnv {oeStore, oeNow} req holders insert = do
   now <- oeNow
   first (\(OrderRefused refusal) -> refusal) <$> E.try (withTransaction oeStore $ \db -> transaction db now)
   where
@@ -204,12 +206,21 @@ placeOrder OrdersEnv {oeStore, oeNow} req insert = do
       overdueOrdersMet db req now >>= \case
         Just overdue -> do
           closed <- mapM (close db now) overdue
-          insert db now >>= either (E.throwIO . OrderRefused) (const $ pure closed)
+          closedHolders <- catMaybes <$> mapM (closeHolder db now) holders
+          insert db now >>= either (E.throwIO . OrderRefused) (const $ pure $ closed <> closedHolders)
         Nothing -> E.throwIO $ OrderRefused OROrderExists
     close db now r =
       closeOverdue db r now >>= \case
         Just v -> pure ClosedOrder {coRegistration = r, coVersion = v}
         Nothing -> E.throwIO $ OrderRefused OROrderExists
+    -- read again here, since another order of its own name may have closed it meanwhile
+    closeHolder db now NameRegistration {nrId} =
+      getRegistration db nrId >>= \case
+        Just holder@NameRegistration {nrLive = True, nrBalanceSource} ->
+          closeOverdue db holder now >>= \case
+            Just v -> pure $ Just ClosedOrder {coRegistration = holder, coVersion = v}
+            Nothing -> E.throwIO . OrderRefused . ORBalanceChanged =<< maybe (pure Nothing) (\source -> getBalance db source now) nrBalanceSource
+        _ -> pure Nothing
 
 -- | In the code's turn, the code as it reads there must pay for the name; the order's insert then reserves it.
 placeCodeOrder :: OrdersEnv -> OrderRequest -> RegistrationId -> PrepaidCode -> IO (Either OrderRefusal [ClosedOrder])
@@ -220,15 +231,15 @@ placeCodeOrder env@OrdersEnv {oeStore, oeTurns, oeNow} req@OrderRequest {orOwner
       Nothing -> pure $ Left $ ORCode CRInvalid
       Just code
         | Just refusal <- codeRefusal now rid ofLength code -> pure $ Left $ ORCode refusal
-        | otherwise -> placeOrder env req $ codeOrderInsert NewRegistration {nrgId = rid, nrgOwner = orOwner, nrgOrder = fields, nrgYears = pcYears} code
+        | otherwise -> placeOrder env req [] $ codeOrderInsert NewRegistration {nrgId = rid, nrgOwner = orOwner, nrgOrder = fields, nrgYears = pcYears} code
 
 -- | The code was checked in its turn, so only a writer outside this process can make its reservation fail.
 codeOrderInsert :: NewRegistration -> PrepaidCode -> DB.Connection -> UTCTime -> IO (Either OrderRefusal ())
 codeOrderInsert new@NewRegistration {nrgId, nrgOrder = OrderFields {ofLength}} code@PrepaidCode {pcCodeHash} db now =
   createCodeRegistration db new code now >>= \case
     Right () -> pure $ Right ()
-    Left RRLiveOrder -> pure $ Left OROrderExists
     Left RRCodeNotReservable -> Left . ORCode <$> reserveRefusal db now pcCodeHash nrgId ofLength
+    Left _ -> pure $ Left OROrderExists
 
 checkTimestamp :: UTCTime -> Word64 -> Either OrderRefusal ()
 checkTimestamp now timestamp =
@@ -267,6 +278,7 @@ unixSeconds = floor . utcTimeToPOSIXSeconds
 movable :: NameRegistration -> Bool
 movable NameRegistration {nrPhase, nrPayment, nrLinksRefusedAt} = case nrPhase of
   PTaken | RPInvoice {} <- nrPayment -> True
+  PTaken | RPBalance <- nrPayment -> True
   PFailed -> True
   PCommitted -> isJust nrLinksRefusedAt
   _ -> False
@@ -297,6 +309,7 @@ retargetOrder OrdersEnv {oeStore, oeTurns, oeNow} r@NameRegistration {nrId, nrPa
   let write db = versionWritten <$> retargetRegistration db r fields price now
   case nrPayment of
     RPInvoice {} -> withTransaction oeStore write
+    RPBalance -> withTransaction oeStore write
     RPCode codeId ->
       withTransaction oeStore (`getPrepaidCodeById` codeId) >>= \case
         Nothing -> pure $ Left $ WRRefused $ ORCode CRInvalid
@@ -343,6 +356,7 @@ confirmLanded OrdersEnv {oeStore, oeContracts, oeTurns, oeNow} r@NameRegistratio
           write db = versionWritten <$> updateRegistration db registered now
       case nrPayment of
         RPInvoice {} -> withTransaction oeStore write
+        RPBalance -> withTransaction oeStore write
         RPCode codeId -> spendLandedCode oeTurns oeStore now codeId nrId write >>= traverse (paidWith codeId)
     paidWith codeId (v, spent) = do
       unless spent $ do

apps/simplex-store-service/src/StoreService/Names/Store.hs

@@ -16,6 +16,15 @@ module StoreService.Names.Store
     VersionWrite (..),
     LiveOrder (..),
     OrderTerms (..),
+    HeldBalance (..),
+    Balance (..),
+    BalanceHold (..),
+    BalanceLink (..),
+    LateCredit (..),
+    LateCreditState (..),
+    LatePending (..),
+    LateAlert (..),
+    CleanupKept (..),
     PrepaidCode (..),
     NewPrepaidCode (..),
     CodeHashTaken (..),
@@ -35,6 +44,7 @@ module StoreService.Names.Store
     textMethod,
     createPaidRegistration,
     createCodeRegistration,
+    createBalanceRegistration,
     getRegistration,
     getRegistrationByOrderHash,
     getLiveOrders,
@@ -47,6 +57,21 @@ module StoreService.Names.Store
     unpaidCleanupCandidates,
     deleteUnpaidRegistration,
     failedCodeOrdersBefore,
+    heldBy,
+    getBalance,
+    overdueHolder,
+    balanceByReference,
+    balanceChain,
+    creditBalance,
+    spendHeldBalance,
+    releaseHeldBalance,
+    refundBalance,
+    lateCreditState,
+    creditLatePayment,
+    latePending,
+    uncreditedLateInvoices,
+    lateAlertDue,
+    claimLateAlert,
     insertPrepaidCode,
     getPrepaidCode,
     getPrepaidCodeById,
@@ -78,9 +103,10 @@ import Data.ByteArray.Encoding (Base (Base16), convertToBase)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import Data.Int (Int64)
-import Data.Functor ((<&>))
 import Data.Maybe (isJust, listToMaybe)
+import Data.String (fromString)
 import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word64)
@@ -138,9 +164,11 @@ instance FromField NamePhase where fromField = fromTextField_ textDecode
 
 instance ToField NamePhase where toField = toField . textEncode
 
+-- | RPBalance: an order paid wholly from another order's balance, with neither invoice nor code.
 data RegistrationPayment
   = RPInvoice ServicePaymentMethod InvoiceId
   | RPCode Int64
+  | RPBalance
   deriving (Eq, Show)
 
 -- | The name, links and owner's intent, all set by an accepted reveal and cleared together.
@@ -168,6 +196,8 @@ data NameRegistration = NameRegistration
     nrYears :: Int,
     nrPrice :: Int,
     nrPayment :: RegistrationPayment,
+    nrBalanceSource :: Maybe RegistrationId,
+    nrBalanceUsed :: Int,
     nrReveal :: Maybe NameReveal,
     nrCommitTx :: Maybe TxHash,
     nrCommitBlock :: Maybe Word64,
@@ -203,7 +233,8 @@ data PaidOrder = PaidOrder
     poProviderRef :: Text
   }
 
-data RegistrationRefused = RRLiveOrder | RRCodeNotReservable
+-- | RRBalanceChanged: the source's balance no longer has the amount seen, or another order holds it.
+data RegistrationRefused = RRLiveOrder | RRCodeNotReservable | RRBalanceChanged
   deriving (Eq, Show)
 
 -- | NotLive: the write would make a closed order live. LiveOrderExists: another live order holds its commitment, or its owner and label hash.
@@ -217,8 +248,102 @@ data LiveOrder = LiveOrder
   }
   deriving (Eq, Show)
 
--- | What an order pays with, as its hash covers it.
-data OrderTerms = OTInvoice ServicePaymentMethod Int | OTCode ByteString
+-- | What an order pays with, as its hash covers it. OTBalance: the paying order, the price, the balance seen, and the method of a difference.
+data OrderTerms = OTInvoice ServicePaymentMethod Int | OTCode ByteString | OTBalance RegistrationId Int Int (Maybe ServicePaymentMethod)
+
+-- | The balance a difference order holds while its invoice is open: the paying order, and all of its amount.
+data HeldBalance = HeldBalance {hbSource :: RegistrationId, hbAmount :: Int}
+
+-- | Cents left to spend, and over the balance's life the cents credited and refunded.
+data Balance = Balance
+  { blRegistration :: RegistrationId,
+    blAmount :: Int,
+    blCredited :: Int,
+    blRefunded :: Int,
+    blHold :: Maybe BalanceHold,
+    blRefundedAt :: Maybe UTCTime
+  }
+  deriving (Eq, Show)
+
+-- | The order whose open invoice holds a balance, until that invoice expires; overdue past it with no money received.
+data BalanceHold = BalanceHold
+  { bhHolder :: RegistrationId,
+    bhUntil :: UTCTime,
+    bhOverdue :: Bool
+  }
+  deriving (Eq, Show)
+
+-- | An order the money of a balance came through. lkPaid and lkFromBalance count only an order that went past unpaid,
+-- since closing an unpaid one released its source's balance.
+data BalanceLink = BalanceLink
+  { lkRegistration :: RegistrationId,
+    lkPayment :: RegistrationPayment,
+    lkPaid :: Int,
+    lkFromBalance :: Int,
+    lkLateCredits :: [LateCredit]
+  }
+  deriving (Eq, Show)
+
+-- | Money paid on a name invoice after its order closed, credited to that order's balance. Rates are decimal text; card money has no units or rates.
+data LateCredit = LateCredit
+  { lcInvoice :: InvoiceId,
+    lcCreditNo :: Int,
+    lcRegistration :: RegistrationId,
+    lcUnits :: Maybe Int64,
+    lcInvoiceRate :: Maybe Text,
+    lcCurrentRate :: Maybe Text,
+    lcRateUsed :: Maybe Text,
+    lcCents :: Int
+  }
+  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.
+data LateCreditState = LateCreditState
+  { lsInvoice :: InvoiceId,
+    lsRegistration :: RegistrationId,
+    lsPhase :: NamePhase,
+    lsLive :: Bool,
+    lsCard :: Bool,
+    lsReceivedCents :: Int,
+    lsConfirmedCents :: Int,
+    lsReceivedUnits :: Maybe Int64,
+    lsConfirmedUnits :: Maybe Int64,
+    lsInvoiceRate :: Maybe Text,
+    lsCreditedUnits :: Int64,
+    lsCreditedCents :: Int,
+    lsCredits :: Int,
+    lsPaymentCreatedAt :: UTCTime
+  }
+  deriving (Eq, Show)
+
+-- | Why a closed order's money is not all credited: Monero confirming with a zero figure, confirmed money not credited yet,
+-- money received and not confirmed, or crypto received that could not be counted in units.
+data LatePending = LPConfirming | LPUncredited | LPUnconfirmed | LPUncounted
+  deriving (Eq, Show, Enum, Bounded)
+
+instance TextEncoding LatePending where
+  textEncode = \case
+    LPConfirming -> "confirming"
+    LPUncredited -> "uncredited"
+    LPUnconfirmed -> "unconfirmed"
+    LPUncounted -> "uncounted"
+  textDecode t = lookup t [(textEncode p, p) | p <- [minBound .. maxBound]]
+
+instance FromField LatePending where fromField = fromTextField_ textDecode
+
+-- | 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,
+    laPending :: LatePending,
+    laReceived :: Maybe Int64,
+    laAlertedAt :: Maybe UTCTime,
+    laAlertedReceived :: Maybe Int64
+  }
+  deriving (Eq, Show)
+
+-- | Why the cleanup keeps an unpaid order: a payment was recorded for it, or it holds the balance of the given order.
+data CleanupKept = CKPaid | CKHolder RegistrationId
+  deriving (Eq, Show)
 
 data PrepaidCode = PrepaidCode
   { pcId :: Int64,
@@ -331,6 +456,7 @@ orderHash owner OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, o
     (tag, payment) = case terms of
       OTInvoice method price -> ("name-invoice", [encodeUtf8 $ methodText method, num price])
       OTCode codeHash -> ("name-code", [codeHash])
+      OTBalance (RegistrationId source) price seen method -> ("name-balance", [encodeUtf8 source, num price, num seen, maybe "" (encodeUtf8 . methodText) method])
     field bs = i2ospOf_ orderHashFieldBytes (toInteger $ B.length bs) <> bs
     num :: Show a => a -> ByteString
     num = encodeUtf8 . tshow
@@ -347,47 +473,66 @@ methodText = \case
 textMethod :: Text -> Maybe ServicePaymentMethod
 textMethod t = lookup t [(methodText m, m) | m <- [SPMCard CPStripe, SPMCrypto CCBtc, SPMCrypto CCXmr]]
 
-createPaidRegistration :: DB.Connection -> NewRegistration -> PaidOrder -> UTCTime -> IO (Either RegistrationRefused ())
-createPaidRegistration db new@NewRegistration {nrgId = RegistrationId rid, nrgOwner, nrgOrder} PaidOrder {poMethod, poPrice, poInvoiceId = InvoiceId invId, poProviderRef} now' = do
+-- | A difference order's hold is written after the registration, so the registration's row is locked before the balance's.
+createPaidRegistration :: DB.Connection -> NewRegistration -> OrderTerms -> PaidOrder -> Maybe HeldBalance -> UTCTime -> IO (Either RegistrationRefused ())
+createPaidRegistration db new@NewRegistration {nrgId = regId@(RegistrationId rid), nrgOwner, nrgOrder} terms PaidOrder {poMethod, poPrice, poInvoiceId = InvoiceId invId, poProviderRef} held now' = do
   let now = truncateToSecond now'
-      hash = orderHash nrgOwner nrgOrder (OTInvoice poMethod poPrice)
-  inserted <- insertRegistration db new PUnpaid poPrice (Just poMethod) Nothing hash now
-  when inserted $
-    DB.execute
-      db
-      "INSERT INTO sx_badge_service_name_invoices (invoice_id, registration_id, provider_ref, created_at) VALUES (?,?,?,?)"
-      (invId, rid, poProviderRef, now)
-  pure $ if inserted then Right () else Left RRLiveOrder
+      fromBalance = (\HeldBalance {hbSource, hbAmount} -> (hbSource, hbAmount)) <$> held
+  inserted <- insertRegistration db new PUnpaid poPrice (Just poMethod) Nothing fromBalance (orderHash nrgOwner nrgOrder terms) now
+  if not inserted
+    then pure $ Left RRLiveOrder
+    else do
+      DB.execute
+        db
+        "INSERT INTO sx_badge_service_name_invoices (invoice_id, registration_id, provider_ref, created_at) VALUES (?,?,?,?)"
+        (invId, rid, poProviderRef, now)
+      held' <- maybe (pure True) (\HeldBalance {hbSource, hbAmount} -> holdBalance db hbSource hbAmount regId now) held
+      if held' then pure $ Right () else Left RRBalanceChanged <$ deleteRegistration db regId
 
 -- | Reserving the code is the conditional update of the transaction that creates the registration.
 createCodeRegistration :: DB.Connection -> NewRegistration -> PrepaidCode -> UTCTime -> IO (Either RegistrationRefused ())
-createCodeRegistration db new@NewRegistration {nrgId = regId@(RegistrationId rid), nrgOwner, nrgOrder} PrepaidCode {pcId, pcCodeHash} now' = do
+createCodeRegistration db new@NewRegistration {nrgId = regId, nrgOwner, nrgOrder} PrepaidCode {pcId, pcCodeHash} now' = do
   let now = truncateToSecond now'
-  inserted <- insertRegistration db new PQueued 0 Nothing (Just pcId) (orderHash nrgOwner nrgOrder (OTCode pcCodeHash)) now
+  inserted <- insertRegistration db new PQueued 0 Nothing (Just pcId) Nothing (orderHash nrgOwner nrgOrder (OTCode pcCodeHash)) now
   if not inserted
     then pure $ Left RRLiveOrder
     else
       reservePrepaidCode db pcId regId now >>= \case
         True -> pure $ Right ()
-        False -> do
-          DB.execute db "DELETE FROM sx_badge_service_name_registrations WHERE registration_id = ?" (Only rid)
-          pure $ Left RRCodeNotReservable
+        False -> Left RRCodeNotReservable <$ deleteRegistration db regId
+
+-- | A queued order whose price is spent from the source's balance in the same transaction, where its amount is the one seen and nothing holds it.
+createBalanceRegistration :: DB.Connection -> NewRegistration -> RegistrationId -> Int -> Int -> UTCTime -> IO (Either RegistrationRefused ())
+createBalanceRegistration db new@NewRegistration {nrgId, nrgOwner, nrgOrder} source price seen now' = do
+  let now = truncateToSecond now'
+  inserted <- insertRegistration db new PQueued price Nothing Nothing (Just (source, price)) (orderHash nrgOwner nrgOrder (OTBalance source price seen Nothing)) now
+  if not inserted
+    then pure $ Left RRLiveOrder
+    else
+      spendBalance db source price seen now >>= \case
+        True -> pure $ Right ()
+        False -> Left RRBalanceChanged <$ deleteRegistration db nrgId
+
+-- | The name invoice row goes with it.
+deleteRegistration :: DB.Connection -> RegistrationId -> IO ()
+deleteRegistration db (RegistrationId rid) = DB.execute db "DELETE FROM sx_badge_service_name_registrations WHERE registration_id = ?" (Only rid)
 
 -- | False when the registration would be a second live one for its commitment, or for its owner and label hash.
-insertRegistration :: DB.Connection -> NewRegistration -> NamePhase -> Int -> Maybe ServicePaymentMethod -> Maybe Int64 -> ByteString -> UTCTime -> IO Bool
-insertRegistration db NewRegistration {nrgId = RegistrationId rid, nrgOwner, nrgOrder, nrgYears} phase price method codeId hash now =
+-- fromBalance: the order whose balance pays, and the cents it pays.
+insertRegistration :: DB.Connection -> NewRegistration -> NamePhase -> Int -> Maybe ServicePaymentMethod -> Maybe Int64 -> Maybe (RegistrationId, Int) -> ByteString -> UTCTime -> IO Bool
+insertRegistration db NewRegistration {nrgId = RegistrationId rid, nrgOwner, nrgOrder, nrgYears} phase price method codeId fromBalance hash now =
   (> 0)
     <$> executeChanging
       db
       [sql|
         INSERT INTO sx_badge_service_name_registrations
           (registration_id, version, label_hash, length, duration, owner, commitment, sealed, phase, years,
-           price, method, name_prepaid_code_id, live, order_hash, moves, created_at, updated_at)
-        VALUES (?,?,?,?,?,?,?,?,?,?, ?,?,?,?,?,?,?,?)
+           price, method, name_prepaid_code_id, live, order_hash, moves, created_at, updated_at, balance_source, balance_used)
+        VALUES (?,?,?,?,?,?,?,?,?,?, ?,?,?,?,?,?,?,?,?,?)
         ON CONFLICT DO NOTHING
       |]
       ( (rid, initialVersion, Binary lh, ofLength, int64 ofDuration, Binary $ unAddress nrgOwner, Binary ofCommitment, ofSealed, phase, nrgYears)
-          :. (price, methodText <$> method, codeId, BI True, Binary hash, 0 :: Int, now, now)
+          :. (price, methodText <$> method, codeId, BI True, Binary hash, 0 :: Int, now, now, (\(RegistrationId s, _) -> s) <$> fromBalance, maybe 0 snd fromBalance)
       )
   where
     OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} = nrgOrder
@@ -398,7 +543,7 @@ registrationColumns =
     SELECT r.registration_id, r.version, r.label_hash, r.length, r.duration, r.owner, r.commitment, r.sealed, r.phase, r.years,
       r.price, r.method, ni.invoice_id, r.name_prepaid_code_id, r.label, r.secret, r.contact_link, r.channel_link, r.intent_nonce, r.intent_deadline,
       r.intent_signature, r.commit_tx, r.commit_block, r.register_tx, r.register_block, r.reveal_after, r.reveal_before, r.expires_at, r.registered_at,
-      r.failed_at, r.error, r.live, r.order_hash, r.moves, r.links_refused_at, r.created_at, r.updated_at
+      r.failed_at, r.error, r.live, r.order_hash, r.moves, r.links_refused_at, r.created_at, r.updated_at, r.balance_source, r.balance_used
   |]
 
 registrationFrom :: Query
@@ -416,19 +561,20 @@ type RegistrationRow =
   (Text, Int64, Binary ByteString, Int, Int64, Binary ByteString, Binary ByteString, Text, NamePhase, Int)
     :. (Int, Maybe Text, Maybe Text, Maybe Int64, Maybe Text, Maybe (Binary ByteString), Maybe Text, Maybe Text, Maybe Int64, Maybe Int64)
     :. (Maybe (Binary ByteString), Maybe (Binary ByteString), Maybe Int64, Maybe (Binary ByteString), Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime)
-    :. (Maybe UTCTime, Maybe Text, BoolInt, Binary ByteString, Int, Maybe UTCTime, UTCTime, UTCTime)
+    :. (Maybe UTCTime, Maybe Text, BoolInt, Binary ByteString, Int, Maybe UTCTime, UTCTime, UTCTime, Maybe Text, Int)
 
 toRegistration :: RegistrationRow -> Either Text NameRegistration
 toRegistration
   ( (rid, nrVersion, Binary lh, nrLength, duration, Binary owner, Binary nrCommitment, nrSealed, nrPhase, nrYears)
       :. (nrPrice, method_, invoiceId_, codeId_, label_, secret_, nrContactLink, nrChannelLink, nonce_, deadline_)
       :. (signature_, commitTx, commitBlock, registerTx, registerBlock, revealAfter, revealBefore, expiresAt, nrRegisteredAt)
-      :. (nrFailedAt, nrError, BI nrLive, Binary nrOrderHash, nrMoves, nrLinksRefusedAt, nrCreatedAt, nrUpdatedAt)
+      :. (nrFailedAt, nrError, BI nrLive, Binary nrOrderHash, nrMoves, nrLinksRefusedAt, nrCreatedAt, nrUpdatedAt, source_, nrBalanceUsed)
     ) = do
     nrOwner <- decodeAddress owner
     nrPayment <- case (method_, invoiceId_, codeId_) of
       (Just m, Just invId, Nothing) -> (`RPInvoice` InvoiceId invId) <$> note ("name_registrations.method: " <> m) (textMethod m)
       (Nothing, Nothing, Just codeId) -> Right $ RPCode codeId
+      (Nothing, Nothing, Nothing) | isJust source_ -> Right RPBalance
       _ -> Left $ "name_registrations payment: " <> rid
     nrReveal <- case (label_, secret_, nonce_, deadline_, signature_) of
       (Nothing, Nothing, Nothing, Nothing, Nothing) -> Right Nothing
@@ -450,6 +596,8 @@ toRegistration
           nrYears,
           nrPrice,
           nrPayment,
+          nrBalanceSource = RegistrationId <$> source_,
+          nrBalanceUsed,
           nrReveal,
           nrCommitTx = txHash <$> commitTx,
           nrCommitBlock = word64 <$> commitBlock,
@@ -503,13 +651,14 @@ unfunded = unfundedQuery "i.invoice_id"
 
 -- | Run in the transaction that inserts the next order, so the unique constraints let it in; the registration's new version.
 -- Nothing when the order changed since it was read, or its invoice is no longer open or holds money: the caller rolls back,
--- since the invoice is written before the registration, as settlement, cancel and the sweep write them.
+-- since the invoice is written before the registration, as settlement, cancel and the sweep write them. A balance it held is released.
 closeOverdue :: DB.Connection -> NameRegistration -> UTCTime -> IO (Maybe Int64)
-closeOverdue db r@NameRegistration {nrId = RegistrationId rid, nrVersion, nrPayment} now = do
+closeOverdue db r@NameRegistration {nrId = regId@(RegistrationId rid), nrVersion, nrPayment} now = do
   -- locked first, so the funding check below, a later statement, sees a payment a concurrent settlement committed
   mapM_ (\invId -> lockInvoice db invId now) $ case nrPayment of
     RPInvoice _ invId -> Just invId
     RPCode _ -> Nothing
+    RPBalance -> Nothing
   expired <-
     executeChanging
       db
@@ -527,9 +676,9 @@ closeOverdue db r@NameRegistration {nrId = RegistrationId rid, nrVersion, nrPaym
       (invoiceStatusText ISExpired, truncateToSecond now, invoiceStatusText ISOpen, rid, nrVersion)
   if expired > 0
     then
-      updateRegistration db r {nrLive = False} now <&> \case
-        Written v -> Just v
-        _ -> Nothing
+      updateRegistration db r {nrLive = False} now >>= \case
+        Written v -> Just v <$ releaseHeldBalance db regId now
+        _ -> pure Nothing
     else pure Nothing
 
 -- | Whether an order can still progress to a registration for its name. The unique live indexes allow one such order per commitment,
@@ -545,6 +694,7 @@ orderLive NameRegistration {nrPhase, nrPayment, nrLive} = case nrPhase of
   PFailed -> True
   PTaken -> case nrPayment of
     RPInvoice {} -> True
+    RPBalance -> True
     RPCode _ -> False
   PRegistered -> False
 
@@ -611,11 +761,15 @@ retargetRegistration db r OrderFields {ofLabelHash, ofLength, ofDuration, ofComm
         nrError = Nothing
       }
 
--- | Newest first, at most findLimit.
+-- | Newest first: findLimit of them, then every older one holding a balance above 0, since a balance never expires.
 findRegistrations :: DB.Connection -> Address -> IO [NameRegistration]
-findRegistrations db owner =
-  DB.query db (selectRegistrations <> " WHERE r.owner = ? ORDER BY r.created_at DESC, r.registration_id DESC LIMIT ?") (Binary $ unAddress owner, findLimit)
-    >>= decodeAll toRegistration
+findRegistrations db owner = do
+  newest <- DB.query db (selectRegistrations <> " WHERE r.owner = ?" <> newestFirst <> " LIMIT ?") (Binary $ unAddress owner, findLimit) >>= decodeAll toRegistration
+  holding <- DB.query db (selectRegistrations <> " WHERE r.owner = ?" <> withBalance <> newestFirst) (Only $ Binary $ unAddress owner) >>= decodeAll toRegistration
+  pure $ newest <> filter ((`notElem` map nrId newest) . nrId) holding
+  where
+    newestFirst = " ORDER BY r.created_at DESC, r.registration_id DESC"
+    withBalance = " AND EXISTS (SELECT 1 FROM sx_badge_service_name_balances b WHERE b.registration_id = r.registration_id AND b.amount > 0)"
 
 isLabelRegistering :: DB.Connection -> LabelHash -> IO Bool
 isLabelRegistering db (LabelHash lh) =
@@ -647,26 +801,29 @@ unpaidCleanupCandidates db expiredBefore =
       |]
       (PUnpaid, truncateToSecond expiredBefore)
 
--- | Deletes an unpaid registration and its invoice, unless a payment was recorded for it.
-deleteUnpaidRegistration :: DB.Connection -> RegistrationId -> IO Bool
-deleteUnpaidRegistration db (RegistrationId rid) = do
-  invoiceIds <- DB.query db "SELECT invoice_id FROM sx_badge_service_name_invoices WHERE registration_id = ?" (Only rid)
-  deleted <-
-    executeChanging
-      db
-      [sql|
-        DELETE FROM sx_badge_service_name_registrations
-        WHERE registration_id = ? AND phase = ?
-          AND NOT EXISTS (
-            SELECT 1 FROM sx_badge_service_name_invoices ni
-            JOIN sx_badge_service_payments p ON p.invoice_id = ni.invoice_id
-            WHERE ni.registration_id = ?
-          )
-      |]
-      (rid, PUnpaid, rid)
-  when (deleted > 0) $
-    mapM_ (DB.execute db "DELETE FROM sx_badge_service_invoices WHERE invoice_id = ?" . Only . fromOnly) (invoiceIds :: [Only Text])
-  pure $ deleted > 0
+-- | Deletes an unpaid registration and its invoice, unless a payment was recorded for it or it holds a balance.
+deleteUnpaidRegistration :: DB.Connection -> RegistrationId -> IO (Either CleanupKept ())
+deleteUnpaidRegistration db (RegistrationId rid) =
+  DB.query db "SELECT registration_id FROM sx_badge_service_name_balances WHERE reserved_by = ?" (Only rid) >>= \case
+    Only source : _ -> pure $ Left $ CKHolder $ RegistrationId source
+    [] -> do
+      invoiceIds <- DB.query db "SELECT invoice_id FROM sx_badge_service_name_invoices WHERE registration_id = ?" (Only rid)
+      deleted <-
+        executeChanging
+          db
+          [sql|
+            DELETE FROM sx_badge_service_name_registrations
+            WHERE registration_id = ? AND phase = ?
+              AND NOT EXISTS (
+                SELECT 1 FROM sx_badge_service_name_invoices ni
+                JOIN sx_badge_service_payments p ON p.invoice_id = ni.invoice_id
+                WHERE ni.registration_id = ?
+              )
+          |]
+          (rid, PUnpaid, rid)
+      if deleted > 0
+        then Right () <$ mapM_ (DB.execute db "DELETE FROM sx_badge_service_invoices WHERE invoice_id = ?" . Only . fromOnly) (invoiceIds :: [Only Text])
+        else pure $ Left CKPaid
 
 -- | Code orders failed before the cutoff that still hold their unspent code.
 failedCodeOrdersBefore :: DB.Connection -> UTCTime -> IO [(RegistrationId, Int64)]
@@ -683,7 +840,303 @@ failedCodeOrdersBefore db cutoff =
       |]
       (PFailed, truncateToSecond cutoff)
 
-insertPrepaidCode :: DB.Connection -> NewPrepaidCode -> UTCTime -> IO (Either CodeHashTaken Int64)
+-- | The hold, unless it is overdue, which reads as none.
+heldBy :: Balance -> Maybe BalanceHold
+heldBy Balance {blHold} = case blHold of
+  Just BalanceHold {bhOverdue = False} -> blHold
+  _ -> Nothing
+
+-- | A holder is overdue as getLiveOrders reads an order overdue: its invoice past its expiry, not paid, and holding no money.
+getBalance :: DB.Connection -> RegistrationId -> UTCTime -> IO (Maybe Balance)
+getBalance db (RegistrationId rid) now =
+  firstDecoded toBalance $
+    DB.query
+      db
+      ( "SELECT b.registration_id, b.amount, b.credited, b.refunded, b.reserved_by, i.expires_at,"
+          <> " CASE WHEN h.phase = ? AND i.status <> ? AND i.expires_at < ?"
+          <> unfunded
+          <> " THEN 1 ELSE 0 END, b.refunded_at"
+          <> " FROM sx_badge_service_name_balances b"
+          <> " LEFT JOIN sx_badge_service_name_registrations h ON h.registration_id = b.reserved_by"
+          <> " LEFT JOIN sx_badge_service_name_invoices ni ON ni.registration_id = b.reserved_by"
+          <> " LEFT JOIN sx_badge_service_invoices i ON i.invoice_id = ni.invoice_id"
+          <> " WHERE b.registration_id = ?"
+      )
+      (PUnpaid, invoiceStatusText ISPaid, truncateToSecond now, rid)
+
+toBalance :: (Text, Int, Int, Int, Maybe Text, Maybe UTCTime, BoolInt, Maybe UTCTime) -> Either Text Balance
+toBalance (rid, blAmount, blCredited, blRefunded, holder_, until_, BI overdue, blRefundedAt) = do
+  blHold <- case (holder_, until_) of
+    (Nothing, _) -> Right Nothing
+    (Just holder, Just bhUntil) -> Right $ Just BalanceHold {bhHolder = RegistrationId holder, bhUntil, bhOverdue = overdue}
+    (Just _, Nothing) -> Left $ "name_balances holder without an invoice: " <> rid
+  pure Balance {blRegistration = RegistrationId rid, blAmount, blCredited, blRefunded, blHold, blRefundedAt}
+
+-- | The order holding the balance, when its hold is overdue, for the next spend to close.
+overdueHolder :: DB.Connection -> RegistrationId -> UTCTime -> IO (Maybe NameRegistration)
+overdueHolder db rid now =
+  getBalance db rid now >>= \case
+    Just Balance {blHold = Just BalanceHold {bhHolder, bhOverdue = True}} -> getRegistration db bhHolder
+    _ -> pure Nothing
+
+-- | The order a support reference names, by its registration id or its name invoice's id, with its balance.
+balanceByReference :: DB.Connection -> Text -> UTCTime -> IO (Maybe (RegistrationId, Maybe Balance))
+balanceByReference db ref now =
+  DB.query
+    db
+    "SELECT registration_id FROM sx_badge_service_name_registrations WHERE registration_id = ? UNION ALL SELECT registration_id FROM sx_badge_service_name_invoices WHERE invoice_id = ?"
+    (ref, ref)
+    >>= \case
+      Only rid : _ -> (\balance -> Just (RegistrationId rid, balance)) <$> getBalance db (RegistrationId rid) now
+      [] -> pure Nothing
+
+-- | From the order back along balance_source to the first, following it only from orders past unpaid.
+balanceChain :: DB.Connection -> RegistrationId -> IO [BalanceLink]
+balanceChain db rid =
+  getRegistration db rid >>= \case
+    Nothing -> pure []
+    Just NameRegistration {nrPhase, nrPayment, nrBalanceSource, nrBalanceUsed} -> do
+      let pastUnpaid = nrPhase /= PUnpaid
+      lkPaid <- case nrPayment of
+        RPInvoice _ (InvoiceId invId) | pastUnpaid -> maybe 0 fromOnly . listToMaybe <$> (DB.query db "SELECT amount FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only invId) :: IO [Only Int])
+        _ -> pure 0
+      lkLateCredits <- case nrPayment of
+        RPInvoice _ invId -> lateCredits db invId
+        _ -> pure []
+      let link = BalanceLink {lkRegistration = rid, lkPayment = nrPayment, lkPaid, lkFromBalance = if pastUnpaid then nrBalanceUsed else 0, lkLateCredits}
+      (link :) <$> maybe (pure []) (balanceChain db) (if pastUnpaid then nrBalanceSource else Nothing)
+
+lateCredits :: DB.Connection -> InvoiceId -> IO [LateCredit]
+lateCredits db (InvoiceId invId) =
+  map toLateCredit
+    <$> DB.query
+      db
+      "SELECT invoice_id, credit_no, registration_id, units, invoice_rate, current_rate, rate_used, cents FROM sx_badge_service_name_late_credits WHERE invoice_id = ? ORDER BY credit_no"
+      (Only invId)
+  where
+    toLateCredit (inv, lcCreditNo, reg, lcUnits, lcInvoiceRate, lcCurrentRate, lcRateUsed, lcCents) =
+      LateCredit {lcInvoice = InvoiceId inv, lcCreditNo, lcRegistration = RegistrationId reg, lcUnits, lcInvoiceRate, lcCurrentRate, lcRateUsed, lcCents}
+
+-- | Adds to the order's balance, making it on its first credit.
+creditBalance :: DB.Connection -> RegistrationId -> Int -> UTCTime -> IO ()
+creditBalance db (RegistrationId rid) cents now' =
+  DB.execute
+    db
+    [sql|
+      INSERT INTO sx_badge_service_name_balances (registration_id, amount, credited, refunded, created_at, updated_at)
+      VALUES (?,?,?,0,?,?)
+      ON CONFLICT (registration_id) DO UPDATE SET
+        amount = sx_badge_service_name_balances.amount + excluded.amount,
+        credited = sx_badge_service_name_balances.credited + excluded.credited,
+        updated_at = excluded.updated_at
+    |]
+    (rid, cents, cents, now, now)
+  where
+    now = truncateToSecond now'
+
+-- | The price spent at once, where the amount is the one seen and nothing holds it.
+spendBalance :: DB.Connection -> RegistrationId -> Int -> Int -> UTCTime -> IO Bool
+spendBalance db (RegistrationId rid) price seen now =
+  (> 0)
+    <$> executeChanging
+      db
+      "UPDATE sx_badge_service_name_balances SET amount = amount - ?, updated_at = ? WHERE registration_id = ? AND amount = ? AND amount >= ? AND reserved_by IS NULL"
+      (price, now, rid, seen, price)
+
+-- | Held by a difference order, where the amount is the one seen and nothing holds it.
+holdBalance :: DB.Connection -> RegistrationId -> Int -> RegistrationId -> UTCTime -> IO Bool
+holdBalance db (RegistrationId rid) seen (RegistrationId holder) now =
+  (> 0)
+    <$> executeChanging
+      db
+      "UPDATE sx_badge_service_name_balances SET reserved_by = ?, updated_at = ? WHERE registration_id = ? AND amount = ? AND reserved_by IS NULL"
+      (holder, now, rid, seen)
+
+-- | The holder's hold spent and cleared, where this holder holds the balance and it still has the cents.
+spendHeldBalance :: DB.Connection -> RegistrationId -> Int -> UTCTime -> IO Bool
+spendHeldBalance db (RegistrationId holder) used now =
+  (> 0)
+    <$> executeChanging
+      db
+      "UPDATE sx_badge_service_name_balances SET amount = amount - ?, reserved_by = NULL, updated_at = ? WHERE reserved_by = ? AND amount >= ?"
+      (used, truncateToSecond now, holder, used)
+
+releaseHeldBalance :: DB.Connection -> RegistrationId -> UTCTime -> IO Bool
+releaseHeldBalance db (RegistrationId holder) now =
+  (> 0)
+    <$> executeChanging
+      db
+      "UPDATE sx_badge_service_name_balances SET reserved_by = NULL, updated_at = ? WHERE reserved_by = ?"
+      (truncateToSecond now, holder)
+
+-- | All of the balance, where it is the cents given, above 0, and nothing holds it; refunded counts every refund.
+refundBalance :: DB.Connection -> RegistrationId -> Int -> UTCTime -> IO Bool
+refundBalance db (RegistrationId rid) cents now' =
+  (> 0)
+    <$> executeChanging
+      db
+      [sql|
+        UPDATE sx_badge_service_name_balances SET amount = 0, refunded = refunded + ?, refunded_at = ?, updated_at = ?
+        WHERE registration_id = ? AND amount = ? AND amount > 0 AND reserved_by IS NULL
+      |]
+      (cents, now, now, rid, cents)
+  where
+    now = truncateToSecond now'
+
+-- | A name invoice with its order, its invoice row and its payment row.
+lateFrom :: Query
+lateFrom =
+  " FROM sx_badge_service_name_invoices ni"
+    <> " JOIN sx_badge_service_name_registrations r ON r.registration_id = ni.registration_id"
+    <> " JOIN sx_badge_service_invoices i ON i.invoice_id = ni.invoice_id"
+    <> " JOIN sx_badge_service_payments p ON p.invoice_id = ni.invoice_id"
+
+-- | Its order closed unpaid, whatever the invoice's status, since settlement queues only a live order; takes the unpaid phase.
+closedUnpaid :: Query
+closedUnpaid = " r.phase = ? AND r.live = 0"
+
+cardInvoice :: Query
+cardInvoice = " i.payment_crypto_currency IS NULL"
+
+cryptoInvoice :: Query
+cryptoInvoice = " i.payment_crypto_currency IS NOT NULL"
+
+-- | No credit rows sum to 0, not NULL.
+creditedTotal :: Query -> Query
+creditedTotal column = " (SELECT " <> integerSum ("COALESCE(SUM(c." <> column <> "), 0)") <> " FROM sx_badge_service_name_late_credits c WHERE c.invoice_id = ni.invoice_id)"
+
+integerSum :: Query -> Query
+#if defined(dbPostgres)
+-- Postgres sums a BIGINT as NUMERIC, which does not decode into an integer
+integerSum s = "CAST(" <> s <> " AS BIGINT)"
+#else
+integerSum = id
+#endif
+
+-- | The first alert's old marks are NULL, which = never matches.
+notDistinctFrom :: Query
+#if defined(dbPostgres)
+notDistinctFrom = " IS NOT DISTINCT FROM "
+#else
+notDistinctFrom = " IS "
+#endif
+
+-- | Confirmed money not all credited: cents for card, units for crypto.
+uncreditedMoney :: Query
+uncreditedMoney =
+  " ((" <> cardInvoice <> " AND p.confirmed_amount >" <> creditedTotal "cents" <> ")"
+    <> " OR (" <> cryptoInvoice <> " AND p.confirmed_units >" <> creditedTotal "units" <> "))"
+
+-- | Why a closed order's money is not all credited, by the first case that holds, else NULL.
+pendingCase :: Query
+pendingCase =
+  " CASE WHEN COALESCE(p.amount, 0) = 0 AND (p.crypto_paid IS NOT NULL OR p.paid_in_full = 1) THEN " <> literal LPConfirming
+    <> " WHEN" <> uncreditedMoney <> " THEN " <> literal LPUncredited
+    <> " WHEN" <> cardInvoice <> " AND COALESCE(p.amount, 0) > p.confirmed_amount THEN " <> literal LPUnconfirmed
+    <> " WHEN p.received_units > p.confirmed_units THEN " <> literal LPUnconfirmed
+    <> " WHEN" <> cryptoInvoice <> " AND p.received_units IS NULL AND COALESCE(p.amount, 0) > 0 THEN " <> literal LPUncounted
+    <> " END"
+  where
+    literal p = fromString $ "'" <> T.unpack (textEncode p) <> "'"
+
+-- | What an alert names as received: cents for card, units for crypto.
+receivedFigure :: Query
+receivedFigure = " CASE WHEN" <> cardInvoice <> " THEN p.amount ELSE p.received_units END"
+
+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,"
+    <> " 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)
+
+toLateState :: LateRow -> 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}
+
+-- | 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)
+
+-- | 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
+creditLatePayment db LateCredit {lcInvoice = InvoiceId invId, lcCreditNo, lcRegistration = regId@(RegistrationId rid), lcUnits, lcInvoiceRate, lcCurrentRate, lcRateUsed, lcCents} now' = do
+  inserted <-
+    executeChanging
+      db
+      [sql|
+        INSERT INTO sx_badge_service_name_late_credits (invoice_id, credit_no, registration_id, units, invoice_rate, current_rate, rate_used, cents, created_at)
+        VALUES (?,?,?,?,?,?,?,?,?)
+        ON CONFLICT DO NOTHING
+      |]
+      (invId, lcCreditNo, rid, lcUnits, lcInvoiceRate, lcCurrentRate, lcRateUsed, lcCents, now)
+  when (inserted > 0) $ creditBalance db regId lcCents now
+  pure $ inserted > 0
+  where
+    now = truncateToSecond now'
+
+-- | Why the closed order's money on the invoice is not all credited; the one rule of the pending log and the alert.
+latePending :: DB.Connection -> InvoiceId -> IO (Maybe LatePending)
+latePending db (InvoiceId invId) =
+  maybe Nothing fromOnly . listToMaybe
+    <$> DB.query db ("SELECT" <> pendingCase <> lateFrom <> " WHERE ni.invoice_id = ? AND" <> closedUnpaid) (invId, PUnpaid)
+
+-- | Closed orders' invoices with confirmed money not all credited, for the poller's credit pass.
+uncreditedLateInvoices :: DB.Connection -> IO [InvoiceId]
+uncreditedLateInvoices db =
+  map (InvoiceId . fromOnly)
+    <$> DB.query db ("SELECT ni.invoice_id" <> lateFrom <> " WHERE" <> closedUnpaid <> " AND" <> uncreditedMoney <> " ORDER BY p.created_at, ni.invoice_id") (Only PUnpaid)
+
+-- | Pending money whose payment row was created before the cutoff, never alerted, or alerted for less money than now received.
+lateAlertDue :: DB.Connection -> UTCTime -> IO [LateAlert]
+lateAlertDue db cutoff =
+  DB.query
+    db
+    ( lateColumns
+        <> ","
+        <> pendingCase
+        <> ","
+        <> receivedFigure
+        <> ", ni.late_alerted_at, ni.late_alerted_units"
+        <> lateFrom
+        <> " WHERE"
+        <> closedUnpaid
+        <> " AND p.created_at < ? AND"
+        <> pendingCase
+        <> " IS NOT NULL AND (ni.late_alerted_at IS NULL OR"
+        <> receivedFigure
+        <> " > ni.late_alerted_units) ORDER BY p.created_at, ni.invoice_id"
+    )
+    (PUnpaid, truncateToSecond cutoff)
+    >>= decodeAll toAlert
+  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}
+      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 =
+  (> 0)
+    <$> executeChanging
+      db
+      ( "UPDATE sx_badge_service_name_invoices SET late_alerted_at = ?, late_alerted_units = ? WHERE invoice_id = ? AND late_alerted_at"
+          <> notDistinctFrom
+          <> "? AND late_alerted_units"
+          <> notDistinctFrom
+          <> "?"
+      )
+      (truncateToSecond now, laReceived, invId, laAlertedAt, laAlertedReceived)
+
+insertPrepaidCode ::DB.Connection -> NewPrepaidCode -> UTCTime -> IO (Either CodeHashTaken Int64)
 insertPrepaidCode db NewPrepaidCode {npcCodeHash, npcMinLength, npcYears, npcPaymentStatus, npcExpiresAt} now = do
   inserted <-
     executeChanging

apps/simplex-store-service/src/StoreService/Names/View.hs

@@ -7,6 +7,7 @@ module StoreService.Names.View
     registrationView,
     readViewChain,
     viewJSON,
+    balanceJSON,
     addressText,
     tldText,
     registrationAt,
@@ -35,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 (NamePhase (..), NameRegistration (..), NameReveal (..), getRegistration)
+import StoreService.Names.Store (Balance (..), BalanceHold (..), NamePhase (..), NameRegistration (..), NameReveal (..), getBalance, getRegistration, heldBy)
 
 -- | The view's chain reads; a field whose read failed is null and named in vrUnread.
 data ViewReads = ViewReads
@@ -44,8 +45,11 @@ data ViewReads = ViewReads
   }
   deriving (Eq, Show)
 
-registrationView :: DBStore -> NamesConfig -> Contracts -> NameRegistration -> IO J.Value
-registrationView _ cfg ct r = viewJSON cfg r <$> readViewChain ct r
+-- | The balance as it reads at the given time, when a hold may have become overdue.
+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
 
 -- | The intent nonce only in committed.
 readViewChain :: Contracts -> NameRegistration -> IO ViewReads
@@ -57,8 +61,8 @@ readViewChain ct NameRegistration {nrPhase, nrOwner} = case nrPhase of
   where
     none = ViewReads {vrIntentNonce = Nothing, vrUnread = []}
 
-viewJSON :: NamesConfig -> NameRegistration -> ViewReads -> J.Value
-viewJSON NamesConfig {nTLD, nChain = ChainConfig {cChainId, cResolver, cSponsor}} r ViewReads {vrIntentNonce, vrUnread} =
+viewJSON :: NamesConfig -> NameRegistration -> Maybe Balance -> ViewReads -> J.Value
+viewJSON NamesConfig {nTLD, nChain = ChainConfig {cChainId, cResolver, cSponsor}} r balance ViewReads {vrIntentNonce, vrUnread} =
   J.object
     [ "id" .= rid,
       "version" .= nrVersion,
@@ -77,6 +81,8 @@ viewJSON NamesConfig {nTLD, nChain = ChainConfig {cChainId, cResolver, cSponsor}
       "years" .= nrYears,
       "duration" .= nrDuration,
       "price" .= nrPrice,
+      "fromBalance" .= nrBalanceUsed,
+      "balance" .= (balanceJSON <$> balance),
       "commitTx" .= (txText <$> nrCommitTx),
       "registerTx" .= (txText <$> nrRegisterTx),
       "revealAfter" .= nrRevealAfter,
@@ -88,9 +94,16 @@ viewJSON NamesConfig {nTLD, nChain = ChainConfig {cChainId, cResolver, cSponsor}
     ]
   where
     NameRegistration {nrId = RegistrationId rid, nrVersion, nrMoves, nrLinksRefusedAt, nrPhase, nrLabelHash = LabelHash lh, nrReveal, nrOwner, nrCommitment, nrSealed} = r
-    NameRegistration {nrYears, nrDuration, nrPrice, nrCommitTx, nrRegisterTx, nrRevealAfter, nrRevealBefore, nrExpiresAt, nrError} = r
+    NameRegistration {nrYears, nrDuration, nrPrice, nrBalanceUsed, nrCommitTx, nrRegisterTx, nrRevealAfter, nrRevealBefore, nrExpiresAt, nrError} = r
     txText (TxHash h) = hex h
 
+-- | The holder is not named, so an order's link discloses no other order.
+balanceJSON :: Balance -> J.Value
+balanceJSON b@Balance {blAmount, blRefunded} =
+  J.object ["amount" .= blAmount, "held" .= isJust hold, "heldUntil" .= (bhUntil <$> hold), "refunded" .= blRefunded]
+  where
+    hold = heldBy b
+
 -- | EIP-55, as the page compares owners.
 addressText :: Address -> Text
 addressText = safeDecodeUtf8 . strEncode

apps/simplex-store-service/src/StoreService/Names/Worker.hs

@@ -327,6 +327,7 @@ judge w@Worker {wkOrders = oe@OrdersEnv {oeContracts}} now r@NameRegistration {n
 taken :: Worker -> UTCTime -> NameRegistration -> IO (Maybe Int64, Next)
 taken Worker {wkOrders = OrdersEnv {oeStore, oeTurns}} now r@NameRegistration {nrId, nrPayment} = case nrPayment of
   RPInvoice {} -> written r <$> withTransaction oeStore write
+  RPBalance -> written r <$> withTransaction oeStore write
   RPCode codeId -> written r . fmap fst <$> releaseCode oeTurns oeStore codeId nrId write
   where
     write db = versionWritten <$> updateRegistration db r {nrPhase = PTaken, nrError = Nothing} now
@@ -396,6 +397,7 @@ retryRegistration oe@OrdersEnv {oeNow} current = do
 retryCode :: OrdersEnv -> UTCTime -> NameRegistration -> IO (Either CodeRefusal (Maybe PrepaidCode))
 retryCode OrdersEnv {oeStore} now NameRegistration {nrId, nrLength, nrPayment} = case nrPayment of
   RPInvoice {} -> pure $ Right Nothing
+  RPBalance -> pure $ Right Nothing
   RPCode codeId ->
     withTransaction oeStore (`getPrepaidCodeById` codeId) <&> \case
       Just code -> maybe (Right $ Just code) Left $ codeRefusal now nrId nrLength code

apps/simplex-store-service/src/StoreService/Orders.hs

@@ -17,7 +17,7 @@ where
 import StoreService.Log (logError, safelyWith)
 import StoreService.Names.Phases (Phases, RegistrationId (..))
 import qualified StoreService.Names.Phases as Phases
-import StoreService.Names.Store (NamePhase (..), NameRegistration (..), VersionWrite (..), getRegistration, updateRegistration)
+import StoreService.Names.Store (NamePhase (..), NameRegistration (..), VersionWrite (..), getRegistration, releaseHeldBalance, updateRegistration)
 import StoreService.Providers (Funded (..), PaymentSignal (..), Received (..))
 import StoreService.Store.Invoices (InvoicePayment (..), InvoiceProduct (..), InvoiceRow (..), expireOverdueInvoice, lockInvoice, markCodePaid, paymentHolds, paymentStatusText, settlementCodeHash, settlementInvoice, truncateToSecond, updateInvoiceStatus, upsertPayment)
 import StoreService.Waiters (Waiters, publish, publishPayment)
@@ -184,13 +184,13 @@ nameSettled db before after wrotePayment holdsMoney r@NameRegistration {nrId, nr
       Just ISExpired -> (<> [NOLate nrId | holdsMoney]) . maybe [] (\(rid, v) -> [NOWritten rid v]) <$> closeOrder db r now
       _ -> pure [NOLate nrId | before /= ISOpen, wrotePayment]
 
--- | Clears a live unpaid order's live flag, as its invoice closes in the same transaction.
+-- | 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))
 closeOrder db r@NameRegistration {nrId, nrPhase, nrLive} now
   | nrPhase /= PUnpaid || not nrLive = pure Nothing
   | otherwise =
       updateRegistration db r {nrLive = False} now >>= \case
-        Written v -> pure (Just (nrId, v))
+        Written v -> Just (nrId, v) <$ releaseHeldBalance db nrId now
         _ -> E.throwIO (RegistrationChanged nrId)
 
 -- | The order of a name invoice whose status this transaction moved to expired.

apps/simplex-store-service/src/StoreService/Poller.hs

@@ -33,7 +33,7 @@ where
 
 import StoreService.Config (PollConfig (..))
 import StoreService.Names.Phases (Phases, RegistrationId (..))
-import StoreService.Names.Store (deleteUnpaidRegistration, unpaidCleanupCandidates)
+import StoreService.Names.Store (CleanupKept (..), deleteUnpaidRegistration, 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)
@@ -296,9 +296,10 @@ cleanupUnpaid env@PollerEnv {peStore, peCleanupLeft} now = do
               Left (ProviderError e) -> keep ("reading invoice " <> invText <> " failed: " <> e)
               Right signal_ -> do
                 mapM_ (\signal -> settleMoved env irProvider now (irProviderRef, signal)) signal_
-                deleted <- withTransaction peStore (`deleteUnpaidRegistration` rid)
-                unless deleted $ logError ("names cleanup: unpaid registration " <> ridText <> " is kept because invoice " <> invText <> " received a payment; refund it")
-                pure deleted
+                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 (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)
 

apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs

@@ -40,7 +40,7 @@ import StoreService.Names.Phases (RegistrationId (..))
 import StoreService.Names.Signatures (OrderFields (..))
 import StoreService.Names.Store (NameRegistration (..), NewRegistration (..), OrderTerms (..), PaidOrder (..), PrepaidCode (..), RegistrationPayment (..), createPaidRegistration, getRegistration, newRegistrationId, orderHash, textMethod)
 import StoreService.Names.Turns (withLabelTurn)
-import StoreService.Names.View (registrationAt, registrationView)
+import StoreService.Names.View (balanceJSON, registrationAt, registrationView)
 import StoreService.Orders (publishRegistration)
 import StoreService.Providers (OrderDraft (..), Provider (..), ProviderError (..), ProviderInvoice (..), expiresItself)
 import StoreService.Store.Invoices (InvoiceRow (..), NewNameInvoice (..), getInvoice, insertNameInvoice, newInvoiceId, truncateToSecond)
@@ -96,6 +96,7 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters
     answerResend now r@NameRegistration {nrPayment} = case nrPayment of
       RPInvoice _ invId -> getInvoice oeStore invId >>= maybe (refuse OROrderExists) (fmap answerNow . viewOf (registrationAt now r) . invoiceAt now)
       RPCode _ -> refuse OROrderExists
+      RPBalance -> refuse OROrderExists
     viewOf r row = jsonResponse status200 <$> nameInvoiceView env (confirmationsFor cfg) row r
     newOrder order@InvoiceOrder {ioRequest = OrderRequest {orFields = OrderFields {ofLabelHash, ofLength, ofDuration}, orTimestamp}, ioMethod, ioPrice} = do
       now <- oeNow
@@ -117,6 +118,7 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters
       invId <- newInvoiceId
       now <- truncateToSecond <$> oeNow
       let amount = CurrencyAmount ioPrice
+          price = fromIntegral ioPrice
       pCreateInvoice provider ioMethod OrderDraft {odAmount = amount, odCurrency = catalogCurrency} >>= \case
         Left (ProviderError e) -> do
           logError ("POST /api/invoice (name) failed: provider refused to create an invoice: " <> e)
@@ -125,8 +127,8 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters
           rid <- newRegistrationId
           let invoice = NewNameInvoice {nniInvoiceId = invId, nniProvider = pProvider provider, nniAmount = amount, nniCurrency = catalogCurrency, nniDestination = piDestination, nniExpiresAt = addUTCTime (invoiceWindow cfg ioMethod) now, nniCreatedAt = now}
               registration = NewRegistration {nrgId = rid, nrgOwner = orOwner, nrgOrder = orFields, nrgYears = nYears $ oeConfig env}
-              paid = PaidOrder {poMethod = ioMethod, poPrice = fromIntegral ioPrice, poInvoiceId = invId, poProviderRef = piProviderRef}
-          placeOrder env req (\db at -> insertNameInvoice db invoice >> first (const OROrderExists) <$> createPaidRegistration db registration paid at)
+              paid = PaidOrder {poMethod = ioMethod, poPrice = price, poInvoiceId = invId, poProviderRef = piProviderRef}
+          placeOrder env req [] (\db at -> insertNameInvoice db invoice >> first (const OROrderExists) <$> createPaidRegistration db registration (OTInvoice ioMethod price) paid Nothing at)
             `E.catch` strandedBy provider piProviderRef
             >>= \case
             Left refusal -> do
@@ -206,6 +208,7 @@ announceClosed OrdersEnv {oeStore, oePhases} providers waiters closed = do
     paidInvoice = \case
       RPInvoice _ invId -> Just invId
       RPCode _ -> Nothing
+      RPBalance -> Nothing
 
 cancelAtProvider :: Provider -> Text -> IO ()
 cancelAtProvider Provider {pCancelInvoice} ref =
@@ -222,8 +225,9 @@ firstRefusal = \case
   check : rest -> check >>= either (pure . Just) (const $ firstRefusal rest)
 
 nameInvoiceView :: OrdersEnv -> Maybe Int -> InvoiceRow -> NameRegistration -> IO J.Value
-nameInvoiceView OrdersEnv {oeStore, oeConfig, oeContracts} confirmations row@InvoiceRow {irInvoiceId = InvoiceId invId} r = do
-  view <- registrationView oeStore oeConfig oeContracts r
+nameInvoiceView OrdersEnv {oeStore, oeConfig, oeContracts, oeNow} confirmations row@InvoiceRow {irInvoiceId = InvoiceId invId} r = do
+  now <- oeNow
+  view <- registrationView oeStore oeConfig oeContracts now r
   pure $ J.object $ ["invoiceId" .= invId, "kind" .= ("name" :: Text), "registration" .= view] <> invoicePairs confirmations row
 
 orderRefusalResponse :: OrderRefusal -> Response
@@ -236,3 +240,4 @@ orderRefusalResponse = \case
   ORCatalogChanged price -> jsonResponse status409 $ J.object ["error" .= ("catalog_changed" :: Text), "price" .= price]
   ORCode refusal -> codeRefusalResponse refusal
   ORPriceTooHigh price -> jsonResponse status409 $ J.object ["error" .= ("price_too_high" :: Text), "price" .= price]
+  ORBalanceChanged balance -> jsonResponse status409 $ J.object ["error" .= ("balance_changed" :: Text), "balance" .= (balanceJSON <$> balance)]

apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs

@@ -79,6 +79,7 @@ foundJSON NameRegistration {nrId = RegistrationId rid, nrPayment, nrPhase, nrCre
     invoiceId = case nrPayment of
       RPInvoice _ (InvoiceId t) -> Just t
       RPCode _ -> Nothing
+      RPBalance -> Nothing
 
 -- | POST /api/registration/:id/name, another name or other links, under the turns of both names.
 retargetHandler :: OrdersEnv -> Text -> Request -> Respond -> IO ResponseReceived
@@ -105,7 +106,7 @@ retargetHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} r
           | nrLabelHash stored `notElem` held -> changed
           | otherwise -> moveTo now (registrationAt now stored) fields timestamp
     moveTo now r@NameRegistration {nrPhase} fields timestamp
-      | orderFieldsOf r == fields = answerNow . jsonResponse status200 <$> registrationView oeStore oeConfig oeContracts r
+      | orderFieldsOf r == fields = answerNow . jsonResponse status200 <$> registrationView oeStore oeConfig oeContracts now r
       | Left refusal <- checkTimestamp now timestamp = refuse refusal
       | not (movable r) = refuse ORBadRequest
       | nrPhase == PFailed =
@@ -122,6 +123,7 @@ retargetHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} r
             Just refusal -> refuse refusal
             Nothing -> case nrPayment of
               RPInvoice {} -> checkMovePrice oeContracts r ofLength >>= either refuse (write now r fields)
+              RPBalance -> checkMovePrice oeContracts r ofLength >>= either refuse (write now r fields)
               RPCode _ -> write now r fields nrPrice
     write now r fields price =
       retargetOrder env r fields price >>= \case
@@ -130,7 +132,7 @@ retargetHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} r
         Left (WRRefused refusal) -> refuse refusal
     movedAnswer now v =
       withTransaction oeStore (`getRegistration` rid) >>= \case
-        Just r -> written env rid v . jsonResponse status200 <$> registrationView oeStore oeConfig oeContracts (registrationAt now r)
+        Just r -> written env rid v . jsonResponse status200 <$> registrationView oeStore oeConfig oeContracts now (registrationAt now r)
         Nothing -> answerNow internalError <$ logError ("POST /api/registration/:id/name: order " <> ridText <> " is not readable after its move")
     changed = answerNow <$> registrationChangedResponse env rid
     refuse = refused "POST /api/registration/:id/name"

apps/simplex-store-service/src/StoreService/Web/Names/Registration.hs

@@ -54,7 +54,7 @@ registrationHandler OrdersEnv {oeStore, oeConfig, oeContracts, oePhases, oeNow}
   where
     rid = RegistrationId ridText
     readNow = oeNow >>= \now -> fmap (now,) <$> withTransaction oeStore (`getRegistration` rid)
-    answer (now, r) = respond . jsonResponse status200 =<< registrationView oeStore oeConfig oeContracts (registrationAt now r)
+    answer (now, r) = respond . jsonResponse status200 =<< registrationView oeStore oeConfig oeContracts now (registrationAt now r)
 
 -- | What a reveal decided in the name's turn, with the version it wrote; the publish and the answer come after the turn.
 data RevealDecision
@@ -150,7 +150,7 @@ registrationRefusalResponse env tag rid = maybe notFound refusal <$> currentView
 -- | The registration's view as it reads now.
 currentView :: OrdersEnv -> RegistrationId -> IO (Maybe J.Value)
 currentView OrdersEnv {oeStore, oeConfig, oeContracts, oeNow} rid =
-  withTransaction oeStore (`getRegistration` rid) >>= traverse (\r -> oeNow >>= \now -> registrationView oeStore oeConfig oeContracts (registrationAt now r))
+  withTransaction oeStore (`getRegistration` rid) >>= traverse (\r -> oeNow >>= \now -> registrationView oeStore oeConfig oeContracts now (registrationAt now r))
 
 -- | The hold, cut to end just past the next moment at which the answer changes with time alone.
 heldFor :: Int -> UTCTime -> [UTCTime] -> Int

simplex-chat.cabal

@@ -767,6 +767,7 @@ test-suite simplex-chat-test
       Bots.StoreService.GroupIntegrationTests
       Bots.StoreService.GroupTests
       Bots.StoreService.NameRegistrationTests
+      Bots.StoreService.NamesBalancesTests
       Bots.StoreService.NamesChainTests
       Bots.StoreService.NamesCodesTests
       Bots.StoreService.NamesContractsTests

tests/Bots/StoreService/NamesBalancesTests.hs

@@ -0,0 +1,665 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Bots.StoreService.NamesBalancesTests (namesBalancesTests) where
+
+import Bots.StoreService.NamesOrdersTests (Ctx (..), withOrders)
+import Bots.StoreService.NamesStoreTests (at, btc, invoiceStatus, newReg, ownerA, ownerB, paidOrder, reg, signature, t0, write)
+import Bots.StoreService.WebTests (capturingStderr, rcv, withServiceStore, withServiceStores)
+import Control.Concurrent.Async (async, wait)
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Control.Concurrent.STM (atomically, check)
+import Control.Monad (forM_)
+import Data.Bifunctor (first)
+import Data.Int (Int64)
+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.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.SimplexName (labelHash)
+import StoreService.Config (ServiceConfig (..))
+import StoreService.Names.Orders (ClosedOrder (..), OrderRefusal (..), OrderRequest (..), OrdersEnv (..))
+import qualified StoreService.Names.Orders as Orders
+import StoreService.Names.Phases (RegistrationId (..))
+import StoreService.Names.Signatures (OrderFields (..))
+import StoreService.Names.Store
+import StoreService.Names.Turns (balanceTurnCount, newTurns, turnsCount, withBalanceTurn, withLabelTurn)
+import StoreService.Orders (cancelOpenInvoice, expireOverdue, settleOrder)
+import StoreService.Poller (cleanupUnpaid, newPollerEnv, unpaidRetention)
+import StoreService.Providers (PaymentSignal (..))
+import StoreService.Waiters (newWaiters)
+import StoreService.Web.Server (WebEnv (..))
+import System.Timeout (timeout)
+import Test.Hspec
+
+#if defined(dbPostgres)
+import Control.Concurrent.Async (concurrently)
+import Control.Concurrent.STM (modifyTVar', newTVarIO, readTVar)
+import Data.Either (isRight)
+import Database.PostgreSQL.Simple (Only (..), (:.) (..))
+#else
+import Database.SQLite.Simple (Only (..), (:.) (..))
+#endif
+
+namesBalancesTests :: Spec
+namesBalancesTests = describe "StoreService names: balances" $ do
+  describe "store" $ do
+    it "credits a balance, making it on the first credit" testCredit
+    it "spends a covered price at once from the amount seen, refusing a stale amount, a dearer price or a held balance, changing nothing" testSpendAtOnce
+    it "lets one of two difference orders hold a balance, the losing order not written" testTwoHolds
+    it "spends a hold only for its holder and while the amount covers it, clearing the hold" testSpendHeld
+    it "releases a hold only for its holder" testRelease
+    it "refunds a balance only at its amount, above 0 and not held, refused while held and accepted once released" testRefund
+    it "keeps amount = credited - spent - refunded over spends at once, a held spend, a released hold and a refund, spent counting orders past unpaid" testInvariant
+    it "keeps the invariant over credit, refund, credit, refund, refunded the sum" testCreditRefundTwice
+    it "reads a hold and a spend back through a new store connection" testRestart
+    it "finds an order and its balance by the order's registration id or its invoice id" testByReference
+    it "chains an order back along its balance sources over three orders, with each payment and its cents" testChain
+    it "stops the chain of a closed difference order at itself, with its late credits" testChainOfClosed
+    it "hashes a balance order over its fields, the paying order, price, balance and method, and stores it for a difference spend" testBalanceOrderHash
+    it "returns the 50 newest orders and then every older one holding a balance above 0" testFindBalances
+  describe "closes" $ do
+    it "releases a hold at a cancel, the sweep's expiry, settlement's expiry and the next order's close" testClosesRelease
+    it "reads an overdue holder's hold as none, and closes it in the transaction of the order placed" testOverdueHolderClosed
+    it "skips a named holder no longer live, and refuses with the balance when a live one cannot be closed" testNamedHolders
+    it "keeps at the cleanup, and logs, an unpaid order still holding a balance" testCleanupKeepsHolder
+  describe "late credits" $ do
+    it "credits a late payment once per credit number, a taken number changing neither the rows nor the balance" testCreditLatePayment
+    it "tells each case of pending money and selects confirmed money not all credited, by the order whatever the invoice's status" testLateScans
+    it "leaves 0.1 and 0.2 BTC credited against 0.3 confirmed neither pending nor selected" testExactUnits
+    it "alerts on pending money past the cutoff once, again only when more arrives, claimed by one of two instances" testLateAlerts
+  describe "turns" $ do
+    it "runs two holders of one balance one after the other, and nests in a label turn" testBalanceTurn
+#if defined(dbPostgres)
+  describe "two connections" $ do
+    it "applies one of a spend and a refund, or of a held spend and a refund, and keeps the invariant for a credit and a refund" testConcurrentWrites
+#endif
+
+-- fixtures
+
+-- | Every name and commitment its own, so any number of live orders fit.
+fieldsN :: Text -> OrderFields
+fieldsN label =
+  OrderFields
+    { ofLabelHash = labelHash label,
+      ofLength = T.length label,
+      ofDuration = 69292800,
+      ofCommitment = C.sha256Hash $ encodeUtf8 label,
+      ofSealed = "sealed-" <> label
+    }
+
+-- | A crypto invoice row, or a card one with its client secret in place of an address.
+invoiceRow :: DB.Connection -> Text -> Bool -> Int -> UTCTime -> IO ()
+invoiceRow db invId card cents expiresAt =
+  DB.execute
+    db
+    "INSERT INTO sx_badge_service_invoices (invoice_id, provider, price, amount, currency, payment_url, payment_address, payment_crypto_currency, payment_crypto_amount, expires_at, status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
+    ((invId, provider, cents, cents, "usd" :: Text, url, address, currency, cryptoAmount, expiresAt) :. ("open" :: Text, t0, t0))
+  where
+    destination :: (Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text)
+    destination
+      | card = ("stripe", Just "pi_secret", Nothing, Nothing, Nothing)
+      | otherwise = ("crypto", Nothing, Just "bc1qexampleaddress", Just "btc", Just "0.003")
+    (provider, url, address, currency, cryptoAmount) = destination
+
+-- | A paid order, unpaid and live, whose invoice of the cents expires at the given time.
+placeOrderRow :: DBStore -> Text -> Bool -> Int -> UTCTime -> IO ()
+placeOrderRow st r card cents expiresAt = withTransaction st $ \db -> do
+  invoiceRow db ("inv-" <> r) card cents expiresAt
+  createPaidRegistration db (newReg r ownerA (fieldsN r)) (OTInvoice method cents) (paidOrder ("inv-" <> r)) {poMethod = method, poPrice = cents} Nothing t0 `shouldReturn` Right ()
+  where
+    method = if card then SPMCard CPStripe else btc
+
+-- | A taken paid order with a balance of its price.
+source :: DBStore -> Text -> Int -> IO ()
+source st r cents = do
+  placeOrderRow st r False cents (at 60)
+  taken <- reg st r
+  write st taken {nrPhase = PTaken} `shouldReturn` Written 2
+  credit st r cents
+
+credit :: DBStore -> Text -> Int -> IO ()
+credit st r cents = withTransaction st $ \db -> creditBalance db (RegistrationId r) cents t0
+
+holdPrice :: Int
+holdPrice = 40000
+
+holdTerms :: Text -> Int -> OrderTerms
+holdTerms src seen = OTBalance (RegistrationId src) holdPrice seen (Just btc)
+
+-- | A difference order holding all of the source's balance seen, its invoice of the difference expiring at the given time.
+holder :: DBStore -> Text -> Text -> Int -> UTCTime -> IO (Either RegistrationRefused ())
+holder st r src seen expiresAt = withTransaction st $ \db -> do
+  invoiceRow db ("inv-" <> r) False (holdPrice - seen) expiresAt
+  createPaidRegistration db (newReg r ownerA (fieldsN r)) (holdTerms src seen) (paidOrder ("inv-" <> r)) {poPrice = holdPrice} (Just $ HeldBalance (RegistrationId src) seen) t0
+
+hold :: Text -> UTCTime -> Bool -> BalanceHold
+hold h bhUntil bhOverdue = BalanceHold {bhHolder = RegistrationId h, bhUntil, bhOverdue}
+
+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
+
+-- | The holder queued and its hold spent in one transaction, as settlement does.
+settleHolder :: DB.Connection -> NameRegistration -> IO Bool
+settleHolder db r = do
+  updateRegistration db r {nrPhase = PQueued} t0 `shouldReturn` Written (nrVersion r + 1)
+  spendHeldBalance db (nrId r) (nrBalanceUsed r) t0
+
+release :: DBStore -> Text -> IO Bool
+release st h = withTransaction st $ \db -> releaseHeldBalance db (RegistrationId h) t0
+
+refund :: DBStore -> Text -> Int -> IO Bool
+refund st r cents = withTransaction st $ \db -> refundBalance db (RegistrationId r) cents (at 5)
+
+-- | Amount, credited, refunded and the hold, as they read at the given time.
+figures :: DBStore -> Text -> UTCTime -> IO (Maybe (Int, Int, Int, Maybe BalanceHold))
+figures st r now = withTransaction st $ \db -> fmap (\Balance {blAmount, blCredited, blRefunded, blHold} -> (blAmount, blCredited, blRefunded, blHold)) <$> getBalance db (RegistrationId r) now
+
+-- | amount = credited - spent - refunded, spent being the balance_used of the orders past unpaid it paid for.
+invariantHolds :: DBStore -> Text -> IO ()
+invariantHolds st r = do
+  Just (amount, credited, refunded, _) <- figures st r t0
+  used <- withTransaction st $ \db -> DB.query db "SELECT balance_used FROM sx_badge_service_name_registrations WHERE balance_source = ? AND phase <> ?" (r, PUnpaid)
+  (r, amount) `shouldBe` (r, credited - sum (map fromOnly (used :: [Only Int])) - refunded)
+
+absent :: DBStore -> Text -> IO ()
+absent st r = withTransaction st (\db -> getRegistration db (RegistrationId r)) `shouldReturn` Nothing
+
+-- | A payment row with the figures the provider's reads left: cents received and confirmed, the crypto text, and units received and confirmed.
+data Paid = Paid
+  { pCents :: Int,
+    pConfirmedCents :: Int,
+    pCrypto :: Maybe Text,
+    pUnits :: Maybe Int64,
+    pConfirmedUnits :: Maybe Int64,
+    pInFull :: Bool
+  }
+
+cryptoPaid :: Int64 -> Int64 -> Paid
+cryptoPaid units confirmed = Paid {pCents = 20000, pConfirmedCents = 0, pCrypto = Just "0.003", pUnits = Just units, pConfirmedUnits = Just confirmed, pInFull = False}
+
+cardPaid :: Int -> Int -> Paid
+cardPaid cents confirmed = Paid {pCents = cents, pConfirmedCents = confirmed, pCrypto = Nothing, pUnits = Nothing, pConfirmedUnits = Nothing, pInFull = False}
+
+payment :: DBStore -> Text -> Paid -> UTCTime -> IO ()
+payment st invId Paid {pCents, pConfirmedCents, pCrypto, pUnits, pConfirmedUnits, pInFull} createdAt =
+  withTransaction st $ \db ->
+    DB.execute
+      db
+      "INSERT INTO sx_badge_service_payments (payment_id, invoice_id, provider, amount, currency, crypto_paid, paid_in_full, status, confirmed_amount, received_units, confirmed_units, invoice_rate, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
+      ((invId, invId, "crypto" :: Text, pCents, "usd" :: Text, pCrypto, if pInFull then 1 else 0 :: Int, "pending" :: Text, pConfirmedCents, pUnits) :. (pConfirmedUnits, Just ("62500" :: Text), createdAt, createdAt))
+
+-- | An order closed unpaid, by crypto unless card, with a late payment row created at the given time.
+closedWith :: DBStore -> Text -> Bool -> Paid -> UTCTime -> IO ()
+closedWith st r card paid createdAt = do
+  placeOrderRow st r card 20000 (at 60)
+  open <- reg st r
+  write st open {nrLive = False} `shouldReturn` Written 2
+  payment st ("inv-" <> r) paid createdAt
+
+lateCredit :: Text -> Int -> Maybe Int64 -> Int -> LateCredit
+lateCredit r n units cents =
+  LateCredit
+    { lcInvoice = InvoiceId ("inv-" <> r),
+      lcCreditNo = n,
+      lcRegistration = RegistrationId r,
+      lcUnits = units,
+      lcInvoiceRate = Just "62500",
+      lcCurrentRate = Just "60000.5",
+      lcRateUsed = Just "60000.5",
+      lcCents = cents
+    }
+
+creditLate :: DBStore -> LateCredit -> IO Bool
+creditLate st c = withTransaction st $ \db -> creditLatePayment db c (at 3)
+
+orderRequest :: Text -> OrderRequest
+orderRequest r = OrderRequest {orOwner = ownerA, orFields = fieldsN r, orTimestamp = 0, orSignature = signature}
+
+spendInsert :: Text -> Text -> Int -> Int -> DB.Connection -> UTCTime -> IO (Either OrderRefusal ())
+spendInsert r src price seen db now = first (const $ ORBalanceChanged Nothing) <$> createBalanceRegistration db (newReg r ownerA (fieldsN r)) (RegistrationId src) price seen now
+
+closedIds :: Either OrderRefusal [ClosedOrder] -> Either OrderRefusal [(RegistrationId, Int64)]
+closedIds = fmap $ map $ \ClosedOrder {coRegistration, coVersion} -> (nrId coRegistration, coVersion)
+
+-- store
+
+testCredit :: IO ()
+testCredit = withServiceStore $ \st -> do
+  placeOrderRow st "s" False 20000 (at 60)
+  figures st "s" t0 `shouldReturn` Nothing
+  credit st "s" 20000
+  credit st "s" 2500
+  figures st "s" t0 `shouldReturn` Just (22500, 22500, 0, Nothing)
+
+testSpendAtOnce :: IO ()
+testSpendAtOnce = withServiceStore $ \st -> do
+  source st "s" 10000
+  coveredSpend st "c1" "s" 6000 10000 `shouldReturn` Right ()
+  c1 <- reg st "c1"
+  (nrPhase c1, nrLive c1, nrPrice c1, nrPayment c1, nrBalanceSource c1, nrBalanceUsed c1) `shouldBe` (PQueued, True, 6000, RPBalance, Just (RegistrationId "s"), 6000)
+  nrOrderHash c1 `shouldBe` orderHash ownerA (fieldsN "c1") (OTBalance (RegistrationId "s") 6000 10000 Nothing)
+  figures st "s" t0 `shouldReturn` Just (4000, 10000, 0, Nothing)
+  coveredSpend st "c2" "s" 3000 10000 `shouldReturn` Left RRBalanceChanged
+  coveredSpend st "c3" "s" 5000 4000 `shouldReturn` Left RRBalanceChanged
+  mapM_ (absent st) ["c2", "c3"]
+  figures st "s" t0 `shouldReturn` Just (4000, 10000, 0, Nothing)
+  holder st "h" "s" 4000 (at 60) `shouldReturn` Right ()
+  coveredSpend st "c4" "s" 1000 4000 `shouldReturn` Left RRBalanceChanged
+  absent st "c4"
+  release st "h" `shouldReturn` True
+  coveredSpend st "c5" "s" 4000 4000 `shouldReturn` Right ()
+  figures st "s" t0 `shouldReturn` Just (0, 10000, 0, Nothing)
+
+testTwoHolds :: IO ()
+testTwoHolds = withServiceStore $ \st -> do
+  source st "s" 10000
+  holder st "h1" "s" 10000 (at 60) `shouldReturn` Right ()
+  holder st "h2" "s" 10000 (at 60) `shouldReturn` Left RRBalanceChanged
+  absent st "h2"
+  h1 <- reg st "h1"
+  (nrPhase h1, nrPayment h1, nrPrice h1, nrBalanceSource h1, nrBalanceUsed h1) `shouldBe` (PUnpaid, RPInvoice btc (InvoiceId "inv-h1"), holdPrice, Just (RegistrationId "s"), 10000)
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Just $ hold "h1" (at 60) False)
+  release st "h1" `shouldReturn` True
+  holder st "h3" "s" 9000 (at 60) `shouldReturn` Left RRBalanceChanged
+  absent st "h3"
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Nothing)
+
+testSpendHeld :: IO ()
+testSpendHeld = withServiceStore $ \st -> do
+  source st "s" 10000
+  source st "other" 5000
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  holder st "g" "other" 5000 (at 60) `shouldReturn` Right ()
+  let spendBy :: Text -> Int -> IO Bool
+      spendBy h used = withTransaction st $ \db -> spendHeldBalance db (RegistrationId h) used t0
+  spendBy "nobody" 10000 `shouldReturn` False
+  spendBy "h" 10001 `shouldReturn` False
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Just $ hold "h" (at 60) False)
+  spendBy "g" 5000 `shouldReturn` True
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Just $ hold "h" (at 60) False)
+  figures st "other" t0 `shouldReturn` Just (0, 5000, 0, Nothing)
+  spendBy "h" 10000 `shouldReturn` True
+  figures st "s" t0 `shouldReturn` Just (0, 10000, 0, Nothing)
+  spendBy "h" 0 `shouldReturn` False
+
+testRelease :: IO ()
+testRelease = withServiceStore $ \st -> do
+  source st "s" 10000
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  release st "g" `shouldReturn` False
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Just $ hold "h" (at 60) False)
+  release st "h" `shouldReturn` True
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Nothing)
+  release st "h" `shouldReturn` False
+
+testRefund :: IO ()
+testRefund = withServiceStore $ \st -> do
+  source st "s" 10000
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  refund st "s" 10000 `shouldReturn` False
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Just $ hold "h" (at 60) False)
+  release st "h" `shouldReturn` True
+  mapM (refund st "s") [9999, 10001] `shouldReturn` [False, False]
+  figures st "s" t0 `shouldReturn` Just (10000, 10000, 0, Nothing)
+  refund st "s" 10000 `shouldReturn` True
+  Just Balance {blAmount, blCredited, blRefunded, blRefundedAt} <- withTransaction st $ \db -> getBalance db (RegistrationId "s") t0
+  (blAmount, blCredited, blRefunded, blRefundedAt) `shouldBe` (0, 10000, 10000, Just (at 5))
+  mapM (refund st "s") [0, 10000] `shouldReturn` [False, False]
+
+testInvariant :: IO ()
+testInvariant = withServiceStore $ \st -> do
+  source st "s" 30000
+  invariantHolds st "s"
+  coveredSpend st "c1" "s" 5000 30000 `shouldReturn` Right ()
+  invariantHolds st "s"
+  holder st "h1" "s" 25000 (at 60) `shouldReturn` Right ()
+  invariantHolds st "s"
+  h1 <- reg st "h1"
+  withTransaction st (`settleHolder` h1) `shouldReturn` True
+  figures st "s" t0 `shouldReturn` Just (0, 30000, 0, Nothing)
+  invariantHolds st "s"
+  credit st "s" 8000
+  holder st "h2" "s" 8000 (at 60) `shouldReturn` Right ()
+  h2 <- reg st "h2"
+  withTransaction st (\db -> closeOverdue db h2 (at 61)) `shouldReturn` Just (nrVersion h2 + 1)
+  figures st "s" t0 `shouldReturn` Just (8000, 38000, 0, Nothing)
+  invariantHolds st "s"
+  refund st "s" 8000 `shouldReturn` True
+  figures st "s" t0 `shouldReturn` Just (0, 38000, 8000, Nothing)
+  invariantHolds st "s"
+
+testCreditRefundTwice :: IO ()
+testCreditRefundTwice = withServiceStore $ \st -> do
+  source st "s" 10000
+  refund st "s" 10000 `shouldReturn` True
+  credit st "s" 4000
+  refund st "s" 4000 `shouldReturn` True
+  figures st "s" t0 `shouldReturn` Just (0, 14000, 14000, Nothing)
+  invariantHolds st "s"
+
+testRestart :: IO ()
+testRestart = withServiceStores $ \open -> do
+  st <- open
+  source st "s" 10000
+  source st "t" 8000
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  coveredSpend st "c" "t" 3000 8000 `shouldReturn` Right ()
+  let readBack :: DBStore -> IO (Maybe (Int, Int, Int, Maybe BalanceHold), Maybe (Int, Int, Int, Maybe BalanceHold), NameRegistration, NameRegistration)
+      readBack store = (,,,) <$> figures store "s" t0 <*> figures store "t" t0 <*> reg store "h" <*> reg store "c"
+  stored@(held, spent, _, c) <- readBack st
+  (held, spent, nrBalanceUsed c) `shouldBe` (Just (10000, 10000, 0, Just $ hold "h" (at 60) False), Just (5000, 8000, 0, Nothing), 3000)
+  restarted <- open
+  readBack restarted `shouldReturn` stored
+
+testByReference :: IO ()
+testByReference = withServiceStore $ \st -> do
+  source st "s" 10000
+  placeOrderRow st "plain" False 20000 (at 60)
+  let byRef :: Text -> IO (Maybe (RegistrationId, Maybe Int))
+      byRef ref = withTransaction st $ \db -> fmap (fmap (fmap blAmount)) <$> balanceByReference db ref t0
+  mapM byRef ["s", "inv-s"] `shouldReturn` replicate 2 (Just (RegistrationId "s", Just 10000))
+  mapM byRef ["plain", "inv-plain"] `shouldReturn` replicate 2 (Just (RegistrationId "plain", Nothing))
+  byRef "nothing" `shouldReturn` Nothing
+
+testChain :: IO ()
+testChain = withServiceStore $ \st -> do
+  source st "a" 20000
+  holder st "b" "a" 20000 (at 60) `shouldReturn` Right ()
+  b <- reg st "b"
+  withTransaction st (`settleHolder` b) `shouldReturn` True
+  queued <- reg st "b"
+  write st queued {nrPhase = PTaken} `shouldReturn` Written (nrVersion queued + 1)
+  credit st "b" holdPrice
+  coveredSpend st "c" "b" 10000 holdPrice `shouldReturn` Right ()
+  withTransaction st (\db -> balanceChain db (RegistrationId "c"))
+    `shouldReturn` [ BalanceLink {lkRegistration = RegistrationId "c", lkPayment = RPBalance, lkPaid = 0, lkFromBalance = 10000, lkLateCredits = []},
+                     BalanceLink {lkRegistration = RegistrationId "b", lkPayment = RPInvoice btc (InvoiceId "inv-b"), lkPaid = holdPrice - 20000, lkFromBalance = 20000, lkLateCredits = []},
+                     BalanceLink {lkRegistration = RegistrationId "a", lkPayment = RPInvoice btc (InvoiceId "inv-a"), lkPaid = 20000, lkFromBalance = 0, lkLateCredits = []}
+                   ]
+
+testChainOfClosed :: IO ()
+testChainOfClosed = withServiceStore $ \st -> do
+  source st "s" 15000
+  holder st "d" "s" 15000 (at 60) `shouldReturn` Right ()
+  waiters <- newWaiters
+  cancelOpenInvoice st waiters Nothing (InvoiceId "inv-d") (at 2) `shouldReturn` True
+  figures st "s" t0 `shouldReturn` Just (15000, 15000, 0, Nothing)
+  let late = lateCredit "d" 1 (Just 40000) 2400
+  creditLate st late `shouldReturn` True
+  withTransaction st (\db -> balanceChain db (RegistrationId "d"))
+    `shouldReturn` [BalanceLink {lkRegistration = RegistrationId "d", lkPayment = RPInvoice btc (InvoiceId "inv-d"), lkPaid = 0, lkFromBalance = 0, lkLateCredits = [late]}]
+
+testBalanceOrderHash :: IO ()
+testBalanceOrderHash = withServiceStore $ \st -> do
+  let o = fieldsN "h"
+      terms = holdTerms "s" 15000
+      base = orderHash ownerA o terms
+      src = RegistrationId "s"
+      variants =
+        [ ("labelHash" :: Text, orderHash ownerA o {ofLabelHash = labelHash "hh"} terms),
+          ("length", orderHash ownerA o {ofLength = 2} terms),
+          ("duration", orderHash ownerA o {ofDuration = 69292801} terms),
+          ("owner", orderHash ownerB o terms),
+          ("commitment", orderHash ownerA o {ofCommitment = C.sha256Hash "another"} terms),
+          ("sealed", orderHash ownerA o {ofSealed = ofSealed o <> "x"} terms),
+          ("paying order", orderHash ownerA o (OTBalance (RegistrationId "t") holdPrice 15000 (Just btc))),
+          ("price", orderHash ownerA o (OTBalance src (holdPrice + 1) 15000 (Just btc))),
+          ("balance", orderHash ownerA o (OTBalance src holdPrice 15001 (Just btc))),
+          ("method", orderHash ownerA o (OTBalance src holdPrice 15000 (Just $ SPMCard CPStripe))),
+          ("no method", orderHash ownerA o (OTBalance src holdPrice 15000 Nothing)),
+          ("an invoice order", orderHash ownerA o (OTInvoice btc holdPrice))
+        ]
+  orderHash ownerA (fieldsN "h") (holdTerms "s" 15000) `shouldBe` base
+  forM_ variants $ \(field, h) -> (field, h == base) `shouldBe` (field, False)
+  source st "s" 15000
+  holder st "h" "s" 15000 (at 60) `shouldReturn` Right ()
+  fmap nrId <$> withTransaction st (`getRegistrationByOrderHash` base) `shouldReturn` Just (RegistrationId "h")
+
+testFindBalances :: IO ()
+testFindBalances = withServiceStore $ \st -> do
+  let rid :: Int -> Text
+      rid i = "r" <> T.pack (show i)
+  forM_ [1 .. 52 :: Int] $ \i -> withTransaction st $ \db -> do
+    invoiceRow db ("inv-" <> rid i) False 20000 (at 60)
+    createPaidRegistration db (newReg (rid i) ownerA (fieldsN $ rid i)) (OTInvoice btc 20000) (paidOrder ("inv-" <> rid i)) Nothing (at i) `shouldReturn` Right ()
+  credit st "r1" 5000
+  credit st "r2" 3000
+  refund st "r2" 3000 `shouldReturn` True
+  map nrId <$> withTransaction st (`findRegistrations` ownerA) `shouldReturn` map (RegistrationId . rid) ([52, 51 .. 3] <> [1])
+
+-- closes
+
+testClosesRelease :: IO ()
+testClosesRelease = withServiceStore $ \st -> do
+  waiters <- newWaiters
+  let closes = ["cancel", "sweep", "settled", "next"]
+  forM_ closes $ \c -> do
+    source st ("s-" <> c) 10000
+    holder st ("h-" <> c) ("s-" <> c) 10000 (at 60) `shouldReturn` Right ()
+  cancelOpenInvoice st waiters Nothing (InvoiceId "inv-h-cancel") (at 2) `shouldReturn` True
+  expireOverdue st waiters Nothing (at 61) (at 61) [InvoiceId "inv-h-sweep"] `shouldReturn` [InvoiceId "inv-h-sweep"]
+  settleOrder st waiters Nothing (InvoiceId "inv-h-settled") (SigClosed (rcv 0 Nothing)) (at 2) `shouldReturn` Right ISExpired
+  next <- reg st "h-next"
+  withTransaction st (\db -> closeOverdue db next (at 61)) `shouldReturn` Just (nrVersion next + 1)
+  forM_ closes $ \c -> do
+    (c,) <$> figures st ("s-" <> c) t0 `shouldReturn` (c, Just (10000, 10000, 0, Nothing))
+    (c,) . nrLive <$> reg st ("h-" <> c) `shouldReturn` (c, False)
+    (c,) <$> invoiceStatus st ("inv-h-" <> c) `shouldReturn` (c, "expired")
+
+testOverdueHolderClosed :: IO ()
+testOverdueHolderClosed = withOrders $ \Ctx {cStore = st, cOrders} -> do
+  now <- oeNow cOrders
+  source st "s" 10000
+  holder st "h" "s" 10000 (at 60) `shouldReturn` Right ()
+  Just balance <- withTransaction st $ \db -> getBalance db (RegistrationId "s") now
+  (blHold balance, heldBy balance) `shouldBe` (Just $ hold "h" (at 60) True, Nothing)
+  Just h <- withTransaction st $ \db -> overdueHolder db (RegistrationId "s") now
+  nrId h `shouldBe` RegistrationId "h"
+  withTransaction st (\db -> overdueHolder db (RegistrationId "s") t0) `shouldReturn` Nothing
+  closedIds <$> Orders.placeOrder cOrders (orderRequest "c") [h] (\_ _ -> pure $ Left ORBadRequest) `shouldReturn` Left ORBadRequest
+  invoiceStatus st "inv-h" `shouldReturn` "open"
+  nrLive <$> reg st "h" `shouldReturn` True
+  figures st "s" now `shouldReturn` Just (10000, 10000, 0, Just $ hold "h" (at 60) True)
+  closedIds <$> Orders.placeOrder cOrders (orderRequest "c") [h] (spendInsert "c" "s" 6000 10000) `shouldReturn` Right [(RegistrationId "h", nrVersion h + 1)]
+  invoiceStatus st "inv-h" `shouldReturn` "expired"
+  nrLive <$> reg st "h" `shouldReturn` False
+  figures st "s" now `shouldReturn` Just (4000, 10000, 0, Nothing)
+  nrPhase <$> reg st "c" `shouldReturn` PQueued
+
+testNamedHolders :: IO ()
+testNamedHolders = withOrders $ \Ctx {cStore = st, cOrders, cWeb} -> do
+  now <- oeNow cOrders
+  source st "s1" 10000
+  holder st "h1" "s1" 10000 (at 60) `shouldReturn` Right ()
+  h1 <- reg st "h1"
+  cancelOpenInvoice st (weWaiters cWeb) Nothing (InvoiceId "inv-h1") now `shouldReturn` True
+  closedIds <$> Orders.placeOrder cOrders (orderRequest "c1") [h1] (spendInsert "c1" "s1" 6000 10000) `shouldReturn` Right []
+  figures st "s1" now `shouldReturn` Just (4000, 10000, 0, Nothing)
+  source st "s2" 10000
+  holder st "h2" "s2" 10000 (at 60) `shouldReturn` Right ()
+  h2 <- reg st "h2"
+  payment st "inv-h2" (cardPaid 100 0) (at 61)
+  Just funded <- withTransaction st $ \db -> getBalance db (RegistrationId "s2") now
+  blHold funded `shouldBe` Just (hold "h2" (at 60) False)
+  closedIds <$> Orders.placeOrder cOrders (orderRequest "c2") [h2] (spendInsert "c2" "s2" 6000 10000) `shouldReturn` Left (ORBalanceChanged $ Just funded)
+  absent st "c2"
+  nrLive <$> reg st "h2" `shouldReturn` True
+  invoiceStatus st "inv-h2" `shouldReturn` "open"
+
+testCleanupKeepsHolder :: IO ()
+testCleanupKeepsHolder = withOrders $ \Ctx {cStore = st, cWeb} -> do
+  source st "s" 10000
+  holder st "h" "s" 10000 t0 `shouldReturn` Right ()
+  let due = addUTCTime (unpaidRetention + 1) t0
+  poller <- newPollerEnv st (weWaiters cWeb) Nothing (weHints cWeb) (weProviders cWeb) (poll $ weConfig cWeb)
+  logs <- capturingStderr $ cleanupUnpaid poller due
+  logs `shouldSatisfy` T.isInfixOf "unpaid registration h is kept because it still holds the balance of registration s"
+  nrLive <$> reg st "h" `shouldReturn` True
+  figures st "s" due `shouldReturn` Just (10000, 10000, 0, Just $ hold "h" t0 True)
+
+-- late credits
+
+testCreditLatePayment :: IO ()
+testCreditLatePayment = withServiceStore $ \st -> do
+  closedWith st "x" False (cryptoPaid 400000 400000) t0
+  let state :: IO (Maybe (Int64, Int, Int))
+      state = withTransaction st $ \db -> fmap (\LateCreditState {lsCreditedUnits, lsCreditedCents, lsCredits} -> (lsCreditedUnits, lsCreditedCents, lsCredits)) <$> lateCreditState db (InvoiceId "inv-x")
+  creditLate st (lateCredit "x" 1 (Just 300000) 3000) `shouldReturn` True
+  creditLate st (lateCredit "x" 1 (Just 100000) 1000) `shouldReturn` False
+  figures st "x" t0 `shouldReturn` Just (3000, 3000, 0, Nothing)
+  state `shouldReturn` Just (300000, 3000, 1)
+  creditLate st (lateCredit "x" 2 (Just 100000) 1000) `shouldReturn` True
+  figures st "x" t0 `shouldReturn` Just (4000, 4000, 0, Nothing)
+  state `shouldReturn` Just (400000, 4000, 2)
+
+testLateScans :: IO ()
+testLateScans = withServiceStore $ \st -> do
+  let cases =
+        [ ("uncredited", False, cryptoPaid 300000 300000, Just LPUncredited),
+          ("unconfirmed", False, cryptoPaid 300000 0, Just LPUnconfirmed),
+          ("monero", False, Paid {pCents = 0, pConfirmedCents = 0, pCrypto = Just "0", pUnits = Just 0, pConfirmedUnits = Just 0, pInFull = True}, Just LPConfirming),
+          ("part", False, cryptoPaid 300000 100000, Just LPUnconfirmed),
+          ("card", True, cardPaid 5000 5000, Just LPUncredited),
+          ("cardpending", True, cardPaid 5000 0, Just LPUnconfirmed),
+          ("settledlate", False, cryptoPaid 200000 200000, Just LPUncredited),
+          ("uncounted", False, (cryptoPaid 0 0) {pCents = 5000, pUnits = Nothing}, Just LPUncounted),
+          ("credited", True, cardPaid 5000 5000, Nothing)
+        ]
+  forM_ (zip [1 ..] cases) $ \(i, (r, card, paid, _)) -> closedWith st r card paid (at i)
+  creditLate st (lateCredit "part" 1 (Just 100000) 1500) `shouldReturn` True
+  creditLate st (lateCredit "credited" 1 Nothing 5000) `shouldReturn` True
+  withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_invoices SET status = ? WHERE invoice_id = ?" ("paid" :: Text, "inv-settledlate" :: Text)
+  placeOrderRow st "live" False 20000 (at 60)
+  payment st "inv-live" (cryptoPaid 300000 300000) (at 20)
+  let pendingOf :: Text -> IO (Text, Maybe LatePending)
+      pendingOf r = withTransaction st $ \db -> (r,) <$> latePending db (InvoiceId $ "inv-" <> r)
+  forM_ cases $ \(r, _, _, expected) -> pendingOf r `shouldReturn` (r, expected)
+  pendingOf "live" `shouldReturn` ("live", Nothing)
+  withTransaction st uncreditedLateInvoices `shouldReturn` map (InvoiceId . ("inv-" <>)) ["uncredited", "card", "settledlate"]
+  withTransaction st (\db -> lateCreditState db (InvoiceId "inv-part"))
+    `shouldReturn` Just
+      LateCreditState
+        { lsInvoice = InvoiceId "inv-part",
+          lsRegistration = RegistrationId "part",
+          lsPhase = PUnpaid,
+          lsLive = False,
+          lsCard = False,
+          lsReceivedCents = 20000,
+          lsConfirmedCents = 0,
+          lsReceivedUnits = Just 300000,
+          lsConfirmedUnits = Just 100000,
+          lsInvoiceRate = Just "62500",
+          lsCreditedUnits = 100000,
+          lsCreditedCents = 1500,
+          lsCredits = 1,
+          lsPaymentCreatedAt = at 4
+        }
+  withTransaction st (\db -> lateCreditState db (InvoiceId "inv-plain")) `shouldReturn` Nothing
+
+testExactUnits :: IO ()
+testExactUnits = withServiceStore $ \st -> do
+  closedWith st "x" False (cryptoPaid 30000000 30000000) t0
+  creditLate st (lateCredit "x" 1 (Just 10000000) 6000) `shouldReturn` True
+  creditLate st (lateCredit "x" 2 (Just 20000000) 12000) `shouldReturn` True
+  withTransaction st (\db -> latePending db (InvoiceId "inv-x")) `shouldReturn` Nothing
+  withTransaction st uncreditedLateInvoices `shouldReturn` []
+  fmap lsCreditedUnits <$> withTransaction st (\db -> lateCreditState db (InvoiceId "inv-x")) `shouldReturn` Just 30000000
+
+testLateAlerts :: IO ()
+testLateAlerts = withServiceStore $ \st -> do
+  closedWith st "old" False (cryptoPaid 300000 0) t0
+  closedWith st "card" True (cardPaid 5000 0) (at 1)
+  closedWith st "done" True (cardPaid 5000 5000) (at 2)
+  creditLate st (lateCredit "done" 1 Nothing 5000) `shouldReturn` True
+  closedWith st "new" False (cryptoPaid 300000 0) (at 120)
+  let due :: IO [LateAlert]
+      due = withTransaction st $ \db -> lateAlertDue db (at 60)
+      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
+  [old, card] <- due
+  map marks [old, card]
+    `shouldBe` [(InvoiceId "inv-old", LPUnconfirmed, Just 300000, Nothing, Nothing), (InvoiceId "inv-card", LPUnconfirmed, Just 5000, Nothing, Nothing)]
+  claim old (at 61) `shouldReturn` True
+  claim old (at 61) `shouldReturn` False
+  claim card (at 61) `shouldReturn` True
+  due `shouldReturn` []
+  withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_payments SET received_units = ? WHERE invoice_id = ?" (400000 :: Int64, "inv-old" :: Text)
+  [more] <- due
+  marks more `shouldBe` (InvoiceId "inv-old", LPUnconfirmed, Just 400000, Just (at 61), Just 300000)
+  claim more (at 62) `shouldReturn` True
+  claim more (at 63) `shouldReturn` False
+  due `shouldReturn` []
+  map marks <$> withTransaction st (\db -> lateAlertDue db (at 180)) `shouldReturn` [(InvoiceId "inv-new", LPUnconfirmed, Just 300000, Nothing, Nothing)]
+
+-- turns
+
+testBalanceTurn :: IO ()
+testBalanceTurn = withServiceStore $ \st -> do
+  turns <- newTurns
+  source st "s" 10000
+  inside <- newEmptyMVar
+  proceed <- newEmptyMVar
+  let src = RegistrationId "s"
+  firstHolder <- async $ withBalanceTurn turns src $ do
+    putMVar inside ()
+    takeMVar proceed
+    holder st "h1" "s" 10000 (at 60)
+  takeMVar inside
+  secondHolder <- async $ withBalanceTurn turns src $ holder st "h2" "s" 10000 (at 60)
+  timeout 5000000 (atomically $ balanceTurnCount turns src >>= check . (== 2)) `shouldReturn` Just ()
+  putMVar proceed ()
+  wait firstHolder `shouldReturn` Right ()
+  wait secondHolder `shouldReturn` Left RRBalanceChanged
+  timeout 5000000 (withLabelTurn turns (labelHash "alicebakery") $ withBalanceTurn turns src $ pure ()) `shouldReturn` Just ()
+  turnsCount turns `shouldReturn` 0
+
+#if defined(dbPostgres)
+-- | Both transactions begun before either writes, so the second writer waits for the first's row lock and re-reads its condition.
+together :: DBStore -> DBStore -> (DB.Connection -> IO a) -> (DB.Connection -> IO b) -> IO (a, b)
+together st1 st2 w1 w2 = do
+  begun <- newTVarIO (0 :: Int)
+  let run :: DBStore -> (DB.Connection -> IO c) -> IO c
+      run st w = withTransaction st $ \db -> do
+        atomically $ modifyTVar' begun (+ 1)
+        atomically $ readTVar begun >>= check . (== 2)
+        w db
+  concurrently (run st1 w1) (run st2 w2)
+
+testConcurrentWrites :: IO ()
+testConcurrentWrites = withServiceStores $ \open -> do
+  st <- open
+  other <- open
+  forM_ [1 .. 25 :: Int] $ \n -> do
+    let tag = T.pack (show n)
+        spendSrc = "spend" <> tag
+        heldSrc = "held" <> tag
+        lateSrc = "late" <> tag
+    source st spendSrc 10000
+    (spent, refundedSpend) <-
+      together st other (\db -> createBalanceRegistration db (newReg ("c" <> tag) ownerA (fieldsN $ "c" <> tag)) (RegistrationId spendSrc) 6000 10000 t0) (\db -> refundBalance db (RegistrationId spendSrc) 10000 t0)
+    (n, isRight spent, refundedSpend) `shouldSatisfy` (\(_, a, b) -> a /= b)
+    fmap (\(amount, _, _, _) -> amount) <$> figures st spendSrc t0 `shouldReturn` Just (if refundedSpend then 0 else 4000)
+    invariantHolds st spendSrc
+    source st heldSrc 10000
+    holder st ("h" <> tag) heldSrc 10000 (at 60) `shouldReturn` Right ()
+    h <- reg st ("h" <> tag)
+    (n,) <$> together st other (`settleHolder` h) (\db -> refundBalance db (RegistrationId heldSrc) 10000 t0) `shouldReturn` (n, (True, False))
+    figures st heldSrc t0 `shouldReturn` Just (0, 10000, 0, Nothing)
+    invariantHolds st heldSrc
+    source st lateSrc 10000
+    (credited, refundedLate) <- together st other (\db -> creditLatePayment db (lateCredit lateSrc 1 (Just 50000) 3000) t0) (\db -> refundBalance db (RegistrationId lateSrc) 10000 t0)
+    credited `shouldBe` True
+    (n,) <$> figures st lateSrc t0 `shouldReturn` (n, Just $ if refundedLate then (3000, 13000, 10000, Nothing) else (13000, 13000, 0, Nothing))
+    invariantHolds st lateSrc
+#endif

tests/Bots/StoreService/NamesOrdersTests.hs

@@ -35,7 +35,7 @@ where
 import Bots.StoreService.FakeBTCPay (FakeBTCPay (..), setInvoiceState, withFakeBTCPay)
 import Bots.StoreService.FakeEthNode
 import Bots.StoreService.NamesContractsTests (alice, answerRegistered, answerRegistrar, nameExpiresCall, noncesCall, registrarOf, rentPriceAnswer, rentPriceCall, reservedNamesCall, unhex)
-import Bots.StoreService.NamesStoreTests (order, ownerA, ownerB, placeCode, placePaid, t0)
+import Bots.StoreService.NamesStoreTests (btc, insertInvoiceRow, newReg, order, ownerA, ownerB, paidOrder, placeCode, placePaid, t0)
 import Bots.StoreService.WebTests
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (async, concurrently, wait)
@@ -88,7 +88,7 @@ import StoreService.Names.Phases (RegistrationId (..), awaitChange, newPhases)
 import StoreService.Names.Signatures (OrderFields (..), orderMessage, personalDigest)
 import StoreService.Names.Store
 import StoreService.Names.Turns (newTurns, withCodeTurn)
-import StoreService.Names.View (ViewReads (..), readViewChain, viewJSON)
+import StoreService.Names.View (ViewReads (..), readViewChain, registrationView, viewJSON)
 import StoreService.Orders (cancelOpenInvoice, expireOverdue, settleOrder)
 import StoreService.Poller (cleanupInterval, cleanupReadsPerPass, cleanupUnpaid, drainHints, newPollerEnv, newReadHints, queueReadHint, runOnePass, unpaidRetention)
 import StoreService.Providers.BTCPay (btcpayProvider)
@@ -170,6 +170,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do
     it "has the contract's fields" testViewFields
     it "reads the intent nonce in committed and nothing in taken" testViewReads
     it "leaves a failed intentNonce read null and named in unread, reading nothing in taken" testViewUnread
+    it "reads the order's balance, held until its holder's invoice expires and free past it, and the cents its order took from another's" testViewBalance
 
 -- fixtures
 
@@ -937,7 +938,7 @@ testCodeNotReservable = withOrders $ \ctx@Ctx {cStore} -> do
   req <- fromJust . Orders.parseOrderRequest <$> signedBody (cRandom ctx) aliceOrder
   let new = NewRegistration {nrgId = RegistrationId "late", nrgOwner = ownerA, nrgOrder = fieldsOf aliceOrder, nrgYears = 2}
   forM_ [(reservedLate, CRReserved), (revokedLate, CRInvalid)] $ \(stale, refusal) -> do
-    placedOrder <- Orders.placeOrder (cOrders ctx) req (Orders.codeOrderInsert new stale)
+    placedOrder <- Orders.placeOrder (cOrders ctx) req [] (Orders.codeOrderInsert new stale)
     either Just (const Nothing) placedOrder `shouldBe` Just (Orders.ORCode refusal)
   length <$> registrationsOf ctx ownerA `shouldReturn` 0
 
@@ -1344,13 +1345,13 @@ 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 ViewReads {vrIntentNonce = Nothing, vrUnread = []}
+  let v = objectOf $ viewJSON (testNamesConfig node) r 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", "commitTx", "registerTx", "revealAfter", "revealBefore", "intentNonce", "unread", "expiresAt", "error"
+        "years", "duration", "price", "fromBalance", "balance", "commitTx", "registerTx", "revealAfter", "revealBefore", "intentNonce", "unread", "expiresAt", "error"
       ]
-  map (`field` v) ["id", "phase", "owner", "tld", "chainId", "linksRefused", "label", "unread", "sponsor"]
+  map (`field` v) ["id", "phase", "owner", "tld", "chainId", "linksRefused", "label", "unread", "sponsor", "fromBalance", "balance"]
     `shouldBe` map
       Just
       [ "r1",
@@ -1361,7 +1362,9 @@ testViewFields = withServiceStore $ \st -> withFakeEthNode $ \node -> do
         J.Bool False,
         J.Null,
         J.Array mempty,
-        J.String $ safeDecodeUtf8 $ strEncode fakeSponsor
+        J.String $ safeDecodeUtf8 $ strEncode fakeSponsor,
+        J.Number 0,
+        J.Null
       ]
 
 testViewReads :: IO ()
@@ -1388,5 +1391,35 @@ 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} (ViewReads Nothing ["intentNonce"])
+  let v = objectOf $ viewJSON (testNamesConfig node) r {nrPhase = PCommitted} Nothing (ViewReads Nothing ["intentNonce"])
   (field "intentNonce" v, field "unread" v) `shouldBe` (Just J.Null, Just (J.toJSON ["intentNonce" :: Text]))
+
+testViewBalance :: IO ()
+testViewBalance = withServiceStore $ \st -> withFakeEthNode $ \node -> do
+  g <- C.newRandom
+  ct <- newContracts TLDSimplex =<< newChainClient g (fakeChainConfig node)
+  let holderExpiry = addUTCTime 3600 t0
+      viewOf :: Text -> UTCTime -> IO J.Object
+      viewOf rid now = do
+        r <- withTransaction st $ \db -> fromJust <$> getRegistration db (RegistrationId rid)
+        objectOf <$> registrationView st (testNamesConfig node) ct now r
+      balanceOf :: J.Object -> (Maybe J.Value, Maybe J.Value)
+      balanceOf v = (field "balance" v, field "fromBalance" v)
+      balance :: Int -> Bool -> Maybe UTCTime -> Int -> J.Value
+      balance amount held heldUntil refunded = J.object ["amount" .= amount, "held" .= held, "heldUntil" .= heldUntil, "refunded" .= refunded]
+  Right () <- placePaid st "source" ownerA (order "alicebakery" 1) holderExpiry
+  withTransaction st $ \db -> creditBalance db (RegistrationId "source") 15000 t0
+  balanceOf <$> viewOf "source" t0 `shouldReturn` (Just $ balance 15000 False Nothing 0, Just $ J.Number 0)
+  Right () <- withTransaction st $ \db -> do
+    insertInvoiceRow db "inv-holder" holderExpiry "open"
+    let terms = OTBalance (RegistrationId "source") 20000 15000 (Just btc)
+    createPaidRegistration db (newReg "holder" ownerA (order "bobsbakery" 2)) terms (paidOrder "inv-holder") (Just $ HeldBalance (RegistrationId "source") 15000) t0
+  balanceOf <$> viewOf "source" t0 `shouldReturn` (Just $ balance 15000 True (Just holderExpiry) 0, Just $ J.Number 0)
+  balanceOf <$> viewOf "source" (addUTCTime 1 holderExpiry) `shouldReturn` (Just $ balance 15000 False Nothing 0, Just $ J.Number 0)
+  balanceOf <$> viewOf "holder" t0 `shouldReturn` (Just J.Null, Just $ J.Number 15000)
+  version <- nrVersion <$> withTransaction st (\db -> fromJust <$> getRegistration db (RegistrationId "source"))
+  withTransaction st (\db -> releaseHeldBalance db (RegistrationId "holder") t0) `shouldReturn` True
+  withTransaction st (\db -> refundBalance db (RegistrationId "source") 15000 t0) `shouldReturn` True
+  v <- viewOf "source" t0
+  balanceOf v `shouldBe` (Just $ balance 0 False Nothing 15000, Just $ J.Number 0)
+  field "version" v `shouldBe` Just (J.toJSON version)

tests/Bots/StoreService/NamesStoreTests.hs

@@ -3,11 +3,12 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Bots.StoreService.NamesStoreTests (namesStoreTests, issue, order, ownerA, ownerB, placeCode, placePaid, reveal, t0, usable) where
+module Bots.StoreService.NamesStoreTests (namesStoreTests, at, btc, insertInvoiceRow, invoiceStatus, issue, newReg, order, ownerA, ownerB, paidOrder, placeCode, placePaid, price, reg, reveal, signature, t0, usable, write) where
 
 import Bots.StoreService.WebTests (columnsOf, digestFixture, runMigrations, withServiceStore)
 import Control.Arrow ((&&&))
 import Control.Monad (forM_, void)
+import Data.Int (Int64)
 import Data.List (sort)
 import Data.Maybe (fromJust, mapMaybe)
 import Data.Text (Text)
@@ -21,8 +22,8 @@ import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationsToRun (..), toDownMigration)
 import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature)
-import Simplex.Messaging.Eth.Address (Address)
-import Simplex.Messaging.SimplexName (labelHash)
+import Simplex.Messaging.Eth.Address (Address, unAddress)
+import Simplex.Messaging.SimplexName (LabelHash (..), labelHash)
 import StoreService.Names.Chain (TxHash (..))
 import StoreService.Names.Phases (RegistrationId (..))
 import StoreService.Names.Signatures (OrderFields (..), parseAnyCaseAddress, parseSignature)
@@ -45,6 +46,7 @@ namesStoreTests = describe "StoreService names: store" $ do
     it "creates the names tables with the planned columns" testNamesColumns
     it "rolls back and re-applies only the names migrations, with rows in them, leaving the badge tables and paid invoices as they were" testNamesDownUp
     it "turns a code_issued order taken at price 0 and not live at its next version, dropping issued_code_id with its index and foreign key, which the down migration restores" testDropTakenCodes
+    it "makes taken orders not live and gives a taken paid order a balance of its price, none to a code order or a price of 0, and rolls back the balance tables and columns" testNameBalancesMigration
   describe "order hash" $ do
     it "is equal for the same order fields, and differs when any one field differs" testOrderHashFields
     it "keeps field boundaries, so moving a byte between two fields changes it" testOrderHashBoundaries
@@ -141,7 +143,7 @@ insertInvoiceRow db invId expiresAt status =
 placePaid :: DBStore -> Text -> Address -> OrderFields -> UTCTime -> IO (Either RegistrationRefused ())
 placePaid st rid owner o expiresAt = withTransaction st $ \db -> do
   insertInvoiceRow db ("inv-" <> rid) expiresAt "open"
-  createPaidRegistration db (newReg rid owner o) (paidOrder $ "inv-" <> rid) t0
+  createPaidRegistration db (newReg rid owner o) (OTInvoice btc price) (paidOrder $ "inv-" <> rid) Nothing t0
 
 issue :: DBStore -> Word8 -> NewPrepaidCode -> IO PrepaidCode
 issue st n c = withTransaction st $ \db -> do
@@ -161,7 +163,11 @@ write :: DBStore -> NameRegistration -> IO VersionWrite
 write st r = withTransaction st $ \db -> updateRegistration db r (at 1)
 
 namesTables :: [Text]
-namesTables = map ("sx_badge_service_name_" <>) ["prepaid_codes", "registrations", "invoices", "record_edits", "transactions"]
+namesTables = map ("sx_badge_service_name_" <>) ["prepaid_codes", "registrations", "invoices", "record_edits", "transactions", "balances", "late_credits"]
+
+-- | Added to the badge tables' payments by the names migrations.
+balancePaymentColumns :: [Text]
+balancePaymentColumns = ["confirmed_amount", "received_units", "confirmed_units", "invoice_rate"]
 
 badgeTables :: [Text]
 badgeTables = map ("sx_badge_service_" <>) ["invoices", "payments", "badge_prices", "badge_offers", "badge_purchases", "badge_ledger", "badge_issuances", "badge_codes", "badge_code_invoices", "group"]
@@ -175,9 +181,12 @@ testNamesColumns = withServiceStore $ \st -> do
     [ "registration_id", "label_hash", "length", "label", "secret", "contact_link", "channel_link", "intent_nonce", "intent_deadline", "intent_signature",
       "sealed", "owner", "commitment", "phase", "commit_tx", "commit_block", "register_tx", "register_block", "reveal_after", "reveal_before",
       "years", "duration", "expires_at", "price", "name_prepaid_code_id", "registered_at", "failed_at", "error", "created_at",
-      "updated_at", "version", "live", "order_hash", "method", "moves", "links_refused_at"
+      "updated_at", "version", "live", "order_hash", "method", "moves", "links_refused_at", "balance_source", "balance_used"
     ]
-  has "sx_badge_service_name_invoices" ["invoice_id", "registration_id", "provider_ref"]
+  has "sx_badge_service_name_invoices" ["invoice_id", "registration_id", "provider_ref", "late_alerted_at", "late_alerted_units"]
+  has "sx_badge_service_name_balances" ["registration_id", "amount", "credited", "refunded", "reserved_by", "refunded_at", "created_at", "updated_at"]
+  has "sx_badge_service_name_late_credits" ["invoice_id", "credit_no", "registration_id", "units", "invoice_rate", "current_rate", "rate_used", "cents", "created_at"]
+  has "sx_badge_service_payments" balancePaymentColumns
   has "sx_badge_service_name_record_edits" ["label_hash", "owner", "nonce", "record_key", "record_value", "deadline", "signature", "body_hash", "state", "revert", "mined_tx", "created_at"]
   has "sx_badge_service_name_transactions" ["registration_id", "name_record_edit_id", "kind", "raw", "tx_hash", "registrar_nonce", "sent_at", "mined_block", "status"]
 
@@ -185,7 +194,7 @@ testNamesDownUp :: IO ()
 testNamesDownUp = withServiceStore $ \st -> do
   let names = dropWhile ((/= "20261010_names") . name) storeServiceSchemaMigrations
       badgeColumns = mapM (fmap sort . columnsOf st) badgeTables
-  map name names `shouldBe` ["20261010_names", "20261022_drop_taken_codes"]
+  map name names `shouldBe` ["20261010_names", "20261022_drop_taken_codes", "20261022_name_balances"]
   badgeBefore <- badgeColumns
   code <- issue st 1 usable
   placeCode st "r1" ownerA (order "alicebakery" 1) code `shouldReturn` Right ()
@@ -195,7 +204,7 @@ testNamesDownUp = withServiceStore $ \st -> do
   runMigrations st $ MTRDown (mapMaybe toDownMigration names)
   mapM (columnsOf st) namesTables `shouldReturn` map (const []) namesTables
   mapM (invoiceCount st) ["inv-r2", "inv-r3"] `shouldReturn` [0, 1]
-  badgeColumns `shouldReturn` badgeBefore
+  badgeColumns `shouldReturn` map (filter (`notElem` balancePaymentColumns)) badgeBefore
   runMigrations st $ MTRUp names
   mapM (fmap null . columnsOf st) namesTables `shouldReturn` map (const False) namesTables
   badgeColumns `shouldReturn` badgeBefore
@@ -225,6 +234,53 @@ testDropTakenCodes = withServiceStore $ \st -> do
   worth <$> reg st "r1" `shouldReturn` (PTaken, 0, False, 2)
   withTransaction st (\db -> DB.execute db "UPDATE sx_badge_service_name_registrations SET issued_code_id = ? WHERE registration_id = 'r1'" (Only $ pcId code + 1)) `shouldThrow` foreignKeyViolation
 
+testNameBalancesMigration :: IO ()
+testNameBalancesMigration = withServiceStore $ \st -> do
+  let balances = [m | m@Migration {name = "20261022_name_balances"} <- storeServiceSchemaMigrations]
+      applied :: IO (Bool, Bool, Bool)
+      applied = (,,) <$> (not . null <$> columnsOf st "sx_badge_service_name_balances") <*> (elem "balance_source" <$> columnsOf st "sx_badge_service_name_registrations") <*> (elem "confirmed_units" <$> columnsOf st "sx_badge_service_payments")
+      live :: Text -> IO Bool
+      live rid = withTransaction st $ \db -> DB.query db "SELECT live FROM sx_badge_service_name_registrations WHERE registration_id = ?" (Only rid) >>= \case
+        [Only (DB.BI l)] -> pure l
+        rows -> fail $ "registration " <> show rid <> ": " <> show (length rows) <> " rows"
+      balanceOf :: Text -> IO (Maybe (Int, Int, Int, Maybe BalanceHold))
+      balanceOf rid = withTransaction st $ \db -> fmap (\Balance {blAmount, blCredited, blRefunded, blHold} -> (blAmount, blCredited, blRefunded, blHold)) <$> getBalance db (RegistrationId rid) t0
+  length balances `shouldBe` 1
+  runMigrations st $ MTRDown (mapMaybe toDownMigration balances)
+  applied `shouldReturn` (False, False, False)
+  code <- issue st 1 usable
+  withTransaction st $ \db -> do
+    insertInvoiceRow db "inv-paid" (at 60) "paid"
+    insertOldRegistration db "paid" 1 "taken" price Nothing (Just "inv-paid")
+    insertOldRegistration db "code" 2 "taken" 0 (Just $ pcId code) Nothing
+    insertInvoiceRow db "inv-converted" (at 60) "paid"
+    insertOldRegistration db "converted" 3 "taken" 0 Nothing (Just "inv-converted")
+    insertInvoiceRow db "inv-queued" (at 60) "paid"
+    insertOldRegistration db "queued" 4 "queued" price Nothing (Just "inv-queued")
+  runMigrations st $ MTRUp balances
+  applied `shouldReturn` (True, True, True)
+  mapM live ["paid", "code", "converted", "queued"] `shouldReturn` [False, False, False, True]
+  mapM balanceOf ["paid", "code", "converted", "queued"] `shouldReturn` [Just (price, price, 0, Nothing), Nothing, Nothing, Nothing]
+  runMigrations st $ MTRDown (mapMaybe toDownMigration balances)
+  applied `shouldReturn` (False, False, False)
+  mapM live ["paid", "queued"] `shouldReturn` [False, True]
+  runMigrations st $ MTRUp balances
+  balanceOf "paid" `shouldReturn` Just (price, price, 0, Nothing)
+
+-- | A registration row as the code before the balances wrote it, paid by the invoice or the code given.
+insertOldRegistration :: DB.Connection -> Text -> Word8 -> Text -> Int -> Maybe Int64 -> Maybe Text -> IO ()
+insertOldRegistration db rid n phase cents codeId invId = do
+  let OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} = order ("alicebakery" <> rid) n
+  DB.execute
+    db
+    ( "INSERT INTO sx_badge_service_name_registrations (registration_id, version, label_hash, length, duration, owner, commitment, sealed, phase, years,"
+        <> " price, method, name_prepaid_code_id, live, order_hash, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?, ?,?,?,?,?,?,?)"
+    )
+    ( (rid, 1 :: Int, DB.Binary lh, ofLength, fromIntegral ofDuration :: Int64, DB.Binary $ unAddress ownerA, DB.Binary ofCommitment, ofSealed, phase, twoYears)
+        :. (cents, ("btc" :: Text) <$ invId, codeId, DB.BI True, DB.Binary $ digestFixture n, t0, t0)
+    )
+  mapM_ (\i -> DB.execute db "INSERT INTO sx_badge_service_name_invoices (invoice_id, registration_id, provider_ref, created_at) VALUES (?,?,?,?)" (i, rid, "ref-" <> i, t0)) invId
+
 testOrderHashFields :: IO ()
 testOrderHashFields = do
   let o = order "alicebakery" 1
@@ -270,6 +326,8 @@ testCreatePaid = withServiceStore $ \st -> do
         nrYears = twoYears,
         nrPrice = price,
         nrPayment = RPInvoice btc (InvoiceId "inv-r1"),
+        nrBalanceSource = Nothing,
+        nrBalanceUsed = 0,
         nrReveal = Nothing,
         nrCommitTx = Nothing,
         nrCommitBlock = Nothing,
@@ -359,7 +417,7 @@ testCloseOverdue = withServiceStore $ \st -> do
     [LiveOrder {loRegistration, loOverdue = True}] <- getLiveOrders db (ofCommitment o') ownerA (ofLabelHash o') (at 61)
     void $ closeOverdue db loRegistration (at 61)
     insertInvoiceRow db "inv-r2" (at 120) "open"
-    createPaidRegistration db (newReg "r2" ownerA o') (paidOrder "inv-r2") (at 61)
+    createPaidRegistration db (newReg "r2" ownerA o') (OTInvoice btc price) (paidOrder "inv-r2") Nothing (at 61)
   placed `shouldBe` Right ()
   old <- reg st "r1"
   (nrLive old, nrPhase old, nrVersion old) `shouldBe` (False, PUnpaid, 2)
@@ -552,7 +610,7 @@ testFind = withServiceStore $ \st -> do
     let rid = "r" <> T.pack (show i)
         o = order ("alicebakery" <> T.pack (show i)) (fromIntegral i)
     insertInvoiceRow db ("inv-" <> rid) (at 60) "open"
-    createPaidRegistration db (newReg rid ownerA o) (paidOrder $ "inv-" <> rid) (at i) `shouldReturn` Right ()
+    createPaidRegistration db (newReg rid ownerA o) (OTInvoice btc price) (paidOrder $ "inv-" <> rid) Nothing (at i) `shouldReturn` Right ()
   placePaid st "other" ownerB (order "bobsbakery" 99) (at 60) `shouldReturn` Right ()
   found <- withTransaction st $ \db -> findRegistrations db ownerA
   map nrId found `shouldBe` [RegistrationId $ "r" <> T.pack (show i) | i <- [52, 51 .. 3 :: Int]]
@@ -611,7 +669,7 @@ testUnpaidCleanup = withServiceStore $ \st -> do
   void $ write st r {nrPhase = PQueued}
   candidates <- withTransaction st $ \db -> unpaidCleanupCandidates db (at 61)
   map (\(RegistrationId rid, InvoiceId invId) -> (rid, invId)) candidates `shouldBe` [("old", "inv-old")]
-  withTransaction st (\db -> mapM (deleteUnpaidRegistration db . RegistrationId) ["old", "funded", "queued"]) `shouldReturn` [True, False, False]
+  withTransaction st (\db -> mapM (deleteUnpaidRegistration db . RegistrationId) ["old", "funded", "queued"]) `shouldReturn` [Right (), Left CKPaid, Left CKPaid]
   withTransaction st (\db -> getRegistration db (RegistrationId "old")) `shouldReturn` Nothing
   invoiceCount st "inv-old" `shouldReturn` 0
   invoiceCount st "inv-funded" `shouldReturn` 1

tests/Bots/StoreService/WebTests.hs

@@ -8,6 +8,7 @@
 module Bots.StoreService.WebTests
   ( badgeWebTests,
     withServiceStore,
+    withServiceStores,
     columnsOf,
     runMigrations,
     digestFixture,
@@ -67,7 +68,7 @@ import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Char (toLower)
 import Data.Either (isLeft)
-import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)
 import Data.Int (Int64)
 import Data.List (isInfixOf, sort, sortOn)
 import qualified Data.Map.Strict as Map
@@ -122,32 +123,37 @@ import Simplex.Messaging.Agent.Store.DB (TrackQueries (..))
 import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
 #endif
 
-#if defined(dbPostgres)
 withServiceStore :: (DBStore -> IO a) -> IO a
-withServiceStore action = do
+withServiceStore action = withServiceStores (>>= action)
+
+-- | Each store the action opens is a new one over the same test database, as a restarted service opens; all are closed at the end.
+withServiceStores :: (IO DBStore -> IO a) -> IO a
+withServiceStores action = withServiceDBOpts $ \opts -> do
+  opened <- newIORef []
+  let open = do
+        Right st <- createDBStore opts storeServiceSchemaMigrations (MigrationConfig MCError Nothing)
+        st <$ modifyIORef' opened (st :)
+  action open `E.finally` (readIORef opened >>= mapM_ closeDBStore)
+
+withServiceDBOpts :: (DBOpts -> IO a) -> IO a
+#if defined(dbPostgres)
+withServiceDBOpts action = do
   n <- atomicModifyIORef' serviceSchemaCounter (\i -> (i + 1, i))
-  Right st <- createDBStore (serviceDBOpts n) storeServiceSchemaMigrations (MigrationConfig MCError Nothing)
-  action st `E.finally` closeDBStore st
-  where
-    serviceDBOpts :: Int -> DBOpts
-    serviceDBOpts n =
-      DBOpts
-        { connstr = BC.pack testDBConnstr,
-          schema = "sx_badge_service_web_test_" <> BC.pack (show n),
-          poolSize = 4,
-          createSchema = True
-        }
+  action
+    DBOpts
+      { connstr = BC.pack testDBConnstr,
+        schema = "sx_badge_service_web_test_" <> BC.pack (show n),
+        poolSize = 4,
+        createSchema = True
+      }
 
 serviceSchemaCounter :: IORef Int
 serviceSchemaCounter = unsafePerformIO $ newIORef 0
 {-# NOINLINE serviceSchemaCounter #-}
 #else
-withServiceStore :: (DBStore -> IO a) -> IO a
-withServiceStore action = do
+withServiceDBOpts action = do
   createDirectoryIfMissing True "tests/tmp"
-  withTempDirectory "tests/tmp" "badge-web" $ \dir -> do
-    Right st <- createDBStore (DBOpts (dir </> "badge_service_test.db") [] "" False True TQOff) storeServiceSchemaMigrations (MigrationConfig MCError Nothing)
-    action st `E.finally` closeDBStore st
+  withTempDirectory "tests/tmp" "badge-web" $ \dir -> action (DBOpts (dir </> "badge_service_test.db") [] "" False True TQOff)
 #endif
 
 columnsOf :: DBStore -> Text -> IO [Text]

tests/Test.hs

@@ -10,6 +10,7 @@ import Bots.StoreService.ConfigTests
 import Bots.StoreService.GroupIntegrationTests
 import Bots.StoreService.GroupTests
 import Bots.StoreService.NameRegistrationTests
+import Bots.StoreService.NamesBalancesTests
 import Bots.StoreService.NamesChainTests
 import Bots.StoreService.NamesCodesTests
 import Bots.StoreService.NamesContractsTests
@@ -104,6 +105,7 @@ main = do
         badgeStripeTests
         badgeNameRegistrationTests
       namesConfigTests
+      namesBalancesTests
       namesChainTests
       namesCodesTests
       namesContractsTests