diff --git a/apps/simplex-store-service/src/StoreService/Names/Store.hs b/apps/simplex-store-service/src/StoreService/Names/Store.hs index e68c3285c7..76bdfca27a 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Store.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Store.hs @@ -206,7 +206,8 @@ 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. -data VersionWrite = Written Int64 | VersionChanged | NotLive | LiveOrderExists +-- NotOverdue: closeOverdue found the order's invoice no longer open, or holding money. +data VersionWrite = Written Int64 | VersionChanged | NotLive | LiveOrderExists | NotOverdue deriving (Eq, Show) -- | A live order an order request meets; overdue when its open invoice is past its expiry time. @@ -479,13 +480,15 @@ getRegistrationByOrderHash db hash = firstDecoded toRegistration $ DB.query db (selectRegistrations <> " WHERE r.order_hash = ? ORDER BY r.created_at DESC, r.registration_id DESC LIMIT 1") (Only $ Binary hash) --- | Overdue whatever status the poller has marked, as long as the invoice is not paid. +-- | Overdue whatever status the poller has marked, as long as the invoice is not paid and holds no money, as the sweep decides. getLiveOrders :: DB.Connection -> ByteString -> Address -> LabelHash -> UTCTime -> IO [LiveOrder] getLiveOrders db commitment owner (LabelHash lh) now = DB.query db ( registrationColumns - <> ", CASE WHEN r.phase = ? AND i.status <> ? AND i.expires_at < ? THEN 1 ELSE 0 END" + <> ", CASE WHEN r.phase = ? AND i.status <> ? AND i.expires_at < ?" + <> unfunded + <> " THEN 1 ELSE 0 END" <> registrationFrom <> " LEFT JOIN sx_badge_service_invoices i ON i.invoice_id = ni.invoice_id" <> " WHERE r.live = 1 AND (r.commitment = ? OR (r.owner = ? AND r.label_hash = ?))" @@ -495,24 +498,43 @@ getLiveOrders db commitment owner (LabelHash lh) now = where toLiveOrder (row :. Only (BI loOverdue)) = (\loRegistration -> LiveOrder {loRegistration, loOverdue}) <$> toRegistration row --- | Run in the transaction that inserts the next order, so the unique constraints let it in. -closeOverdue :: DB.Connection -> NameRegistration -> UTCTime -> IO VersionWrite -closeOverdue db r@NameRegistration {nrId = RegistrationId rid} now = do - written <- updateRegistration db r {nrLive = False} now - when (isWritten written) $ - DB.execute - db - [sql| - UPDATE sx_badge_service_invoices SET status = ?, updated_at = ? - WHERE status = ? AND invoice_id IN (SELECT invoice_id FROM sx_badge_service_name_invoices WHERE registration_id = ?) - |] - (invoiceStatusText ISExpired, truncateToSecond now, invoiceStatusText ISOpen, rid) - pure written +-- | A payment holding money, as the sweep's own check reads one, makes the invoice i funded. +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) + ) + |] -isWritten :: VersionWrite -> Bool -isWritten = \case - Written _ -> True - _ -> False +-- | 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 + expired <- + executeChanging + db + ( [sql| + UPDATE sx_badge_service_invoices SET status = ?, updated_at = ? + WHERE status = ? AND invoice_id IN ( + SELECT i.invoice_id 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 + WHERE ni.registration_id = ? AND r.version = ? AND r.live = 1 + |] + <> unfunded + <> " )" + ) + (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 -- | 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. diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index d5b84d7cad..2a82c4c2c4 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -90,6 +90,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do it "accepts a new order of the same wallet and name after a cancel" testOrderAfterCancel it "closes an overdue order of the same wallet and name before the poller marks it, cancelling its invoice after" testOverdueClosed 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 "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 @@ -591,6 +592,22 @@ testLatePaymentAfterNewOrder = withOrders $ \ctx -> do settleNow ctx newInv settled `shouldReturn` Right ISPaid (nrPhase <$> invoiceRegistration ctx newInv) `shouldReturn` PQueued +-- | Paid in full at minute 44 of 45 and confirming after; a second tab's order at minute 46 must not refund it. +testFundedOverdueKept :: IO () +testFundedOverdueKept = withOrders $ \ctx -> do + (inv, _) <- placed ctx aliceOrder + advance ctx (44 * 60) + settleNow ctx inv (SigFunded (rcv 10000 (Just "0.00156")) PaidInFull) `shouldReturn` Right ISOpen + advance ctx (2 * 60) + now <- readIORef (cClock ctx) + 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)) + (irStatus <$>) <$> getInvoice (cStore ctx) inv `shouldReturn` Just ISOpen + settleNow ctx inv settled `shouldReturn` Right ISPaid + nrPhase <$> invoiceRegistration ctx inv `shouldReturn` PQueued + -- | The real BTCPay adapter against the fake: a payment into an expired invoice reads Expired with PaidLate, -- into a cancelled one Invalid, and into one only we closed New and paid in part. testLateBTCPayPayments :: IO ()