From 5ef9080c09f1f4c5dd4ab88cab223a7c0a5138e5 Mon Sep 17 00:00:00 2001
From: sh <37271604+shumvgolove@users.noreply.github.com>
Date: Fri, 25 Sep 2026 22:52:13 +0400
Subject: [PATCH] badges: stop skipped-invoice log flood (#7591)

* badges: fill skip log in cap test without logging

* badges: aggregate foreign invoice skip warnings

* badges: document dedicated payment store
---
 apps/simplex-badge-service/README.md          |  4 +++
 .../src/BadgeService/Poller.hs                | 26 ++++++++++++++-----
 tests/Bots/BadgeService/WebTests.hs           | 15 ++++++++---
 3 files changed, 35 insertions(+), 10 deletions(-)

diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md
index 945256f814..8467e57906 100644
--- a/apps/simplex-badge-service/README.md
+++ b/apps/simplex-badge-service/README.md
@@ -122,6 +122,10 @@ The BTCPay API key needs four permissions, each scoped to the one store:
 `canmodifyinvoices` so `POST /api/invoice/:id/cancel` can invalidate an invoice at BTCPay
 rather than only in this store.
 
+Give the service a BTCPay store of its own, and a Stripe account of its own if card payments are
+on. The poller lists every invoice and payment intent of the last three days or so, and one it did
+not create and cannot read is reported in a warning once an hour until it falls out of that window.
+
 ### Card payments (Stripe)
 
 An optional `[stripe]` section enables the card lane; omitting it disables card payments
diff --git a/apps/simplex-badge-service/src/BadgeService/Poller.hs b/apps/simplex-badge-service/src/BadgeService/Poller.hs
index c91ffcd22f..c22df44ddb 100644
--- a/apps/simplex-badge-service/src/BadgeService/Poller.hs
+++ b/apps/simplex-badge-service/src/BadgeService/Poller.hs
@@ -45,7 +45,7 @@ import qualified Data.Set as S
 import Data.Text (Text)
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
 import Numeric.Natural (Natural)
-import Simplex.Chat.PaymentService.Types (InvoiceStatus (..), PaymentProvider)
+import Simplex.Chat.PaymentService.Types (InvoiceStatus (..), PaymentProvider (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore)
 import Simplex.Messaging.Util (tshow)
 
@@ -181,6 +181,7 @@ listPass env now p =
       pure False
     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)
       where
@@ -290,13 +291,26 @@ skipOwner PollerEnv {peStore} provider = \case
 reportSkip :: PollerEnv -> PaymentProvider -> UTCTime -> (Maybe Text, Text) -> IO SkipOwner
 reportSkip env provider now (ref, reason) = do
   owner <- skipOwner env provider ref
-  due <- dueToWarn env now reason
-  when due $ case owner of
-    SkipOurs -> logError ("badge poller: an invoice this service sold was not read, so its payment cannot be detected: " <> reason)
-    SkipUnaccounted -> logError ("badge poller: part of the window was not read, so a payment to any invoice in it cannot be detected: " <> reason)
-    SkipStranger -> logWarn ("badge poller: the list pass could not read everything: " <> reason)
+  let raise msg = dueToWarn env now reason >>= (`when` logError (msg <> reason))
+  case owner of
+    SkipOurs -> raise "badge poller: an invoice this service sold was not read, so its payment cannot be detected: "
+    SkipUnaccounted -> raise "badge poller: part of the window was not read, so a payment to any invoice in it cannot be detected: "
+    SkipStranger -> pure ()
   pure owner
 
+-- | One limiter key per provider, so a store full of invoices sold elsewhere costs one line an hour, not one per invoice.
+reportStrangers :: PollerEnv -> PaymentProvider -> UTCTime -> [Text] -> IO ()
+reportStrangers env provider now = \case
+  [] -> pure ()
+  reasons@(example : _) -> do
+    due <- dueToWarn env now ("stranger skips: " <> tshow provider)
+    when due $ logWarn ("badge poller: " <> tshow (length reasons) <> " unreadable invoice(s) not created by this service; use a dedicated " <> home <> "; first: " <> example)
+  where
+    home = case provider of
+      PPCrypto -> "BTCPay store"
+      PPStripe -> "Stripe account"
+      other -> providerText other <> " account"
+
 dueToWarn :: PollerEnv -> UTCTime -> Text -> IO Bool
 dueToWarn PollerEnv {peSkipped} now reason = atomically $ do
   seen <- readTVar peSkipped
diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs
index dd21c820dd..633ad14564 100644
--- a/tests/Bots/BadgeService/WebTests.hs
+++ b/tests/Bots/BadgeService/WebTests.hs
@@ -28,7 +28,7 @@ import qualified Control.Concurrent.Async as Async
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
 import Control.Concurrent.STM (atomically, modifyTVar', readTVarIO)
 import qualified Control.Exception as E
-import Control.Monad (join, replicateM, replicateM_, void, when)
+import Control.Monad (forM_, join, replicateM, replicateM_, void, when)
 import Data.Aeson ((.=))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Key as K
@@ -237,6 +237,7 @@ badgeWebTests = do
     it "reports a skipped invoice once, and again only after the interval" testSkipWarningsAreRateLimited
     it "warns once for a provider that stays down, not once a pass" testOutageWarnsOnceNotEveryPass
     it "holds the skip log under its cap when every reason is fresh" testSkipReasonsStayBounded
+    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
@@ -2665,13 +2666,19 @@ testSkipNamingOurInvoiceIsRaised = bounded "skip ownership" $ withStubPoller rac
   invoiceStatus (weStore env) iid `shouldReturn` ISPaid
 
 testSkipReasonsStayBounded :: IO ()
-testSkipReasonsStayBounded = bounded "skip reasons bounded" $ withStubPoller raceHold $ \ref poller _ _ -> do
-  let reasons n = [(Just ("p-" <> tshow i), "btcpay invoice p-" <> tshow i <> ": unknown method") | i <- [1 .. n :: Int]]
-  setSkipped ref (reasons (maxSkipReasons + 500))
+testSkipReasonsStayBounded = bounded "skip reasons bounded" $ withStubPoller raceHold $ \_ poller _ _ -> do
+  now <- getCurrentTime
+  forM_ [1 .. maxSkipReasons + 500] $ \i -> dueToWarn poller now ("btcpay invoice p-" <> tshow i <> ": unknown method")
   runOnePass poller
   held <- Map.size <$> readTVarIO (peSkipped poller)
   held `shouldSatisfy` (<= maxSkipReasons)
 
+testStrangerSkipsShareOneWarning :: IO ()
+testStrangerSkipsShareOneWarning = bounded "stranger skips" $ withStubPoller raceHold $ \ref poller _ _ -> do
+  setSkipped ref [(Just ("stranger-" <> tshow i), "btcpay invoice stranger-" <> tshow i <> ": unknown method") | i <- [1 .. 3 :: Int]]
+  runOnePass poller
+  Map.size <$> readTVarIO (peSkipped poller) `shouldReturn` 1
+
 -- | The failure text carries the whole request, whose window moves with the clock, so the two
 -- messages differ only in startDate to prove the limiter key ignores it rather than warning
 -- every pass.