diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index d1d2f936d1..1f28acf81d 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/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 = diff --git a/apps/simplex-store-service/src/StoreService/Names/Store.hs b/apps/simplex-store-service/src/StoreService/Names/Store.hs index c243398c0a..53787211b2 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Store.hs +++ b/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. diff --git a/apps/simplex-store-service/src/StoreService/Orders.hs b/apps/simplex-store-service/src/StoreService/Orders.hs index d951982f7a..a1b2c4ad76 100644 --- a/apps/simplex-store-service/src/StoreService/Orders.hs +++ b/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)) diff --git a/apps/simplex-store-service/src/StoreService/Poller.hs b/apps/simplex-store-service/src/StoreService/Poller.hs index 5bddfec0e8..b5c6c09df0 100644 --- a/apps/simplex-store-service/src/StoreService/Poller.hs +++ b/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) diff --git a/apps/simplex-store-service/src/StoreService/Store/Invoices.hs b/apps/simplex-store-service/src/StoreService/Store/Invoices.hs index 5c22726358..f3d093d0e1 100644 --- a/apps/simplex-store-service/src/StoreService/Store/Invoices.hs +++ b/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) diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 927fb0bf82..9efac23221 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/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) diff --git a/tests/Bots/StoreService/NamesStoreTests.hs b/tests/Bots/StoreService/NamesStoreTests.hs index fc778c9925..c32ea0b0e2 100644 --- a/tests/Bots/StoreService/NamesStoreTests.hs +++ b/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") diff --git a/tests/Bots/StoreService/WebTests.hs b/tests/Bots/StoreService/WebTests.hs index 91d11d5102..41d42fae39 100644 --- a/tests/Bots/StoreService/WebTests.hs +++ b/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