Merge branch 'master' into ep/parallel-tests

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

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

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.