From ba1731c5514cf85eebe0afc01c330b9349b683b5 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Tue, 6 Oct 2026 12:57:35 +0400 Subject: [PATCH] core: pin the badge-held and internal-retry rules without depending on timing --- tests/Bots/BadgeService/BotTests.hs | 139 +++++++++++++++------------- 1 file changed, 75 insertions(+), 64 deletions(-) diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index b4dc94dc0f..a0e054b4b9 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -36,7 +36,7 @@ import Data.Char (toLower) import Data.Either (isLeft, isRight) import Data.Int (Int64) import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) -import Data.List (stripPrefix) +import Data.List (isPrefixOf, stripPrefix) import qualified Data.Map.Strict as M import Data.Maybe (isJust, isNothing) import Data.String (fromString) @@ -57,6 +57,7 @@ import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Chat.PaymentService (ServicePayment (..)) import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..)) +import Simplex.Chat.Store.Badges (getDueStoreReceipts, getNextStoreReceiptAttempt) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) import Simplex.Messaging.Agent.Store.Common (withTransaction) @@ -1599,7 +1600,9 @@ testStoreQuantityRefused ps = since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleQuantityJWS}) storePurchaseOpen alice "" - snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error final internal" + (at, failure) <- waitStoreReceiptDeferred (chatController alice) since + failure `shouldBe` "service_error final internal" + at `shouldSatisfy` (< addUTCTime 60 since) heldStoreReceipts (chatController alice) `shouldReturn` 1 nothingPurchased cc @@ -1692,8 +1695,7 @@ testPurchaseBadge ps = withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do let purchase = "/_badge purchase 1 " <> paymentArg supporterPlay alice ##> purchase - storePurchaseOpen alice "" - storePurchaseCredited alice "" "1: supporter" + inAnyOrder alice [[openPurchase ""], creditedLines "" "1: supporter"] -- the app hands a purchase over until it is answered credited, and one already credited adds nothing alice ##> purchase alice <## "badge already redeemed" @@ -1708,8 +1710,7 @@ testPurchaseBadgeAppStore ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = FakeStore {appleLegendJWS}} -> withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleLegendJWS}) - storePurchaseOpen alice "" - storePurchaseCredited alice "" "1: legend" + inAnyOrder alice [[openPurchase ""], creditedLines "" "1: legend"] storePayments cc `shouldReturn` [("apple", Just 7000, Just "USD", 1)] testPurchaseStash :: HasCallStack => TestParams -> IO () @@ -1720,8 +1721,7 @@ testPurchaseStash ps = refused = "/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "not-a-purchase") -- the store does not vouch for it, so it can never be credited, and the record says so alice ##> refused - storePurchaseOpen alice "" - alice <## "store purchase settled" + inAnyOrder alice [[openPurchase ""], ["store purchase settled"]] alice ##> refused alice <## "cannot get badge: badge service error: receipt_invalid" records `shouldReturn` 1 @@ -1737,8 +1737,7 @@ testPurchaseStash ps = storePurchaseOpen alice "" snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error retry payment_pending" settlePending store - retryStoreReceiptsAfter alice bsClock 300 - storePurchaseCredited alice "" "1: supporter" + retryStoreReceiptsAfter alice bsClock 300 $ creditedLines "" "1: supporter" records `shouldReturn` 2 heldStoreReceipts (chatController alice) `shouldReturn` 0 rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 @@ -1750,11 +1749,9 @@ testPurchaseStashReceiptUsed ps = withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do let purchase = "/_badge purchase 1 " <> paymentArg supporterPlay alice ##> purchase - storePurchaseOpen alice "" - storePurchaseCredited alice "" "1: supporter" + inAnyOrder alice [[openPurchase ""], creditedLines "" "1: supporter"] bob ##> purchase - storePurchaseOpen bob "" - bob <## "store purchase settled" + inAnyOrder bob [[openPurchase ""], ["store purchase settled"]] bob ##> purchase bob <## "cannot get badge: badge service error: receipt_used" storeReceiptRows (chatController bob) `shouldReturn` [(1, Nothing, True)] @@ -1784,8 +1781,7 @@ testPurchaseWhileBadgeHeld ps = alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) alice <##. "1: supporter" storePurchaseOpen alice "" - (alice withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) - storePurchaseOpen alice "" - storePurchaseCredited alice "" "1: supporter" + inAnyOrder alice [[openPurchase ""], creditedLines "" "1: supporter"] alice ##> "/create user alisa" showActiveUser alice "alisa" -- the store transaction is the device's, so it stays with the profile it was bought under @@ -1820,8 +1815,7 @@ testPurchaseStrandedUnderOtherProfile ps = -- handed over again under whichever profile is active, the purchase stays with the keys alice holds alice ##> unsettled 2 storePurchaseOpen alice "[user: alice] " - retryStoreReceiptsAfter alice bsClock 300 - storePurchaseCredited alice "[user: alice] " "1: supporter" + retryStoreReceiptsAfter alice bsClock 300 $ creditedLines "[user: alice] " "1: supporter" (alice unsettled 2 (alice "/user alice password" @@ -1861,8 +1855,7 @@ testInvoiceOtherProfile ps = alice ##> "/create user alisa" showActiveUser alice "alisa" alice ##> purchaseWithInvoice 2 invoiceId supporterPlay - alice <##. ("[user: alice] store purchase open: invoice " <> invoiceId <> ", transaction ") - storePurchaseCredited alice "[user: alice] " "1: supporter" + inAnyOrder alice [["[user: alice] store purchase open: invoice " <> invoiceId <> ", transaction "], creditedLines "[user: alice] " "1: supporter"] (alice "/user alice" @@ -1874,8 +1867,7 @@ testInvoiceSameReceiptTwice ps = withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do invoiceId <- createInvoice alice 1 alice ##> purchaseWithInvoice 1 invoiceId supporterPlay - alice <##. ("store purchase open: invoice " <> invoiceId <> ", transaction ") - storePurchaseCredited alice "" "1: supporter" + inAnyOrder alice [["store purchase open: invoice " <> invoiceId <> ", transaction "], creditedLines "" "1: supporter"] alice ##> purchaseWithInvoice 1 invoiceId supporterPlay alice <## "badge already redeemed" storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack invoiceId), True)] @@ -1890,8 +1882,7 @@ testInvoiceUnknown ps = -- a reinstall or a second device: the store echoes an invoice this database never created let unknown = "0b6a5e6c-4f3e-4d51-9f55-3a0f7c2f9e11" alice ##> purchaseWithInvoice 2 unknown supporterPlay - alice <##. ("store purchase open: invoice " <> unknown <> ", transaction ") - storePurchaseCredited alice "" "1: supporter" + inAnyOrder alice [["store purchase open: invoice " <> unknown <> ", transaction "], creditedLines "" "1: supporter"] storeReceiptRows (chatController alice) `shouldReturn` [(2, Just (T.pack unknown), True)] testInvoiceLateReceipt :: HasCallStack => TestParams -> IO () @@ -1903,8 +1894,7 @@ testInvoiceLateReceipt ps = alice ##> "/create user alisa" showActiveUser alice "alisa" alice ##> purchaseWithInvoice 2 invoiceId supporterPlay - alice <##. ("[user: alice] store purchase open: invoice " <> invoiceId <> ", transaction ") - storePurchaseCredited alice "[user: alice] " "1: supporter" + inAnyOrder alice [["[user: alice] store purchase open: invoice " <> invoiceId <> ", transaction "], creditedLines "[user: alice] " "1: supporter"] (alice refused) _ <- waitStoreReceiptDeferred (chatController alice) since alice ##> purchaseWithInvoice 1 refused (googlePayment "badge_supporter_01" "not-a-purchase") - alice <## ("store purchase open: invoice " <> unpaid) - alice <##. ("store purchase open: invoice " <> presented <> ", transaction ") - alice <##. ("store purchase open: invoice " <> refused <> ", transaction ") - alice <## "store purchase settled" + inAnyOrder + alice + [ [ "store purchase open: invoice " <> unpaid, + "store purchase open: invoice " <> presented <> ", transaction ", + "store purchase open: invoice " <> refused <> ", transaction " + ], + ["store purchase settled"] + ] -- no age hides a record: one with no receipt and one held stay listed, and only a settled one goes getCurrentTime >>= setClockAt clock . addUTCTime (8 * nominalDay) alice ##> "/_badge state 1" @@ -1957,8 +1951,7 @@ testInvoiceWhileBadgeHeld ps = alice ##> purchaseWithInvoice 1 invoiceId supporterPlay alice <##. "1: supporter" alice <##. ("store purchase open: invoice " <> invoiceId <> ", transaction ") - (alice addUTCTime 290 since) setGoogleDown store False - retryStoreReceiptsAfter alice bsClock 300 - storePurchaseCredited alice "" "1: supporter" + retryStoreReceiptsAfter alice bsClock 300 $ creditedLines "" "1: supporter" rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 testStoreReceiptNotSentEarly :: HasCallStack => TestParams -> IO () @@ -2025,7 +2017,7 @@ testStoreReceiptRetriedDaily ps = storePurchaseOpen alice "" (firstAt, _) <- waitStoreReceiptDeferred (chatController alice) since firstAt `shouldSatisfy` (> addUTCTime (nominalDay - 60) since) - retryStoreReceiptsAfter alice bsClock nominalDay + retryStoreReceiptsAfter alice bsClock nominalDay [] (secondAt, failure) <- waitStoreReceiptDeferred (chatController alice) firstAt failure `shouldBe` "service_error final provider_not_configured" secondAt `shouldSatisfy` (> addUTCTime (nominalDay - 60) firstAt) @@ -2039,8 +2031,7 @@ testStoreRefusalKept ps = do withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do let refused = "/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "not-a-purchase") alice ##> refused - storePurchaseOpen alice "" - alice <## "store purchase settled" + inAnyOrder alice [[openPurchase ""], ["store purchase settled"]] alice ##> refused alice <## "cannot get badge: badge service error: receipt_invalid" alice ##> "/_badge state 1" @@ -2058,9 +2049,11 @@ testStoreSettledOtherProfile ps = showActiveUser alice "alisa" -- the invoice makes alice the owner, so the hand-over's answer and the settlement are hers alice ##> purchaseWithInvoice 2 shown (googlePayment "badge_supporter_01" "not-a-purchase") - alice <##. ("[user: alice] store purchase open: invoice " <> shown <> ", transaction ") - alice <## ("store purchase open: invoice " <> hidden) - alice <## "[user: alice] store purchase settled" + inAnyOrder + alice + [ ["[user: alice] store purchase open: invoice " <> shown <> ", transaction ", "store purchase open: invoice " <> hidden], + ["[user: alice] store purchase settled"] + ] alice ##> "/_hide user 1 \"password\"" alice <## "user alice:" alice <## "messages are hidden (use /tail to view)" @@ -2077,7 +2070,7 @@ testStoreReceiptTwoAtOnce ps = withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do let handOver = void $ sendChatCmdStr (chatController alice) ("/_badge purchase 1 " <> paymentArg supporterPlay) concurrentlyN_ [handOver, handOver] - storePurchaseCredited alice "" "1: supporter" + mapM_ (alice <##.) $ creditedLines "" "1: supporter" (alice do unpaid <- createInvoice alice 1 alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "not-a-purchase")) - alice <## ("store purchase open: invoice " <> unpaid) - storePurchaseOpen alice "" - alice <## "store purchase settled" + inAnyOrder alice [["store purchase open: invoice " <> unpaid, openPurchase ""], ["store purchase settled"]] since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googleUnreachableToken)) alice <## ("store purchase open: invoice " <> unpaid) storePurchaseOpen alice "" _ <- waitStoreReceiptDeferred (chatController alice) since alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS}) - alice <## ("store purchase open: invoice " <> unpaid) - storePurchaseOpen alice "" - storePurchaseOpen alice "" - storePurchaseCredited alice "" "1: supporter" + inAnyOrder alice [["store purchase open: invoice " <> unpaid, openPurchase "", openPurchase ""], creditedLines "" "1: supporter"] storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack unpaid), False), (1, Nothing, True), (1, Nothing, True), (1, Nothing, True)] -- a month on, the record no receipt reached and the refusal go; the credited and the held one stay testClockTime bsClock >>= setClockAt bsClock . addUTCTime (31 * nominalDay) + -- the move also ends the badge credited above; whether its worker wakes alone or on this signal, its lines are read here + alice `send` "/_app activate" + inAnyOrder alice [["/_app activate"], ["ok"], ["badge alert: support_ended "], ["1: supporter", "badge alert: support_ended "]] waitStoreReceiptRows (chatController alice) 2 `shouldReturn` [(1, Nothing, True), (1, Nothing, True)] heldStoreReceipts (chatController alice) `shouldReturn` 1 -- a receipt for the deleted invoice now arrives with no record to name its profile, so the presenting one gets it @@ -2128,7 +2119,7 @@ testStoreReceiptAttemptThrows ps = do verifications `shouldReturn` 1 -- a stored payment this version cannot read makes the attempt throw before anything is sent setStoreReceiptPayment (chatController alice) "not a payment" - retryStoreReceiptsAfter alice bsClock 300 + retryStoreReceiptsAfter alice bsClock 300 [] (secondAt, failure) <- waitStoreReceiptDeferred (chatController alice) firstAt failure `shouldBe` "unexpected held store payment does not decode" secondAt `shouldSatisfy` (> addUTCTime (nominalDay - 60) firstAt) @@ -2161,10 +2152,13 @@ waitStoreReceiptRows cc n = loop (100 :: Int) rows <- storeReceiptRows cc if length rows == n then pure rows else threadDelay 50000 >> loop (i - 1) -storeReceiptErrors :: ChatController -> IO [Maybe Text] -storeReceiptErrors ChatController {chatStore} = +-- | The receipts the owner's worker could select, and when it would wake for them. Read two days ahead, so +-- a receipt the worker has already deferred by a day is still counted. +selectableStoreReceipts :: ChatController -> Int64 -> IO (Int, Maybe UTCTime) +selectableStoreReceipts ChatController {chatStore} userId = do + later <- addUTCTime (2 * nominalDay) <$> getCurrentTime withTransaction chatStore $ \db -> - map fromOnly <$> DB.query_ db "SELECT credit_error FROM badge_store_receipts ORDER BY badge_store_receipt_id" + (,) <$> (length <$> getDueStoreReceipts db userId later) <*> getNextStoreReceiptAttempt db userId heldStoreReceipts :: ChatController -> IO Int heldStoreReceipts ChatController {chatStore} = @@ -2197,12 +2191,28 @@ setStoreReceiptPayment ChatController {chatStore} payment = withTransaction chatStore $ \db -> DB.execute db "UPDATE badge_store_receipts SET payment = ?" (Only payment) -- | Moves the badge clock past a deferred receipt's next attempt, and signals the worker as the app's --- return to the foreground does. -retryStoreReceiptsAfter :: HasCallStack => TestCC -> TestClock -> NominalDiffTime -> IO () -retryStoreReceiptsAfter cc clock wait = do +-- return to the foreground does; the events the worker prints may come before or after the "ok". +retryStoreReceiptsAfter :: HasCallStack => TestCC -> TestClock -> NominalDiffTime -> [String] -> IO () +retryStoreReceiptsAfter cc clock wait events = do testClockTime clock >>= setClockAt clock . addUTCTime (wait + 1) cc ##> "/_app activate" - cc <## "ok" + inAnyOrder cc $ ["ok"] : [events | not (null events)] + +-- | Each block's lines in order, the blocks in any order: the worker is signalled before the command that +-- signalled it has answered, so its events can print first. Every line is matched as a prefix. +inAnyOrder :: HasCallStack => TestCC -> [[String]] -> IO () +inAnyOrder _ [] = pure () +inAnyOrder cc blocks = do + line <- getTermLine cc + case break (startsWith line) blocks of + (earlier, (_ : rest) : others) -> do + mapM_ (cc <##.) rest + inAnyOrder cc (earlier <> others) + _ -> error $ "expected a line starting one of " <> show blocks <> ", got " <> show line + where + startsWith l = \case + start : _ -> start `isPrefixOf` l + [] -> False -- | Counts the Google verifications the service makes, re-arming the one-shot hook each time. countGoogleVerifications :: IORef (IO ()) -> IO (IO Int) @@ -2213,10 +2223,11 @@ countGoogleVerifications hook = do pure $ readIORef n storePurchaseOpen :: HasCallStack => TestCC -> String -> IO () -storePurchaseOpen cc userPrefix = cc <##. (userPrefix <> "store purchase open: invoice none, transaction ") +storePurchaseOpen cc userPrefix = cc <##. openPurchase userPrefix + +openPurchase :: String -> String +openPurchase userPrefix = userPrefix <> "store purchase open: invoice none, transaction " -- | The worker's credit as the owner's terminal shows it: the badge, then the settlement. -storePurchaseCredited :: HasCallStack => TestCC -> String -> String -> IO () -storePurchaseCredited cc userPrefix badge = do - cc <##. (userPrefix <> badge) - cc <## (userPrefix <> "store purchase settled") +creditedLines :: String -> String -> [String] +creditedLines userPrefix badge = [userPrefix <> badge, userPrefix <> "store purchase settled"]