store: lock the invoice row before a payment

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

@@ -97,7 +97,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)
 
 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
@@ -513,7 +513,11 @@ unfunded =
 -- 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
+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

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, paymentHolds, 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 {}

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

@@ -26,6 +26,7 @@ module StoreService.Store.Invoices
     OverdueInvoice (..),
     overdueInvoices,
     expireOverdueInvoice,
+    lockInvoice,
     newInvoiceId,
     readCatalogRows,
     seedCatalog,
@@ -296,6 +297,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 = ?"
@@ -657,6 +661,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

@@ -100,6 +100,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do
     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 "cleans up unpaid orders after 30 days, reading the provider first" testCleanup
@@ -780,6 +781,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