From 6b2bb17db3903721f28895c70bf01659d3792c6b Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 16:31:36 +0000 Subject: [PATCH] store: name the invoice in credit pass warnings --- .../src/StoreService/Names/LateCredits.hs | 16 +++++++++------- .../src/StoreService/Poller.hs | 7 ++++++- tests/Bots/StoreService/NamesLateCreditTests.hs | 12 ++++++++++++ 3 files changed, 27 insertions(+), 8 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/LateCredits.hs b/apps/simplex-store-service/src/StoreService/Names/LateCredits.hs index 1187ddddd6..082febeea7 100644 --- a/apps/simplex-store-service/src/StoreService/Names/LateCredits.hs +++ b/apps/simplex-store-service/src/StoreService/Names/LateCredits.hs @@ -31,10 +31,12 @@ import Text.Read (readMaybe) minCurrentRateFraction :: Rational minCurrentRateFraction = 1 % 2 --- | CORefused: the credit's number was taken meanwhile, which the invoice's lock rules out. +-- | CONoInvoiceRate: crypto due with no invoice rate recorded to credit it at. CORefused: the credit's number was taken meanwhile, +-- which the invoice's lock rules out. data CreditOutcome = CONothingDue | COCredited LateCredit + | CONoInvoiceRate | CORateFailed ProviderError | CORateFloor Text Rate | CORefused @@ -45,12 +47,12 @@ creditLateInvoice st readRate invId now = withTransaction st (`lateCreditState` invId) >>= \case Just s | creditable s && moneyDue s -> case lsCoin s of Nothing -> credit Nothing - Just coin -> - readRate coin >>= \case - Left e -> pure $ CORateFailed e - Right rate -> case invoiceRate s of - Nothing -> pure $ CORateFailed $ ProviderError "the invoice's rate is not stored" - Just (invoiceText, invoiceValue) + Just coin -> case invoiceRate s of + Nothing -> pure CONoInvoiceRate + Just (invoiceText, invoiceValue) -> + readRate coin >>= \case + Left e -> pure $ CORateFailed e + Right rate | toRational (rateValue rate) < minCurrentRateFraction * toRational invoiceValue -> CORateFloor invoiceText rate <$ withTransaction st (\db -> setLateSupport db invId LSRateFloor) | otherwise -> credit (Just rate) diff --git a/apps/simplex-store-service/src/StoreService/Poller.hs b/apps/simplex-store-service/src/StoreService/Poller.hs index 4e461cfb65..0044168de2 100644 --- a/apps/simplex-store-service/src/StoreService/Poller.hs +++ b/apps/simplex-store-service/src/StoreService/Poller.hs @@ -341,7 +341,9 @@ creditPass env@PollerEnv {peStore, peProviders} now = do safely ("names: crediting invoice " <> invText) $ getInvoice peStore invId >>= \case Just InvoiceRow {irProvider} | Just p <- find ((== irProvider) . pProvider) peProviders -> void $ creditLate env p now invId - _ -> logWarn ("names: invoice " <> invText <> " has late money to credit, but no provider is configured to read its rate") + _ -> do + due' <- dueToWarn env now ("no rate provider: " <> invText) + when due' $ logWarn ("names: invoice " <> invText <> " has late money to credit, but no provider is configured to read its rate") -- | The pass's rate of a coin at a provider, read at most once. cachedRate :: PollerEnv -> Provider -> CryptoCurrency -> IO (Either ProviderError Rate) @@ -367,6 +369,9 @@ creditLate env@PollerEnv {peStore} p now invId@(InvoiceId invText) = do logInfo $ "names: invoice " <> invText <> " credited " <> tshow lcCents <> " cents to the balance of registration " <> rid <> maybe "" (\units -> " for " <> tshow units <> " units at " <> fromMaybe "?" lcRateUsed <> " (invoice " <> fromMaybe "?" lcInvoiceRate <> ", current " <> fromMaybe "?" lcCurrentRate <> ")") lcUnits + CONoInvoiceRate -> do + due <- dueToWarn env now ("no invoice rate: " <> invText) + when due $ logError ("names: invoice " <> invText <> " has confirmed late money, but no invoice rate was recorded to credit it at; check it at the provider") CORateFailed (ProviderError e) -> do due <- dueToWarn env now ("rate read failed: " <> tshow (pProvider p)) when due $ logWarn ("names: late credits wait, as the current rate cannot be read; each pass tries again: " <> e) diff --git a/tests/Bots/StoreService/NamesLateCreditTests.hs b/tests/Bots/StoreService/NamesLateCreditTests.hs index c3fb1cb1e3..3150176450 100644 --- a/tests/Bots/StoreService/NamesLateCreditTests.hs +++ b/tests/Bots/StoreService/NamesLateCreditTests.hs @@ -69,6 +69,7 @@ namesLateCreditTests = describe "StoreService names: balance life" $ do it "credits nothing below the rate floor and never after, logging an error, and alerts support naming both rates" testRateFloor it "logs the rate floor of an invoice once while the price moves below it" testFloorLoggedOnce it "alerts confirmed money waiting on the rate read as such, whatever reason was stored before" testWaitingOutranksStoredReason + it "warns once of an invoice no provider reads a rate for, and names an invoice with no recorded rate" testRateProblemsNamed it "reads one rate per coin per pass for several invoices, and none when nothing is due" testOneRateReadPerPass it "never credits a late Settled payment on an invoice made under HighSpeed, alerting it past the window" testHighSpeed it "credits at the next pass a late Settled invoice and a settlement whose credit step did not run" testCreditedByPass @@ -448,6 +449,17 @@ testWaitingOutranksStoredReason = withLate $ \l@Late {lStore = st} -> do alertsAt l (Left $ ProviderError "rates down for outranked") (pastWindow (at 70) 60) >>= (`shouldSatisfy` logged "ERROR" "invoice inv-outranked of order outranked: 320000 satoshi received, 320000 satoshi confirmed, 0 satoshi credited; confirmed, the credit waits on the rate read; do not refund; fix the rate read") +testRateProblemsNamed :: IO () +testRateProblemsNamed = withLate $ \l@Late {lStore = st} -> do + closedOrder l "noprovider" False + settleAt l "noprovider" (SigClosed (btcPaid lateUnits lateUnits)) (at 70) `shouldReturn` Right ISExpired + withTransaction st $ \db -> DB.execute_ db "UPDATE sx_badge_service_invoices SET provider = 'apple' WHERE invoice_id = 'inv-noprovider'" + closedOrder l "norate" False + settleAt l "norate" (SigClosed (btcPaid lateUnits lateUnits) {rcvRate = Nothing}) (at 70) `shouldReturn` Right ISExpired + logs <- (<>) <$> passAt l (at 71) <*> passAt l (at 72) + count "invoice inv-noprovider has late money to credit, but no provider" logs `shouldBe` 1 + logs `shouldSatisfy` logged "ERROR" "invoice inv-norate has confirmed late money, but no invoice rate was recorded to credit it at" + testOneRateReadPerPass :: IO () testOneRateReadPerPass = withLate $ \l@Late {lStore = st} -> do mapM_ (\r -> closedOrder l r False >> settleAt l r (SigClosed (btcPaid lateUnits lateUnits)) (at 70)) ["x", "y", "z"]