store: merge name order follow-ups

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

@@ -51,7 +51,7 @@ import StoreService.Names.Env (NamesEnv (..))
 import StoreService.Names.Phases (Phases)
 import StoreService.Names.Abi (bytes32FromHex)
 import StoreService.Names.Signatures (OrderFields (..), orderMessage, parseChecksumAddress, parseSignature, personalDigest)
-import StoreService.Names.Store (LiveOrder (..), NameRegistration (..), RegistrationRefused (..), VersionWrite (..), closeOverdue, getLiveOrders, getRegistrationByOrderHash, isLabelRegistering)
+import StoreService.Names.Store (LiveOrder (..), NameRegistration (..), RegistrationRefused (..), closeOverdue, getLiveOrders, getRegistrationByOrderHash, isLabelRegistering)
 import StoreService.Names.Turns (Turns)
 
 data OrdersEnv = OrdersEnv
@@ -167,8 +167,8 @@ placeOrder OrdersEnv {oeStore, oeNow} req insert = do
         Nothing -> E.throwIO $ OrderRefused OROrderExists
     close db now r =
       closeOverdue db r now >>= \case
-        Written v -> pure ClosedOrder {coRegistration = r, coVersion = v}
-        _ -> E.throwIO $ OrderRefused OROrderExists
+        Just v -> pure ClosedOrder {coRegistration = r, coVersion = v}
+        Nothing -> E.throwIO $ OrderRefused OROrderExists
 
 checkTimestamp :: UTCTime -> Word64 -> Either OrderRefusal ()
 checkTimestamp now timestamp =

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

@@ -77,6 +77,7 @@ 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.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
@@ -99,7 +100,7 @@ import StoreService.Names.Chain (TxHash (..))
 import StoreService.Names.Phases (RegistrationId (..))
 import StoreService.Names.Signatures (OrderFields (..), parseSignature)
 import StoreService.Store (RevokeResult (..))
-import StoreService.Store.Invoices (StoreDecodeError (..), executeChanging, invoiceStatusText, newInvoiceId, truncateToSecond)
+import StoreService.Store.Invoices (StoreDecodeError (..), executeChanging, invoiceStatusText, lockInvoice, newInvoiceId, truncateToSecond, unfundedQuery)
 
 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
@@ -208,8 +209,7 @@ data RegistrationRefused = RRLiveOrder | RRCodeNotReservable
   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.
--- NotOverdue: closeOverdue found the order's invoice no longer open, or holding money.
-data VersionWrite = Written Int64 | VersionChanged | NotLive | LiveOrderExists | NotOverdue
+data VersionWrite = Written Int64 | VersionChanged | NotLive | LiveOrderExists
   deriving (Eq, Show)
 
 -- | A live order an order request meets; overdue when its open invoice is past its expiry time.
@@ -500,22 +500,19 @@ getLiveOrders db commitment owner (LabelHash lh) now =
   where
     toLiveOrder (row :. Only (BI loOverdue)) = (\loRegistration -> LiveOrder {loRegistration, loOverdue}) <$> toRegistration row
 
--- | A payment holding money, as the sweep's own check reads one, makes the invoice i funded.
+-- | The sweep's own check, on the invoice joined as i.
 unfunded :: Query
-unfunded =
-  " "
-    <> [sql|
-    AND NOT EXISTS (
-      SELECT 1 FROM sx_badge_service_payments p
-      WHERE p.invoice_id = i.invoice_id AND (COALESCE(p.amount, 0) > 0 OR p.crypto_paid IS NOT NULL OR p.paid_in_full = 1)
-    )
-  |]
+unfunded = unfundedQuery "i.invoice_id"
 
--- | Run in the transaction that inserts the next order, so the unique constraints let it in. The invoice is written before
--- the registration, as settlement, cancel and the sweep write them; a registration write that loses after it leaves the
--- caller to roll back.
-closeOverdue :: DB.Connection -> NameRegistration -> UTCTime -> IO VersionWrite
-closeOverdue db r@NameRegistration {nrId = RegistrationId rid, nrVersion} now = do
+-- | 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.
+closeOverdue :: DB.Connection -> NameRegistration -> UTCTime -> IO (Maybe Int64)
+closeOverdue db r@NameRegistration {nrId = 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
   expired <-
     executeChanging
       db
@@ -532,11 +529,11 @@ closeOverdue db r@NameRegistration {nrId = RegistrationId rid, nrVersion} now =
       )
       (invoiceStatusText ISExpired, truncateToSecond now, invoiceStatusText ISOpen, rid, nrVersion)
   if expired > 0
-    then updateRegistration db r {nrLive = False} now
-    else
-      DB.query db "SELECT version FROM sx_badge_service_name_registrations WHERE registration_id = ?" (Only rid) >>= \case
-        [Only version] | version == nrVersion -> pure NotOverdue
-        _ -> pure VersionChanged
+    then
+      updateRegistration db r {nrLive = False} now <&> \case
+        Written v -> Just v
+        _ -> 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,
 -- and one per owner and label hash, so a wallet can order a name again once its registration is done.

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

@@ -18,7 +18,7 @@ import StoreService.Names.Phases (Phases, RegistrationId (..))
 import qualified StoreService.Names.Phases as Phases
 import StoreService.Names.Store (NamePhase (..), NameRegistration (..), VersionWrite (..), getRegistration, updateRegistration)
 import StoreService.Providers (Funded (..), PaymentSignal (..), Received (..))
-import StoreService.Store.Invoices (InvoicePayment (..), InvoiceProduct (..), InvoiceRow (..), expireOverdueInvoice, markCodePaid, paymentStatusText, settlementCodeHash, settlementInvoice, truncateToSecond, updateInvoiceStatus, upsertPayment)
+import StoreService.Store.Invoices (InvoicePayment (..), InvoiceProduct (..), InvoiceRow (..), expireOverdueInvoice, lockInvoice, markCodePaid, paymentHolds, paymentStatusText, settlementCodeHash, settlementInvoice, truncateToSecond, updateInvoiceStatus, upsertPayment)
 import StoreService.Waiters (Waiters, publish, publishPayment)
 import Control.Concurrent.STM (STM, atomically)
 import Control.Exception (Exception)
@@ -91,11 +91,13 @@ settleOrder :: DBStore -> Waiters -> Maybe Phases -> InvoiceId -> PaymentSignal
 settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do
   outcome <- withTransaction st $ \db ->
     settlementInvoice db invId >>= \case
-      Nothing -> pure (Left "no such invoice")
-      Just row@InvoiceRow {irStatus} -> case decide irStatus signal of
-        Nothing -> pure (Right (irStatus, PubNothing, []))
-        -- read the product first, so an invoice without one leaves the transaction empty, not paid with nothing to show for it
-        Just w -> productOf db row w >>= either (pure . Left) (settle db row w)
+      Just InvoiceRow {irStatus}
+        | isJust (decide irStatus signal) -> do
+            -- On Postgres, a concurrent overdue close holding the row is waited for, and the read below sees its writes;
+            -- a close that comes later waits for this payment and then sees it.
+            lockInvoice db invId now
+            settlementInvoice db invId >>= settleRow db
+      row_ -> settleRow db row_
   case outcome of
     Left e -> pure (Left e)
     Right (status, toPublish, name) -> do
@@ -115,6 +117,12 @@ settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do
   where
     now = truncateToSecond now'
     at = truncateToSecond (settledInstant signal now)
+    settleRow db = \case
+      Nothing -> pure (Left "no such invoice")
+      Just row@InvoiceRow {irStatus} -> case decide irStatus signal of
+        Nothing -> pure (Right (irStatus, PubNothing, []))
+        -- read the product first, so an invoice without one is not marked paid with nothing to show for it
+        Just w -> productOf db row w >>= either (pure . Left) (settle db row w)
     productOf :: DB.Connection -> InvoiceRow -> Write -> IO (Either Text Product)
     productOf db InvoiceRow {irProduct} Write {wCode} = case irProduct of
       IPBadge {}
@@ -148,7 +156,7 @@ settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do
         then do
           name <- case sold of
             PBadge codeHash -> [] <$ mapM_ (\h -> markCodePaid db h (addUTCTime codeLifetime at)) codeHash
-            PName r -> nameSettled db irStatus wStatus wrotePayment r now
+            PName r -> nameSettled db irStatus wStatus wrotePayment (wrotePayment || maybe False paymentHolds (irPayment row)) r now
           pure (Right (fromMaybe irStatus wStatus, maybe (if wrotePayment then PubPayment else PubNothing) PubStatus wStatus, name))
         else do
           -- another writer moved the row first, so publish what we found
@@ -156,10 +164,11 @@ settleOrder st waiters phases invId@(InvoiceId invText) signal now' = do
           pure (Right (current, PubStatus current, []))
 
 -- | A paid open invoice queues its order only while the order is live; a payment of a closed one is late.
--- An invoice the provider closed closes its order. BTCPay reports money paid into a closed invoice as Expired or Invalid,
--- not Settled, so a new payment figure on a closed invoice is late too; the monotonic payment write reports each figure once.
-nameSettled :: DB.Connection -> InvoiceStatus -> Maybe InvoiceStatus -> Bool -> NameRegistration -> UTCTime -> IO [NameOutcome]
-nameSettled db before after wrotePayment r@NameRegistration {nrId, nrPhase} now
+-- An invoice the provider closed closes its order, and is late once if it holds money, read now or before.
+-- BTCPay reports money paid into a closed invoice as Expired or Invalid, not Settled, so a new payment figure
+-- on a closed invoice is late too; the monotonic payment write reports each figure once.
+nameSettled :: DB.Connection -> InvoiceStatus -> Maybe InvoiceStatus -> Bool -> Bool -> NameRegistration -> UTCTime -> IO [NameOutcome]
+nameSettled db before after wrotePayment holdsMoney r@NameRegistration {nrId, nrPhase} now
   | nrPhase /= PUnpaid = pure []
   | otherwise = case after of
       Just ISPaid
@@ -168,13 +177,11 @@ nameSettled db before after wrotePayment r@NameRegistration {nrId, nrPhase} now
             updateRegistration db r {nrPhase = PQueued} now >>= \case
               Written v -> pure [NOWritten nrId v]
               NotLive -> pure [NOLate nrId]
-              -- another live order holds the name, so this payment can only be refunded; it is still recorded
+              -- not expected while this order is live; kept so the payment is still recorded
               LiveOrderExists -> pure [NOLate nrId]
               _ -> E.throwIO (RegistrationChanged nrId)
-      Just ISExpired -> (<> late) . maybe [] (\(rid, v) -> [NOWritten rid v]) <$> closeOrder db r now
-      _ -> pure $ if before /= ISOpen then late else []
-  where
-    late = [NOLate nrId | wrotePayment]
+      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.
 closeOrder :: DB.Connection -> NameRegistration -> UTCTime -> IO (Maybe (RegistrationId, Int64))

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

@@ -36,15 +36,15 @@ import StoreService.Names.Phases (Phases, RegistrationId (..))
 import StoreService.Names.Store (deleteUnpaidRegistration, unpaidCleanupCandidates)
 import StoreService.Orders (decide, expireOverdue, settleOrder)
 import StoreService.Providers (ListPass (..), PaymentSignal (..), Provider (..), ProviderError (..), Received (..), expiresItself, settleWindow)
-import StoreService.Store.Invoices (InvoiceRow (..), OverdueInvoice (..), getInvoice, getInvoiceByProviderRef, overdueInvoices, providerText, unpaidRefs)
+import StoreService.Store.Invoices (InvoiceProduct (..), InvoiceRow (..), OverdueInvoice (..), getInvoice, getInvoiceByProviderRef, overdueInvoices, providerText, unpaidRefs)
 import StoreService.Waiters (Waiters, waitingCount, waitingCountSTM)
 import Control.Concurrent.STM
 import StoreService.Log (logError, logInfo, logWarn, safely, safelyWith)
-import Control.Monad (filterM, forever, unless, void, when)
+import Control.Monad (filterM, forM_, forever, unless, void, when)
 import Data.List (find, partition, sortOn)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
-import Data.Maybe (fromMaybe, isJust)
+import Data.Maybe (catMaybes, fromMaybe, isJust)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Text (Text)
@@ -132,26 +132,26 @@ newPollerEnv peStore peWaiters pePhases peHints peProviders pePoll = do
   peCleanupLeft <- newTVarIO []
   pure PollerEnv {peStore, peWaiters, pePhases, peHints, peProviders, pePoll, peSkipped, peListedAt, peStrayEvery = strayListInterval, peCancelFailed, peCleanedAt, peCleanupLeft}
 
--- | Read providers before the sweep, and skip the sweep entirely when a read failed, so an
--- invoice with money in it is never expired.
+-- | Read providers before the sweep, and leave out of the sweep every invoice whose read or settlement failed,
+-- so an invoice with money in it is never expired. A list that cannot account for every invoice skips the sweep.
 runOnePass :: PollerEnv -> IO ()
 runOnePass env@PollerEnv {peStore, peProviders} = do
   now <- getCurrentTime
   rows <- unpaidRefs peStore (addUTCTime (negate settleWindow) now)
   let bulk = length rows > readsPerPass
   listNow <- listDue env now bulk
-  accounted <-
+  missed <-
     if bulk
       then do
-        covered <- and <$> mapM (rowIsCovered env now) rows
-        (covered &&) . and <$> mapM (listPass env now) peProviders
+        uncovered <- S.fromList . map snd <$> filterM (fmap not . rowIsCovered env now) rows
+        fmap (S.unions . (uncovered :)) . sequence <$> mapM (listPass env now) peProviders
       else do
-        read' <- readRows env now rows
+        missed <- readRows env now rows
         when listNow $ mapM_ (listPass env now) peProviders
-        pure read'
+        pure (Just missed)
   pruneSkipLog env now
   -- the cleanup runs whatever the sweep met
-  when (accounted && not (null peProviders)) $ void $ safely "badge poller: the sweep" (sweepExpired env now)
+  unless (null peProviders) $ forM_ missed $ \refs -> safely "badge poller: the sweep" (sweepExpired env now refs)
   cleanupUnpaid env now
 
 -- | The cases the stray list catches are rare and not urgent, so minutes, not the pass cadence.
@@ -181,9 +181,10 @@ coveringProvider env@PollerEnv {peProviders} now (provider, ref) =
 rowIsCovered :: PollerEnv -> UTCTime -> (Text, Text) -> IO Bool
 rowIsCovered env now row = isJust <$> coveringProvider env now row
 
-readRows :: PollerEnv -> UTCTime -> [(Text, Text)] -> IO Bool
+-- | The refs whose read or settlement failed.
+readRows :: PollerEnv -> UTCTime -> [(Text, Text)] -> IO (Set Text)
 readRows env now rows =
-  and <$> mapM (\r -> safelyWith (readWhat r) False (readRow r)) rows
+  S.fromList . map snd <$> filterM (\r -> not <$> safelyWith (readWhat r) False (readRow r)) rows
   where
     readWhat (provider, ref) = "badge poller: reading " <> provider <> " invoice " <> ref
     readRow row@(_, ref) = coveringProvider env now row >>= maybe (pure False) (`readOne` ref)
@@ -196,20 +197,24 @@ readRows env now rows =
         Right Nothing -> pure True
         Right (Just signal) -> True <$ settleMoved env (pProvider p) now (ref, signal)
 
--- | False when the pass cannot account for every invoice sold, so the sweep does not expire one
--- over money it missed.
-listPass :: PollerEnv -> UTCTime -> Provider -> IO Bool
+-- | The refs of ours the list did not account for, so the sweep does not expire one over money it missed;
+-- Nothing when it cannot name them all.
+listPass :: PollerEnv -> UTCTime -> Provider -> IO (Maybe (Set Text))
 listPass env now p =
   pListOpen p >>= \case
     Left (ProviderError e) -> do
       due <- dueToWarn env now ("list failed: " <> tshow (pProvider p))
       when due $ logWarn ("badge poller: " <> tshow (pProvider p) <> " list failed; every invoice waits for the next pass: " <> e)
-      pure False
+      pure Nothing
     Right ListPass {lpMoved, lpSkipped} -> do
       owners <- mapM (\s -> safelyWith (skipWhat s) SkipUnaccounted (reportSkip env (pProvider p) now s)) lpSkipped
       reportStrangers env (pProvider p) now [reason | (SkipStranger, (_, reason)) <- zip owners lpSkipped]
-      settled <- mapM (\m -> safely (settleWhat m) (settleMoved env (pProvider p) now m)) lpMoved
-      pure (all (== SkipStranger) owners && and settled)
+      unsettled <- filterM (\m -> not <$> safely (settleWhat m) (settleMoved env (pProvider p) now m)) lpMoved
+      let skippedOurs = [ref | (SkipOurs, (ref, _)) <- zip owners lpSkipped]
+      pure $
+        if SkipUnaccounted `elem` owners
+          then Nothing
+          else Just $ S.fromList $ map fst unsettled <> catMaybes skippedOurs
       where
         settleWhat (ref, _) = "badge poller: settling " <> tshow (pProvider p) <> " invoice " <> ref
         skipWhat (ref, _) = "badge poller: reading the skipped " <> tshow (pProvider p) <> " invoice " <> fromMaybe "the provider did not name" ref
@@ -218,16 +223,17 @@ listPass env now p =
 settleMoved :: PollerEnv -> PaymentProvider -> UTCTime -> (Text, PaymentSignal) -> IO ()
 settleMoved env@PollerEnv {peStore, peWaiters, pePhases} provider now (ref, signal) =
   getInvoiceByProviderRef peStore ref >>= \case
-    Just InvoiceRow {irInvoiceId, irStatus, irProvider} | irProvider == provider ->
+    Just InvoiceRow {irInvoiceId, irStatus, irProvider, irProduct} | irProvider == provider ->
       when (isJust (decide irStatus signal)) $
         settleOrder peStore peWaiters pePhases irInvoiceId signal now >>= \case
           Left e -> logError ("badge poller: settling order " <> ref <> " failed: " <> e)
-          Right status -> reportSettled irStatus status
+          Right status -> reportSettled irProduct irStatus status
     _ -> pure ()
   where
-    reportSettled before after
-      -- checked before the no-change case, so a refund still alerts when money lands after expiry
-      | after == ISExpired, SigClosed Received {rcvCrypto = Just paid} <- signal = do
+    reportSettled sold before after
+      -- checked before the no-change case, so a refund still alerts when money lands after expiry;
+      -- settlement itself alerts once for a name order's late payment
+      | IPBadge {} <- sold, after == ISExpired, SigClosed Received {rcvCrypto = Just paid} <- signal = do
           let alert = "badge poller: order " <> ref <> " expired holding " <> paid <> ", which needs a refund"
           due <- dueToWarn env now alert
           when due $ logError alert
@@ -252,10 +258,11 @@ readHint env@PollerEnv {peStore, peProviders} now ref =
           Right Nothing -> pure ()
           Right (Just signal) -> settleMoved env irProvider now (ref, signal)
 
-sweepExpired :: PollerEnv -> UTCTime -> IO ()
-sweepExpired env@PollerEnv {peStore, peWaiters, pePhases, peCancelFailed} now = do
+-- | Leaves out the invoices whose read or settlement failed this pass.
+sweepExpired :: PollerEnv -> UTCTime -> Set Text -> IO ()
+sweepExpired env@PollerEnv {peStore, peWaiters, pePhases, peCancelFailed} now missed = do
   let cutoff = addUTCTime (negate expiryGrace) now
-  (selfExpiring, payable) <- partition (expiresItself . oiProvider) <$> overdueInvoices peStore cutoff
+  (selfExpiring, payable) <- partition (expiresItself . oiProvider) . filter ((`S.notMember` missed) . oiProviderRef) <$> overdueInvoices peStore cutoff
   atomically $ modifyTVar' peCancelFailed (`M.restrictKeys` S.fromList (map oiProviderRef payable))
   -- Cancel only a few orders per pass, so a long list does not block other work.
   cancelled <- filterM (closedAtProvider env now) (take readsPerPass payable)

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

@@ -26,6 +26,8 @@ module StoreService.Store.Invoices
     OverdueInvoice (..),
     overdueInvoices,
     expireOverdueInvoice,
+    lockInvoice,
+    unfundedQuery,
     newInvoiceId,
     readCatalogRows,
     seedCatalog,
@@ -233,12 +235,20 @@ qUnpaidRefs =
 qCodeHashExists :: Query
 qCodeHashExists = mkQuery "SELECT 1 FROM @badge_codes WHERE code_hash = ? LIMIT 1"
 
-unfundedOnly :: Text
-unfundedOnly =
+-- | No payment holding money was read for the invoice whose id is in this column, as paymentHolds reads one.
+-- The sweep and the overdue close of a name order must agree on it, so both use this.
+unfundedBy :: Text -> Text
+unfundedBy invoiceId =
   "AND NOT EXISTS (SELECT 1 FROM @payments p "
-    <> "WHERE p.invoice_id = @invoices.invoice_id AND ("
+    <> ("WHERE p.invoice_id = " <> invoiceId <> " AND (")
     <> "COALESCE(p.amount, 0) > 0 OR p.crypto_paid IS NOT NULL OR p.paid_in_full = 1)) "
 
+unfundedQuery :: Text -> Query
+unfundedQuery = mkQuery . (" " <>) . unfundedBy
+
+unfundedOnly :: Text
+unfundedOnly = unfundedBy "@invoices.invoice_id"
+
 qOverdueInvoices :: Query
 qOverdueInvoices =
   mkQuery $
@@ -297,6 +307,9 @@ qUpsertPayment =
   where
     alreadySettled = "@payments.status = '" <> paymentStatusText PSSettled <> "'"
 
+qLockInvoice :: Query
+qLockInvoice = mkQuery "UPDATE @invoices SET updated_at = ? WHERE invoice_id = ?"
+
 qUpdateInvoiceStatus :: Query
 qUpdateInvoiceStatus =
   mkQuery "UPDATE @invoices SET status = ?, updated_at = ? WHERE invoice_id = ? AND status = ?"
@@ -658,6 +671,10 @@ upsertPayment db InvoiceRow {irInvoiceId, irProvider, irProviderRef, irCurrency}
     InvoiceId invId = irInvoiceId
     at = truncateToSecond at'
 
+-- | Takes the invoice row's lock for the rest of the transaction; SQLite's transactions hold the whole database already.
+lockInvoice :: DB.Connection -> InvoiceId -> UTCTime -> IO ()
+lockInvoice db (InvoiceId invId) at = DB.execute db qLockInvoice (truncateToSecond at, invId)
+
 updateInvoiceStatus :: DB.Connection -> InvoiceId -> InvoiceStatus -> InvoiceStatus -> UTCTime -> IO Bool
 updateInvoiceStatus db (InvoiceId invId) observed new at =
   (> 0) <$> executeChanging db qUpdateInvoiceStatus (invoiceStatusText new, truncateToSecond at, invId, invoiceStatusText observed)

tests/Bots/StoreService/NamesOrdersTests.hs

@@ -14,6 +14,7 @@ import Control.Concurrent.Async (async, concurrently, wait)
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
 import Control.Concurrent.STM (TVar, atomically, check, modifyTVar', newTVarIO, readTVar)
 import qualified Control.Exception as E
+import Control.Arrow ((&&&))
 import Control.Monad (forM_, void)
 import Crypto.Random (ChaChaDRG)
 import Data.Aeson ((.=))
@@ -29,7 +30,7 @@ import Data.List (sort)
 import Data.Maybe (fromJust, isJust, isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime)
+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
 import Data.Word (Word64)
 import Network.HTTP.Client (defaultManagerSettings, newManager, responseBody)
@@ -56,7 +57,7 @@ import StoreService.Names.Store
 import StoreService.Names.Turns (newTurns)
 import StoreService.Names.View (ViewReads (..), readViewChain, viewJSON)
 import StoreService.Orders (cancelOpenInvoice, expireOverdue, settleOrder)
-import StoreService.Poller (cleanupInterval, cleanupReadsPerPass, cleanupUnpaid, drainHints, newPollerEnv, newReadHints, queueReadHint, unpaidRetention)
+import StoreService.Poller (cleanupInterval, cleanupReadsPerPass, cleanupUnpaid, drainHints, newPollerEnv, newReadHints, queueReadHint, runOnePass, unpaidRetention)
 import StoreService.Providers.BTCPay (btcpayProvider)
 import StoreService.Providers (Funded (..), OrderDraft (..), PaymentSignal (..), Provider (..), ProviderError (..), ProviderInvoice (..))
 import StoreService.Store.Invoices (InvoicePayment (..), InvoiceProduct (..), InvoiceRow (..), OverdueInvoice (..), ProviderRefConflict (..), getInvoice, getInvoiceByProviderRef, overdueInvoices, unpaidRefs)
@@ -95,17 +96,21 @@ namesOrdersTests = describe "StoreService names: orders" $ do
     it "records a payment of the closed order as a late payment, leaving the newer order alone" testLatePaymentAfterNewOrder
     it "keeps an overdue order whose invoice holds money, refusing the next order, and settles it" testFundedOverdueKept
     it "alerts on a late payment as BTCPay reports it for an expired, cancelled or swept invoice, once" testLateBTCPayPayments
+    it "alerts once on money read while open when the provider then closes the invoice, also after a restart" testOneLateAlert
     it "answers cancel with funded, not_open, paid when settlement won, and expired with the payment read meanwhile" testCancelAnswers
     it "leaves a late payment of a cancelled invoice unpaid and alerts" testLatePayment
     it "queues an order settled while open and publishes its version" testSettlementQueues
+    it "takes the invoice's row before recording a payment that moves no status" testSettlementLocksInvoice
     it "closes the order of an invoice the provider closed or the sweep expired" testExpiryCloses
     it "sweeps each invoice on its own, skipping one whose order cannot be read" testSweepSkipsBadRow
+    it "keeps out of a pass's sweep only the invoices whose read or settlement failed" testPassSweepsAroundFailures
     it "cleans up unpaid orders after 30 days, reading the provider first" testCleanup
     it "reads at most a pass's share of the provider in a cleanup, carrying the rest to the next pass" testCleanupCapped
     it "answers 503 for a name invoice while names are off, cancelling nothing" testNamesOff
   describe "invoice side" $ do
     it "finds an invoice by provider ref in either table, refusing a ref both hold" testProviderRefs
     it "reads and sweeps name invoices with the badge ones" testPollerQueries
+    it "agrees between the sweep and the overdue close on which invoices hold money" testFundedAgreement
   describe "registration view" $ do
     it "has the contract's fields" testViewFields
     it "reads the intent nonce in committed and the code length in taken and code_issued" testViewReads
@@ -646,7 +651,7 @@ testFundedOverdueKept = withOrders $ \ctx -> do
   placeOrder ctx aliceOrder {oCommitment = commitmentOf 2, oTimestamp = seconds now, oDuration = durationAt now} `shouldReturn` refusedWith 409 "order_exists"
   r <- invoiceRegistration ctx inv
   (nrLive r, nrPhase r) `shouldBe` (True, PUnpaid)
-  withTransaction (cStore ctx) (\db -> closeOverdue db r now) >>= (`shouldNotBe` Written (nrVersion r + 1))
+  withTransaction (cStore ctx) (\db -> closeOverdue db r now) `shouldReturn` Nothing
   (irStatus <$>) <$> getInvoice (cStore ctx) inv `shouldReturn` Just ISOpen
   settleNow ctx inv settled `shouldReturn` Right ISPaid
   nrPhase <$> invoiceRegistration ctx inv `shouldReturn` PQueued
@@ -682,6 +687,26 @@ testLateBTCPayPayments = withFakeBTCPay $ \fake -> do
       r <- invoiceRegistration ctx inv
       (nrPhase r, nrLive r) `shouldBe` (PUnpaid, False)
 
+-- | Paid in part while open, then expired by BTCPay with the same figures: one refund line, none from a restarted poller.
+testOneLateAlert :: IO ()
+testOneLateAlert = withOrders $ \ctx@Ctx {cStore = st, cWeb} -> do
+  (inv, _) <- placed ctx aliceOrder
+  Just InvoiceRow {irProviderRef = ref} <- getInvoice st inv
+  let paid = rcv 5000 (Just "0.00078")
+      newPoller = newPollerEnv st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) (weHints cWeb) (weProviders cWeb) (poll $ weConfig cWeb)
+      readWith poller = capturingStderr $ queueReadHint (weHints cWeb) ref >> drainHints poller
+      refunds = length . T.breakOnAll "refund"
+  poller <- newPoller
+  setSignals (cStub ctx) [(ref, SigFunded paid PaidInPart)]
+  refunds <$> readWith poller `shouldReturn` 0
+  setSignals (cStub ctx) [(ref, SigClosed paid)]
+  logs <- readWith poller
+  refunds logs `shouldBe` 1
+  logs `shouldSatisfy` T.isInfixOf "stays unpaid; refund the payment"
+  restarted <- newPoller
+  refunds <$> readWith restarted `shouldReturn` 0
+  (nrPhase &&& nrLive) <$> invoiceRegistration ctx inv `shouldReturn` (PUnpaid, False)
+
 testCancelAnswers :: IO ()
 testCancelAnswers = withOrders $ \ctx -> do
   let cancel = cancelAt ctx
@@ -758,6 +783,16 @@ testSettlementQueues = withOrders $ \ctx -> do
   r <- invoiceRegistration ctx invId
   (nrPhase r, nrLive r, nrVersion r) `shouldBe` (PQueued, True, 2)
 
+-- | Postgres serializes the payment with a concurrent overdue close only on this row; SQLite shows that it is written.
+testSettlementLocksInvoice :: IO ()
+testSettlementLocksInvoice = withOrders $ \ctx -> do
+  (inv@(InvoiceId t), _) <- placed ctx aliceOrder
+  advance ctx 60
+  settleNow ctx inv (SigFunded (rcv 10000 (Just "0.00156")) PaidInFull) `shouldReturn` Right ISOpen
+  now <- readIORef (cClock ctx)
+  withConnection (cStore ctx) (\db -> DB.query db "SELECT updated_at, status FROM sx_badge_service_invoices WHERE invoice_id = ?" [t])
+    `shouldReturn` [(now, "open" :: Text)]
+
 testExpiryCloses :: IO ()
 testExpiryCloses = withOrders $ \ctx -> do
   (closedByProvider, _) <- placed ctx aliceOrder
@@ -785,6 +820,28 @@ testSweepSkipsBadRow = withOrders $ \ctx@Ctx {cStore = st} -> do
   where
     invoiceText (InvoiceId t) = t
 
+-- | The poller reads by the wall clock, so the orders are placed two hours ago by it.
+testPassSweepsAroundFailures :: IO ()
+testPassSweepsAroundFailures = do
+  unreadable <- newIORef ""
+  let failing p = p {pReadInvoice = \r -> readIORef unreadable >>= \u -> if r == u then pure (Left $ ProviderError "down") else pReadInvoice p r}
+  withOrdersVia failing $ \ctx@Ctx {cStore = st, cWeb} -> do
+    placedAt <- addUTCTime (-7200) <$> getCurrentTime
+    writeIORef (cClock ctx) placedAt
+    let at' o = o {oTimestamp = seconds placedAt, oDuration = durationAt placedAt}
+        refOf inv = maybe (error "no invoice") irProviderRef <$> getInvoice st inv
+    (poisoned, _) <- placed ctx $ at' aliceOrder
+    (unread, _) <- placed ctx $ at' aliceOrder {oLabel = "dynamis", oPrice = 20000, oCommitment = commitmentOf 2}
+    (good, _) <- placed ctx $ at' aliceOrder {oOwner = ownerBText, oKey = keyB, oCommitment = commitmentOf 3}
+    NameRegistration {nrId = RegistrationId poisonedId} <- invoiceRegistration ctx poisoned
+    withConnection st $ \db -> DB.execute db "UPDATE sx_badge_service_name_registrations SET phase = 'lost' WHERE registration_id = ? AND phase = ?" (poisonedId, "unpaid" :: Text)
+    poisonedRef <- refOf poisoned
+    refOf unread >>= writeIORef unreadable
+    setSignals (cStub ctx) [(poisonedRef, SigClosed (rcv 0 Nothing))]
+    poller <- newPollerEnv st (weWaiters cWeb) (Just $ oePhases $ cOrders ctx) (weHints cWeb) (weProviders cWeb) (poll $ weConfig cWeb)
+    void $ capturingStderr $ runOnePass poller
+    mapM (fmap (irStatus <$>) . getInvoice st) [poisoned, unread, good] `shouldReturn` map Just [ISOpen, ISOpen, ISExpired]
+
 testCleanup :: IO ()
 testCleanup = withOrders $ \ctx -> testCleanupIn ctx
 
@@ -858,6 +915,28 @@ testPollerQueries = withServiceStore $ \st -> do
   map oiProviderRef <$> overdueInvoices st (addUTCTime 7200 t0) `shouldReturn` ["ref-inv-r1"]
   overdueInvoices st t0 `shouldReturn` []
 
+testFundedAgreement :: IO ()
+testFundedAgreement = withServiceStore $ \st -> do
+  waiters <- newWaiters
+  let now = addUTCTime 3600 t0
+      shapes =
+        [ ("amount", Just (SigFunded (rcv 100 Nothing) PaidInPart), True),
+          ("crypto", Just (SigFunded (rcv 0 (Just "0.00001")) PaidInPart), True),
+          ("verdict", Just (SigFunded (rcv 0 Nothing) PaidInFull), True),
+          ("nothing", Nothing, False)
+        ]
+  forM_ (zip [1 ..] shapes) $ \(n, (rid, signal, _)) -> do
+    placePaid st rid ownerA (order ("fundname" <> rid) n) t0 `shouldReturn` Right ()
+    forM_ signal $ \sig -> void $ settleOrder st waiters Nothing (InvoiceId $ "inv-" <> rid) sig t0
+  listed <- map oiInvoiceId <$> overdueInvoices st now
+  forM_ (zip [1 ..] shapes) $ \(n, (rid, _, funded)) -> do
+    let o = order ("fundname" <> rid) n
+    (InvoiceId ("inv-" <> rid) `elem` listed) `shouldBe` not funded
+    [LiveOrder {loRegistration, loOverdue}] <- withTransaction st $ \db -> getLiveOrders db (ofCommitment o) ownerA (ofLabelHash o) now
+    (rid, loOverdue) `shouldBe` (rid, not funded)
+    closed <- withTransaction st $ \db -> closeOverdue db loRegistration now
+    (rid, closed) `shouldBe` (rid, if funded then Nothing else Just (nrVersion loRegistration + 1))
+
 testViewFields :: IO ()
 testViewFields = withServiceStore $ \st -> withFakeEthNode $ \node -> do
   Right () <- placePaid st "r1" ownerA (order "alicebakery" 1) (addUTCTime 3600 t0)

tests/Bots/StoreService/NamesStoreTests.hs

@@ -304,7 +304,7 @@ testOrderHashLookup = withServiceStore $ \st -> do
   placePaid st "r1" ownerA o (at 1) `shouldReturn` Right ()
   r <- reg st "r1"
   closed <- withTransaction st $ \db -> closeOverdue db r (at 2)
-  closed `shouldBe` Written 2
+  closed `shouldBe` Just 2
   found <- withTransaction st $ \db -> getRegistrationByOrderHash db (orderHash ownerA o (OTInvoice btc price))
   (nrId <$> found, nrLive <$> found) `shouldBe` (Just (RegistrationId "r1"), Just False)
   withTransaction st (\db -> getRegistrationByOrderHash db (orderHash ownerA o (OTInvoice btc (price + 1)))) `shouldReturn` Nothing
@@ -346,7 +346,7 @@ testCloseOverdueStale = withServiceStore $ \st -> do
   placePaid st "r1" ownerA (order "alicebakery" 1) (at 60) `shouldReturn` Right ()
   r <- reg st "r1"
   write st r {nrPhase = PQueued} `shouldReturn` Written 2
-  withTransaction st (\db -> closeOverdue db r (at 61)) `shouldReturn` VersionChanged
+  withTransaction st (\db -> closeOverdue db r (at 61)) `shouldReturn` Nothing
   invoiceStatus st "inv-r1" `shouldReturn` "open"
   (nrLive &&& nrPhase) <$> reg st "r1" `shouldReturn` (True, PQueued)
 
@@ -462,7 +462,7 @@ testLatePayment = withServiceStore $ \st -> do
       o' = o {ofCommitment = digestFixture 2, ofSealed = "new"}
   placePaid st "r1" ownerA o (at 60) `shouldReturn` Right ()
   closed <- reg st "r1"
-  withTransaction st (\db -> closeOverdue db closed (at 61)) `shouldReturn` Written 2
+  withTransaction st (\db -> closeOverdue db closed (at 61)) `shouldReturn` Just 2
   r1 <- reg st "r1"
   write st r1 {nrPhase = PQueued} `shouldReturn` NotLive
   reg st "r1" `shouldReturn` r1
@@ -549,7 +549,7 @@ testSameSecondOrder = withServiceStore $ \st -> do
   forM_ ["r5", "r4"] $ \rid -> do
     placePaid st rid ownerB o (at 60) `shouldReturn` Right ()
     r <- reg st rid
-    withTransaction st (\db -> closeOverdue db r (at 61)) `shouldReturn` Written 2
+    withTransaction st (\db -> closeOverdue db r (at 61)) `shouldReturn` Just 2
   found <- withTransaction st $ \db -> getRegistrationByOrderHash db (orderHash ownerB o (OTInvoice btc price))
   nrId <$> found `shouldBe` Just (RegistrationId "r5")
 

tests/Bots/StoreService/WebTests.hs

@@ -284,7 +284,7 @@ badgeWebTests = do
     it "warns once for all the invoices it did not sell, not once per invoice" testStrangerSkipsShareOneWarning
     it "raises a skip naming an invoice this service sold" testSkipNamingOurInvoiceIsRaised
     it "holds the sweep back until a pass has accounted for every invoice" testSweepWaitsForAPassThatSawEverything
-    it "settles the rest of the pass around an invoice that throws" testOneBadInvoiceDoesNotStopThePass
+    it "settles and sweeps the rest of the pass around an invoice that throws" testOneBadInvoiceDoesNotStopThePass
     it "pages past a hundred open invoices, a request per hundred" testListPaginates
     it "stops paging at its ceiling rather than looping on a server that ignores take" testPagingStopsAtTheCeiling
   describe "store service webhook" $ do
@@ -2923,12 +2923,8 @@ testOneBadInvoiceDoesNotStopThePass = bounded "one bad invoice" $ withStubPoller
   setSignals ref [("p-bad", settledSignal), ("p-good", settledSignal)]
   runOnePass poller
   invoiceStatus (weStore env) good `shouldReturn` ISPaid
-  invoiceStatus (weStore env) overdue `shouldReturn` ISOpen
-
-  setSignals ref []
-  setSkipped ref [(Just "p-bad", "some reason the provider gave")]
-  runOnePass poller
-  invoiceStatus (weStore env) overdue `shouldReturn` ISOpen
+  -- only the invoice that failed is kept out of the sweep
+  invoiceStatus (weStore env) overdue `shouldReturn` ISExpired
 
 testSweepWaitsForAPassThatSawEverything :: IO ()
 testSweepWaitsForAPassThatSawEverything = bounded "sweep guards" $ withStubPoller raceHold $ \ref poller env _ -> do