diff --git a/apps/ios/Shared/Views/Badges/BadgeStore.swift b/apps/ios/Shared/Views/Badges/BadgeStore.swift index 696ed7c29c..6237c49740 100644 --- a/apps/ios/Shared/Views/Badges/BadgeStore.swift +++ b/apps/ios/Shared/Views/Badges/BadgeStore.swift @@ -109,8 +109,8 @@ final class BadgeStore: ObservableObject { // kept for this run only: StoreKit lists no deferred purchase, and a declined one delivers nothing // by invoice id, so a pending purchase shows only under the profile whose record it names @Published private var waitingForApproval: Set = [] - // set when the first sweep has returned, which is after every transaction the store holds was handed - // to core - until then a purchase made while the app was not running is unknown + // set once presentUnfinished has read the store: until then, an Ask to Buy approved while the app was + // closed, or a purchase it died before handing over, are both unknown, so canBuy refuses to buy again @Published private var reconciledOnce = false // purchases the user started this run, by transaction: the store is not relied on to echo the invoice back private var awaitedTransactions: Set = [] diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt index f292da605c..881ee9c1f9 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/badges/BadgeStore.kt @@ -156,8 +156,8 @@ object BadgeStore { private val buying = mutableStateOf(false) // by invoice id, so a pending purchase shows only under the profile whose record it names private val waitingForApproval = mutableStateOf>(emptySet()) - // set when the first sweep has returned or failed, which is after every purchase the store holds was handed - // to core - until then a purchase made while the app was not running is unknown + // set once presentUnfinished has read the store, or failed to: until then, a slow payment completed while + // the app was closed, or a purchase it died before handing over, are both unknown, so canBuy refuses private val reconciledOnce = mutableStateOf(false) // purchases the user started this run, by token: the store is not relied on to echo the invoice back private val awaitedTransactions = mutableSetOf() diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index c2da292ef6..b7562f9f13 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -294,6 +294,11 @@ data BadgeWorker = BadgeWorker badgeWork :: TMVar () } +data StoreReceiptWorker = StoreReceiptWorker + { receiptWorker :: Worker, + parkedReceipts :: TVar (Set Int64) + } + data ChatController = ChatController { currentUser :: TVar (Maybe User), randomPresetServers :: NonEmpty PresetOperator, @@ -328,7 +333,7 @@ data ChatController = ChatController relayRequestWorkers :: TMap Int Worker, -- single global worker with key 1 is used to fit into existing worker management framework -- one badge worker per user: badge state is per profile, and one profile must not stall another badgeWorkers :: TMap UserId (SessionVar BadgeWorker), - storeReceiptWorkers :: TMap UserId (SessionVar BadgeWorker), + storeReceiptWorkers :: TMap UserId StoreReceiptWorker, badgeSeq :: TVar Int, relayGroupLinkChecksAsync :: TVar (Maybe (Async ())), webPreviewState :: Maybe WebPreviewState, diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 01a84cee7a..fd8667cbbc 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -105,9 +105,10 @@ import qualified Simplex.Chat.Util as U import Simplex.Chat.Web (webPreviewWorker) import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSizeHard) import Simplex.Messaging.Agent -import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles) +import Simplex.Messaging.Agent.Client (getAgentWorker', hasWorkToDo, waitForUserNetwork, waitForWork, waitWhileSuspended, withWork_) +import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), Worker (..), allRoles) import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay, withRetryInterval) +import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), withRetryInterval) import Simplex.Messaging.Agent.Store.Entity import Simplex.Messaging.Agent.Store.Interface (execSQL) import Simplex.Messaging.Agent.Store.Shared (upMigration) @@ -263,7 +264,7 @@ startChatController mainApp enableSndFiles serviceRequests = do startRelayRequestWorker_ startCleanupManager mapM_ startBadgeWork users - mapM_ startStoreReceiptWork users + startStoreReceiptWorkers users void $ forkIO $ mapM_ startExpireCIs users startRelayChecks users startWebPreview users @@ -282,6 +283,10 @@ startChatController mainApp enableSndFiles serviceRequests = do runExceptT startRelayRequestWorker >>= \case Left e -> liftIO $ putStrLn $ "Error starting relay request worker: " <> show e Right _ -> pure () + startStoreReceiptWorkers users = + runExceptT (mapM_ startStoreReceiptWork users) >>= \case + Left e -> liftIO $ putStrLn $ "Error starting store receipt workers: " <> show e + Right _ -> pure () startCleanupManager = do cleanupAsync <- asks cleanupManagerAsync readTVarIO cleanupAsync >>= \case @@ -374,7 +379,7 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, clearMap deliveryJobWorkers >>= mapM_ cancelWorker clearMap relayRequestWorkers >>= mapM_ cancelWorker stopBadgeWorkers badgeWorkers - stopBadgeWorkers storeReceiptWorkers + clearMap storeReceiptWorkers >>= mapM_ (cancelWorker . receiptWorker) closeFiles sndFiles closeFiles rcvFiles atomically $ do @@ -607,7 +612,7 @@ processChatCommand cxt nm = \case void . forkIO $ startFilesToReceive users setAllExpireCIFlags True mapM_ startBadgeWork users - mapM_ startStoreReceiptWork users + mapM_ startStoreReceiptWork users ok_ APISuspendChat t -> do chatWriteVar chatActivated False @@ -5269,9 +5274,9 @@ handOverStoreReceipt presentingUser echoedInvoiceId payment = do (StoreReceipt {ownerId, status}, newlyHeld) <- withStore' (\db -> holdStoreReceipt db g presentingUser echoedInvoiceId txRef payment now) >>= maybe (throwChatError $ CEInternalError "store receipt was not recorded") pure - owner <- withStore $ \db -> getUser db ownerId -- before the answer, which can throw: no later hand-over of this receipt signals, and a spare signal costs an empty pass - when newlyHeld $ lift $ startStoreReceiptWork owner + when newlyHeld $ lift $ resumeStoreReceiptWork ownerId + owner <- withStore $ \db -> getUser db ownerId case status of RSHeld -> badgeStateResponse owner RSCredited {badgePurchaseId} -> do @@ -5348,23 +5353,20 @@ badgeNow = asks (badgeCurrentTime . config) >>= liftIO -- | A signal carries nothing: each pass derives its work from stored state, so a signal lost or -- duplicated changes no outcome. startBadgeWork :: User -> CM' () -startBadgeWork user = whenM (isJust <$> asks (badgeServiceAddress . config)) $ void $ getBadgeWorker badgeWorkers runBadgeWorker user - -startStoreReceiptWork :: User -> CM' () -startStoreReceiptWork user = whenM (isJust <$> asks (badgeServiceAddress . config)) $ void $ getBadgeWorker storeReceiptWorkers runStoreReceiptWorker user +startBadgeWork user = whenM (isJust <$> asks (badgeServiceAddress . config)) $ void $ getBadgeWorker user -- | Exactly one caller starts the thread and the rest wait for it: the lookup and the create cannot -- be one transaction, because starting a thread is not STM. -getBadgeWorker :: (ChatController -> TM.TMap UserId (SessionVar BadgeWorker)) -> (UserId -> TMVar () -> CM ()) -> User -> CM' BadgeWorker -getBadgeWorker workers runWorker User {userId} = do - ws <- asks workers +getBadgeWorker :: User -> CM' BadgeWorker +getBadgeWorker User {userId} = do + ws <- asks badgeWorkers seq' <- asks badgeSeq now <- liftIO getCurrentTime withGetSessVar' seq' userId ws now startWorker signalWorker where startWorker v = do badgeWork <- newEmptyTMVarIO - badgeWorkerAsync <- async $ void $ runExceptT $ runWorker userId badgeWork + badgeWorkerAsync <- async $ void $ runExceptT $ runBadgeWorker userId badgeWork let w = BadgeWorker {badgeWorkerAsync, badgeWork} w <$ atomically (putTMVar (sessionVar v) w) signalWorker v = do @@ -5434,46 +5436,74 @@ waitBadgeWake badgeWork now = \case badgeMaxWake :: NominalDiffTime badgeMaxWake = 100 * 365 * nominalDay --- | The only sender of held store receipts; each row's next_attempt_at is when it is tried again. The --- wait is floored, so a row still due because its outcome could not be written does not spin the worker. -runStoreReceiptWorker :: UserId -> TMVar () -> CM () -runStoreReceiptWorker userId work = forever $ do - lift waitChatStartedAndActivated - nextAt_ <- creditStoreReceipts userId `catchAllErrors` \e -> eToView e >> Just <$> badgeNow - now <- badgeNow - ri <- asks $ badgeRetryInterval . config - liftIO $ waitBadgeWake work now $ max (retryFloor ri `addUTCTime` now) <$> nextAt_ +startStoreReceiptWork :: User -> CM () +startStoreReceiptWork User {userId} = do + due <- withStore' $ \db -> getNextDueStoreReceipt db userId S.empty + when (either (const False) isJust due) $ lift $ resumeStoreReceiptWork userId --- | The due rows are read once, so a pass tries each at most once. -creditStoreReceipts :: UserId -> CM (Maybe UTCTime) -creditStoreReceipts userId = do - now <- badgeNow - due <- withStore' $ \db -> getDueStoreReceipts db userId now - forM_ due $ \r -> creditStoreReceipt userId r `catchAllErrors` eToView - withStore' (`getNextStoreReceiptAttempt` userId) +resumeStoreReceiptWork :: UserId -> CM' () +resumeStoreReceiptWork userId = do + StoreReceiptWorker {receiptWorker, parkedReceipts} <- getStoreReceiptWorker userId + atomically $ writeTVar parkedReceipts S.empty >> hasWorkToDo receiptWorker -data StoreReceiptOutcome = SROCredited (Maybe User) | SRORefused | SRODeferred +getStoreReceiptWorker :: UserId -> CM' StoreReceiptWorker +getStoreReceiptWorker userId = do + ws <- asks storeReceiptWorkers + a <- asks smpAgent + getAgentWorker' receiptWorker newStoreReceiptWorker "store_receipt" False a userId ws $ + runStoreReceiptWorker a userId + where + newStoreReceiptWorker w = StoreReceiptWorker w <$> newTVar S.empty + +runStoreReceiptWorker :: AgentClient -> UserId -> StoreReceiptWorker -> CM () +runStoreReceiptWorker a userId StoreReceiptWorker {receiptWorker = Worker {doWork}, parkedReceipts} = + forever $ do + lift $ waitForWork doWork + withWork_ a doWork getNextReceipt $ \r@HeldStoreReceipt {receiptId} -> + (creditStoreReceipt a userId r `catchAllErrors` \e -> False <$ eToView e) >>= \case + True -> pure () + -- unlike the agent's workers, a final failure keeps the row: the purchase is paid for, so the next trigger tries it again + False -> atomically $ modifyTVar' parkedReceipts $ S.insert receiptId + where + getNextReceipt = do + parked <- readTVarIO parkedReceipts + withStore' $ \db -> getNextDueStoreReceipt db userId parked + +data StoreReceiptOutcome = SROCredited (Maybe User) | SRORefused | SRORetry (Maybe Word32) | SROFailed -- | Under the owner's badge lock, which keeps a profile's requests to the service serial. -creditStoreReceipt :: UserId -> HeldStoreReceipt -> CM () -creditStoreReceipt userId HeldStoreReceipt {receiptId, stash = stash@BadgeStash {masterKey}, payment, retryDelay} = do - outcome <- withEntityLock "badgePurchase" (CLBadgeUser userId) $ - tryAllErrors attempt >>= \case - Right (Right (present_, _)) -> pure $ SROCredited present_ - Right (Left (code, retryAfter)) - | storeReceiptRefused code -> SRORefused <$ withStore' (\db -> refuseStoreReceipt db receiptId $ serviceFailure code retryAfter) - | otherwise -> SRODeferred <$ defer (serviceFailure code retryAfter) retryAfter - Left e -> SRODeferred <$ defer (badgeIssueFailure e) Nothing - -- only a settlement is announced, and the app's sweep in answer signals this worker only for a newly held receipt, so it cannot loop - case outcome of - SROCredited present_ -> do - user <- withStore $ \db -> getUser db userId - toView . CEvtBadgeChanged user =<< getUserBadgeState user - toView $ CEvtStorePurchaseSettled user - -- last, so a failed broadcast cannot lose the settlement; outside the badge lock, as it takes the chat lock - mapM_ presentUserBadgeToContacts present_ - SRORefused -> withStore (`getUser` userId) >>= toView . CEvtStorePurchaseSettled - SRODeferred -> pure () +creditStoreReceipt :: AgentClient -> UserId -> HeldStoreReceipt -> CM Bool +creditStoreReceipt a userId HeldStoreReceipt {receiptId, stash = stash@BadgeStash {masterKey}, payment, retryDelay} = do + ri <- asks $ badgeRetryInterval . config + notBefore <- newTVarIO Nothing + withRetryInterval (maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) retryDelay) $ \delay loop -> do + liftIO $ waitWhileSuspended a + liftIO $ waitForUserNetwork a + now <- badgeNow + readTVarIO notBefore >>= \case + Just at | now < at -> loop + _ -> do + outcome <- withEntityLock "badgePurchase" (CLBadgeUser userId) $ + tryAllErrors attempt >>= \case + Right (Right (present_, _)) -> pure $ SROCredited present_ + Right (Left (code, retryAfter)) + | storeReceiptRefused code -> SRORefused <$ withStore' (\db -> refuseStoreReceipt db receiptId $ serviceFailure code retryAfter) + | otherwise -> failed delay (serviceFailure code retryAfter) retryAfter + Left e -> failed delay (badgeIssueFailure e) Nothing + -- only a settlement is announced, and the app's sweep in answer signals this worker only for a newly held receipt, so it cannot loop + case outcome of + SROCredited present_ -> do + user <- withStore $ \db -> getUser db userId + toView . CEvtBadgeChanged user =<< getUserBadgeState user + toView $ CEvtStorePurchaseSettled user + -- last, so a failed broadcast cannot lose the settlement; outside the badge lock, as it takes the chat lock + mapM_ presentUserBadgeToContacts present_ + pure True + SRORefused -> True <$ (withStore (`getUser` userId) >>= toView . CEvtStorePurchaseSettled) + SRORetry retryAfter_ -> do + atomically $ writeTVar notBefore $ (`addUTCTime` now) . fromIntegral <$> retryAfter_ + loop + SROFailed -> pure False where attempt = do user <- withStore $ \db -> getUser db userId @@ -5482,21 +5512,9 @@ creditStoreReceipt userId HeldStoreReceipt {receiptId, stash = stash@BadgeStash payment' <- maybe (throwChatError $ CEInternalError "held store payment does not decode") pure $ decodeJSON payment requestBadgeStash NRMBackground user sendTarget stash BSCPurchaseBadge {masterKey, payment = payment', upgrade = Nothing} serviceFailure code retryAfter = BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter} - defer failure retryAfter = do - ri <- asks $ badgeRetryInterval . config - now <- badgeNow - let (delay, retryDelay') = storeReceiptRetry ri failure retryAfter retryDelay - withStore' $ \db -> deferStoreReceipt db receiptId (delay `addUTCTime` now) retryDelay' failure - --- | The service's retryAfter when given; otherwise a failure that can clear grows its own delay, and any --- other waits a day. Unlike a renewal, an answered internal grows too: a buyer is watching the purchase. -storeReceiptRetry :: RetryInterval -> BadgeIssueFailure -> Maybe Word32 -> Maybe Int64 -> (NominalDiffTime, Maybe Int64) -storeReceiptRetry ri@RetryInterval {initialInterval} failure retryAfter retryDelay - | isJust retryAfter = (badgeRetryAfter ri retryAfter, retryDelay) - | badgeFailureTransient failure = (fromIntegral delay / 1000000, Just delay) - | otherwise = (badgeStalledInterval, retryDelay) - where - delay = maybe initialInterval (\d -> nextRetryDelay 0 d ri) retryDelay + failed delay failure retryAfter = do + withStore' $ \db -> recordStoreReceiptFailure db receiptId delay failure + pure $ if badgeFailureTransient failure then SRORetry retryAfter else SROFailed -- | Retire what has ended, renew what is due, then report the next wake. Waking early, late or not -- at all changes only timing: each run reads stored state and works out what to do. diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 65be54b2fe..51109d19f6 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -26,9 +26,8 @@ module Simplex.Chat.Store.Badges holdStoreReceipt, createBadgeStoreReceipt, getOpenStorePurchases, - getDueStoreReceipts, - getNextStoreReceiptAttempt, - deferStoreReceipt, + getNextDueStoreReceipt, + recordStoreReceiptFailure, refuseStoreReceipt, deleteUnfundedStoreReceipts, deleteBadgeCodeRedemption, @@ -50,7 +49,10 @@ import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) +import Data.List (find) import Data.Maybe (isJust, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as S import Data.Text (Text) import Data.Time.Clock (UTCTime) import Simplex.Chat.Badges @@ -59,7 +61,7 @@ import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..), OpenStorePurchase (..)) import Simplex.Chat.PaymentService (ServicePayment) import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..)) -import Simplex.Chat.Store.Shared (insertedRowId) +import Simplex.Chat.Store.Shared (StoreError, insertedRowId) import Simplex.Chat.Types import Simplex.Messaging.Agent.Protocol (UserId) import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) @@ -139,8 +141,8 @@ holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provid forM_ invoiceId_ $ \invoiceId -> DB.execute db - "UPDATE badge_store_receipts SET provider = ?, transaction_ref = ?, payment = ?, next_attempt_at = ? WHERE invoice_id = ? AND transaction_ref IS NULL" - (provider, transactionRef, paymentJSON, now, invoiceId) + "UPDATE badge_store_receipts SET provider = ?, transaction_ref = ?, payment = ? WHERE invoice_id = ? AND transaction_ref IS NULL" + (provider, transactionRef, paymentJSON, invoiceId) getStoreReceipt db txRef >>= \case Just r -> pure $ Just (r, True) Nothing -> do @@ -160,11 +162,11 @@ holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provid db [sql| INSERT INTO badge_store_receipts - (user_id, invoice_id, provider, transaction_ref, payment, next_attempt_at, purchase_key, purchase_priv_key, master_key, created_at) - VALUES (?,?,?,?,?,?,?,?,?,?) + (user_id, invoice_id, provider, transaction_ref, payment, purchase_key, purchase_priv_key, master_key, created_at) + VALUES (?,?,?,?,?,?,?,?,?) ON CONFLICT DO NOTHING |] - ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, now)) + ((userId, invoiceId', provider, transactionRef, paymentJSON) :. (purchaseKey, purchasePrivKey, Binary mk, now)) -- | held is a CASE because in Postgres a comparison is boolean, which BoolInt rejects. getStoreReceipt :: DB.Connection -> StoreTransactionRef -> IO (Maybe StoreReceipt) @@ -219,48 +221,35 @@ data HeldStoreReceipt = HeldStoreReceipt retryDelay :: Maybe Int64 } --- | Due only from next_attempt_at, so a pass a signal starts cannot send a deferred receipt early. -getDueStoreReceipts :: DB.Connection -> UserId -> UTCTime -> IO [HeldStoreReceipt] -getDueStoreReceipts db userId now = - map toHeld +getNextDueStoreReceipt :: DB.Connection -> UserId -> Set Int64 -> IO (Either StoreError (Maybe HeldStoreReceipt)) +getNextDueStoreReceipt db userId parked = + Right . find notParked . map toHeld <$> DB.query db [sql| SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.payment, r.retry_delay FROM badge_store_receipts r JOIN users u ON u.user_id = r.user_id - WHERE r.user_id = ? AND r.payment IS NOT NULL AND r.next_attempt_at <= ? AND u.shown_badge_id IS NULL - ORDER BY r.next_attempt_at + WHERE r.user_id = ? AND r.payment IS NOT NULL AND u.shown_badge_id IS NULL + ORDER BY r.badge_store_receipt_id |] - (userId, now) + (Only userId) where + notParked HeldStoreReceipt {receiptId} = receiptId `S.notMember` parked toHeld (stashRow@(receiptId, _, _, _) :. (payment, retryDelay)) = HeldStoreReceipt {receiptId, stash = toBadgeStash BSRStoreReceipt stashRow, payment, retryDelay} -getNextStoreReceiptAttempt :: DB.Connection -> UserId -> IO (Maybe UTCTime) -getNextStoreReceiptAttempt db userId = - fmap join . maybeFirstRow fromOnly $ - DB.query - db - [sql| - SELECT MIN(r.next_attempt_at) - FROM badge_store_receipts r - JOIN users u ON u.user_id = r.user_id - WHERE r.user_id = ? AND r.payment IS NOT NULL AND u.shown_badge_id IS NULL - |] - (Only userId) - -deferStoreReceipt :: DB.Connection -> Int64 -> UTCTime -> Maybe Int64 -> BadgeIssueFailure -> IO () -deferStoreReceipt db receiptId nextAttemptAt retryDelay failure = +recordStoreReceiptFailure :: DB.Connection -> Int64 -> Int64 -> BadgeIssueFailure -> IO () +recordStoreReceiptFailure db receiptId retryDelay failure = DB.execute db - "UPDATE badge_store_receipts SET next_attempt_at = ?, retry_delay = ?, credit_error = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL" - (nextAttemptAt, retryDelay, failure, receiptId) + "UPDATE badge_store_receipts SET retry_delay = ?, credit_error = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL" + (retryDelay, failure, receiptId) -- | Kept rather than deleted, so that a later hand-over of the same transaction is answered from the record. refuseStoreReceipt :: DB.Connection -> Int64 -> BadgeIssueFailure -> IO () refuseStoreReceipt db receiptId refusal = - DB.execute db "UPDATE badge_store_receipts SET payment = NULL, credit_error = ? WHERE badge_store_receipt_id = ?" (refusal, receiptId) + DB.execute db "UPDATE badge_store_receipts SET payment = NULL, retry_delay = NULL, credit_error = ? WHERE badge_store_receipt_id = ?" (refusal, receiptId) -- | A held record is paid for and a credited one is referenced by its purchase, so neither is deleted. deleteUnfundedStoreReceipts :: DB.Connection -> UTCTime -> IO () @@ -296,7 +285,7 @@ deleteBadgeCodeRedemption db User {userId} code = createStashBadgePurchase :: DB.Connection -> User -> BadgeStash -> BadgeCredential -> UTCTime -> IO (Int64, Bool) createStashBadgePurchase db User {userId} stash credential now = do -- the credit settles a held receipt in the transaction that stores its purchase, a replay included - forM_ storeReceiptId_ $ \storeReceiptId -> DB.execute db "UPDATE badge_store_receipts SET payment = NULL WHERE badge_store_receipt_id = ?" (Only storeReceiptId) + forM_ storeReceiptId_ $ \storeReceiptId -> DB.execute db "UPDATE badge_store_receipts SET payment = NULL, retry_delay = NULL WHERE badge_store_receipt_id = ?" (Only storeReceiptId) getStashBadgePurchase db stash >>= \case Just purchaseId -> pure (purchaseId, False) Nothing -> do diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs index cc76061291..f05860882d 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs @@ -24,7 +24,6 @@ CREATE TABLE badge_store_receipts( master_key BYTEA NOT NULL, created_at TIMESTAMPTZ NOT NULL, payment TEXT, - next_attempt_at TIMESTAMPTZ, retry_delay BIGINT, credit_error TEXT, UNIQUE(provider, transaction_ref) diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql index 37266af7fa..6e808cacad 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql @@ -307,7 +307,6 @@ CREATE TABLE test_chat_schema.badge_store_receipts ( master_key bytea NOT NULL, created_at timestamp with time zone NOT NULL, payment text, - next_attempt_at timestamp with time zone, retry_delay bigint, credit_error text ); diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs index 4595e95cea..2a7b50de50 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs @@ -23,7 +23,6 @@ CREATE TABLE badge_store_receipts( master_key BLOB NOT NULL, created_at TEXT NOT NULL, payment TEXT, - next_attempt_at TEXT, retry_delay INTEGER, credit_error TEXT, UNIQUE(provider, transaction_ref) diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index 5721eec897..1dc47afd1f 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -993,7 +993,6 @@ CREATE TABLE badge_store_receipts( master_key BLOB NOT NULL, created_at TEXT NOT NULL, payment TEXT, - next_attempt_at TEXT, retry_delay INTEGER, credit_error TEXT, UNIQUE(provider, transaction_ref) diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index a0e054b4b9..c8101f86b4 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -18,7 +18,7 @@ import BadgeService.Options import BadgeService.Service import BadgeService.Store (NewStorePurchase (..), createStorePurchase) import BadgeService.Store.Invoices (markCodePaid) -import BadgeService.StoreReceipts (StoreVerifier, noStoreVerifier) +import BadgeService.StoreReceipts (StoreRefusal (..), StoreVerifier (..), noStoreVerifier) import Simplex.Messaging.Agent.Store.DB (Binary (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import ChatClient @@ -39,6 +39,7 @@ import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) import Data.List (isPrefixOf, stripPrefix) import qualified Data.Map.Strict as M import Data.Maybe (isJust, isNothing) +import qualified Data.Set as S import Data.String (fromString) import System.Timeout (timeout) import Data.Text (Text) @@ -57,7 +58,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.Chat.Store.Badges (getNextDueStoreReceipt) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) import Simplex.Messaging.Agent.Store.Common (withTransaction) @@ -153,14 +154,13 @@ badgeServiceTests = do it "should refuse an invoice with no service configured or while a badge is held, creating no record" testInvoiceRefusedBeforeCharge it "should hold a receipt for an invoice while a badge is held, without attempting it" testInvoiceWhileBadgeHeld it "should list only the asking profile's open store purchases" testInvoiceStateOtherProfile - it "should credit a receipt the store could not verify once its retryAfter has passed, with no second hand-over" testStoreReceiptRetried - it "should send nothing for a deferred receipt handed over again before it is due" testStoreReceiptNotSentEarly - it "should retry a receipt with no verifier a day later, and never drop it" testStoreReceiptRetriedDaily + it "should credit a receipt the store could not verify once its retryAfter has passed, with no trigger at all" testStoreReceiptRetried + it "should keep a receipt with no verifier held, and attempt it again only on the next trigger" testStoreReceiptRetriedOnTrigger it "should answer a refused receipt from the record, sending nothing, and not list it" testStoreRefusalKept it "should announce a settlement to an owner that is not active, and print nothing for a hidden one" testStoreSettledOtherProfile it "should resolve one new transaction handed over twice at once to one record" testStoreReceiptTwoAtOnce it "should delete a month-old record that will fund no badge, and keep held and credited ones" testStoreReceiptCleanup - it "should defer a receipt whose attempt throws, and not send it again in the pass" testStoreReceiptAttemptThrows + it "should keep a receipt whose attempt throws, sending nothing" testStoreReceiptAttemptThrows badgeProfile :: Profile badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} @@ -1592,32 +1592,28 @@ testStoreVerifiedOtherTransaction ps = testStoreQuantityRefused :: HasCallStack => TestParams -> IO () testStoreQuantityRefused ps = - withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = FakeStore {appleQuantityJWS}} -> do + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = FakeStore {appleQuantityJWS}} -> do (purchaseKey, masterKey) <- newPurchaseKeys refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey SPApple {jws = appleQuantityJWS}) `shouldReturn` (BSEInternal, Nothing) nothingPurchased cc withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do - since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleQuantityJWS}) storePurchaseOpen alice "" - (at, failure) <- waitStoreReceiptDeferred (chatController alice) since - failure `shouldBe` "service_error final internal" - at `shouldSatisfy` (< addUTCTime 60 since) + waitStoreReceiptError (chatController alice) "service_error final internal" heldStoreReceipts (chatController alice) `shouldReturn` 1 nothingPurchased cc testPurchaseWithNoVerifier :: HasCallStack => TestParams -> IO () testPurchaseWithNoVerifier ps = - withBadgeServiceVerifier ps (const noStoreVerifier) $ \env@BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc} -> do + withBadgeServiceVerifier ps (const noStoreVerifier) $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc} -> do (purchaseKey, masterKey) <- newPurchaseKeys refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey supporterPlay) `shouldReturn` (BSEProviderNotConfigured, Nothing) nothingPurchased cc withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do - since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) storePurchaseOpen alice "" -- not yet rather than never, so the receipt stays held for the retry once a verifier is deployed - snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error final provider_not_configured" + waitStoreReceiptError (chatController alice) "service_error final provider_not_configured" heldStoreReceipts (chatController alice) `shouldReturn` 1 alice ##> "/_badge state 1" alice .<## ", not credited: service_error final provider_not_configured" @@ -1716,7 +1712,7 @@ testPurchaseBadgeAppStore ps = testPurchaseStash :: HasCallStack => TestParams -> IO () testPurchaseStash ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} -> - withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do let records = rowCount (chatController alice) "badge_store_receipts" 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 @@ -1732,12 +1728,12 @@ testPurchaseStash ps = records `shouldReturn` 1 nothingPurchased cc -- pending keeps the receipt held, and the settled purchase is credited to its keys, once - since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken)) storePurchaseOpen alice "" - snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error retry payment_pending" + waitStoreReceiptError (chatController alice) "service_error retry payment_pending" settlePending store - retryStoreReceiptsAfter alice bsClock 300 $ creditedLines "" "1: supporter" + passRetryAfter bsClock + mapM_ (alice <##.) $ creditedLines "" "1: supporter" records `shouldReturn` 2 heldStoreReceipts (chatController alice) `shouldReturn` 0 rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 @@ -1763,12 +1759,11 @@ testPurchaseStashReceiptUsed ps = testPurchaseUnsentPlayToken :: HasCallStack => TestParams -> IO () testPurchaseUnsentPlayToken ps = - withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc} -> + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do - since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "token/other")) storePurchaseOpen alice "" - snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error retry provider_unavailable" + waitStoreReceiptError (chatController alice) "service_error retry provider_unavailable" heldStoreReceipts (chatController alice) `shouldReturn` 1 nothingPurchased cc @@ -1781,7 +1776,7 @@ testPurchaseWhileBadgeHeld ps = alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) alice <##. "1: supporter" storePurchaseOpen alice "" - selectableStoreReceipts (chatController alice) 1 `shouldReturn` (0, Nothing) + storeReceiptDue (chatController alice) 1 `shouldReturn` False heldStoreReceipts (chatController alice) `shouldReturn` 1 rowCount cc "sx_badge_service_payments" `shouldReturn` 0 @@ -1803,19 +1798,19 @@ testPurchaseSameReceiptOtherProfile ps = testPurchaseStrandedUnderOtherProfile :: HasCallStack => TestParams -> IO () testPurchaseStrandedUnderOtherProfile ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} -> - withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do let unsettled userId = "/_badge purchase " <> show (userId :: Int) <> " " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken) - since <- testClockTime bsClock alice ##> unsettled 1 storePurchaseOpen alice "" - _ <- waitStoreReceiptDeferred (chatController alice) since + waitStoreReceiptError (chatController alice) "service_error retry payment_pending" alice ##> "/create user alisa" showActiveUser alice "alisa" settlePending store -- 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 $ creditedLines "[user: alice] " "1: supporter" + passRetryAfter bsClock + mapM_ (alice <##.) $ creditedLines "[user: alice] " "1: supporter" (alice TestParams -> IO () testPurchaseDeliveredToHiddenProfile ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} -> - withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do let unsettled userId = "/_badge purchase " <> show (userId :: Int) <> " " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken) - since <- testClockTime bsClock alice ##> unsettled 1 storePurchaseOpen alice "" - _ <- waitStoreReceiptDeferred (chatController alice) since + waitStoreReceiptError (chatController alice) "service_error retry payment_pending" alice ##> "/create user alisa" showActiveUser alice "alisa" alice ##> "/_hide user 1 \"password\"" @@ -1841,7 +1835,7 @@ testPurchaseDeliveredToHiddenProfile ps = -- the answer and the credit are the hidden owner's, so the view prints none of them alice ##> unsettled 2 (alice "/user alice password" @@ -1905,21 +1899,19 @@ testInvoiceAgedOut ps = unpaid <- createInvoice alice 1 presented <- createInvoice alice 1 refused <- createInvoice alice 1 - since <- testClockTime clock - alice ##> purchaseWithInvoice 1 presented (googlePayment "badge_supporter_01" googlePendingToken) - alice <## ("store purchase open: invoice " <> unpaid) - alice <##. ("store purchase open: invoice " <> presented <> ", transaction ") - alice <## ("store purchase open: invoice " <> refused) - _ <- waitStoreReceiptDeferred (chatController alice) since alice ##> purchaseWithInvoice 1 refused (googlePayment "badge_supporter_01" "not-a-purchase") inAnyOrder alice [ [ "store purchase open: invoice " <> unpaid, - "store purchase open: invoice " <> presented <> ", transaction ", + "store purchase open: invoice " <> presented, "store purchase open: invoice " <> refused <> ", transaction " ], ["store purchase settled"] ] + alice ##> purchaseWithInvoice 1 presented (googlePayment "badge_supporter_01" googlePendingToken) + alice <## ("store purchase open: invoice " <> unpaid) + alice <##. ("store purchase open: invoice " <> presented <> ", transaction ") + waitStoreReceiptError (chatController alice) "service_error retry payment_pending" -- 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" @@ -1951,7 +1943,7 @@ testInvoiceWhileBadgeHeld ps = alice ##> purchaseWithInvoice 1 invoiceId supporterPlay alice <##. "1: supporter" alice <##. ("store purchase open: invoice " <> invoiceId <> ", transaction ") - selectableStoreReceipts (chatController alice) 1 `shouldReturn` (0, Nothing) + storeReceiptDue (chatController alice) 1 `shouldReturn` False storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack invoiceId), True)] heldStoreReceipts (chatController alice) `shouldReturn` 1 rowCount cc "sx_badge_service_payments" `shouldReturn` 0 @@ -1973,54 +1965,38 @@ testInvoiceStateOtherProfile ps = (alice TestParams -> IO () -testStoreReceiptRetried ps = - withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} -> - withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do - setGoogleDown store True - since <- testClockTime bsClock - alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) - storePurchaseOpen alice "" - (at, failure) <- waitStoreReceiptDeferred (chatController alice) since - failure `shouldBe` "service_error retry provider_unavailable" - at `shouldSatisfy` (> addUTCTime 290 since) - setGoogleDown store False - retryStoreReceiptsAfter alice bsClock 300 $ creditedLines "" "1: supporter" - rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 - -testStoreReceiptNotSentEarly :: HasCallStack => TestParams -> IO () -testStoreReceiptNotSentEarly ps = do +testStoreReceiptRetried ps = do hook <- newIORef (pure ()) verifications <- countGoogleVerifications hook - withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} -> - withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do setGoogleDown store True - let purchase = "/_badge purchase 1 " <> paymentArg supporterPlay - since <- testClockTime bsClock - alice ##> purchase - storePurchaseOpen alice "" - deferred <- waitStoreReceiptDeferred (chatController alice) since - verifications `shouldReturn` 1 - alice ##> purchase - storePurchaseOpen alice "" - alice ##> "/_app activate" - alice <## "ok" - (alice TestParams -> IO () -testStoreReceiptRetriedDaily ps = - withBadgeServiceVerifier ps (const noStoreVerifier) $ \BadgeServiceEnv {bsClientCfg, bsClock} -> - withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do - since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) storePurchaseOpen alice "" - (firstAt, _) <- waitStoreReceiptDeferred (chatController alice) since - firstAt `shouldSatisfy` (> addUTCTime (nominalDay - 60) since) - retryStoreReceiptsAfter alice bsClock nominalDay [] - (secondAt, failure) <- waitStoreReceiptDeferred (chatController alice) firstAt - failure `shouldBe` "service_error final provider_not_configured" - secondAt `shouldSatisfy` (> addUTCTime (nominalDay - 60) firstAt) + waitStoreReceiptError (chatController alice) "service_error retry provider_unavailable" + setGoogleDown store False + threadDelay 1000000 + verifications `shouldReturn` 1 + passRetryAfter bsClock + mapM_ (alice <##.) $ creditedLines "" "1: supporter" + verifications `shouldReturn` 2 + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + +testStoreReceiptRetriedOnTrigger :: HasCallStack => TestParams -> IO () +testStoreReceiptRetriedOnTrigger ps = do + hook <- newIORef (pure ()) + verifications <- countGoogleVerifications hook + withBadgeServiceVerifier ps (notConfiguredGoogle hook) $ \BadgeServiceEnv {bsClientCfg} -> + withNewTestChatCfg ps (fastRetryCfg bsClientCfg) "alice" aliceProfile $ \alice -> do + alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + storePurchaseOpen alice "" + waitStoreReceiptError (chatController alice) "service_error final provider_not_configured" + threadDelay 1000000 + verifications `shouldReturn` 1 + alice ##> "/_app activate" + alice <## "ok" + waitGoogleVerifications verifications 2 + (alice TestParams -> IO () @@ -2083,13 +2059,12 @@ testStoreReceiptCleanup ps = unpaid <- createInvoice alice 1 alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "not-a-purchase")) inAnyOrder alice [["store purchase open: invoice " <> unpaid, openPurchase ""], ["store purchase settled"]] - since <- testClockTime bsClock + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS}) + inAnyOrder alice [["store purchase open: invoice " <> unpaid, openPurchase ""], creditedLines "" "1: supporter"] alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googleUnreachableToken)) + alice <##. "1: supporter" alice <## ("store purchase open: invoice " <> unpaid) storePurchaseOpen alice "" - _ <- waitStoreReceiptDeferred (chatController alice) since - alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS}) - 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) @@ -2109,20 +2084,17 @@ testStoreReceiptAttemptThrows :: HasCallStack => TestParams -> IO () testStoreReceiptAttemptThrows ps = do hook <- newIORef (pure ()) verifications <- countGoogleVerifications hook - withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} -> + withBadgeServiceVerifier ps (notConfiguredGoogle hook) $ \BadgeServiceEnv {bsClientCfg} -> withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do - setGoogleDown store True - since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) storePurchaseOpen alice "" - (firstAt, _) <- waitStoreReceiptDeferred (chatController alice) since + waitStoreReceiptError (chatController alice) "service_error final provider_not_configured" 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 [] - (secondAt, failure) <- waitStoreReceiptDeferred (chatController alice) firstAt - failure `shouldBe` "unexpected held store payment does not decode" - secondAt `shouldSatisfy` (> addUTCTime (nominalDay - 60) firstAt) + alice ##> "/_app activate" + alice <## "ok" + waitStoreReceiptError (chatController alice) "unexpected held store payment does not decode" (alice > loop (i - 1) --- | 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 +storeReceiptDue :: ChatController -> Int64 -> IO Bool +storeReceiptDue ChatController {chatStore} userId = withTransaction chatStore $ \db -> - (,) <$> (length <$> getDueStoreReceipts db userId later) <*> getNextStoreReceiptAttempt db userId + getNextDueStoreReceipt db userId S.empty >>= either (error . show) (pure . isJust) heldStoreReceipts :: ChatController -> IO Int heldStoreReceipts ChatController {chatStore} = @@ -2172,31 +2141,30 @@ waitHeldStoreReceipts cc n = loop (100 :: Int) loop 0 = heldStoreReceipts cc >>= (`shouldBe` n) loop i = heldStoreReceipts cc >>= \held -> if held == n then pure () else threadDelay 50000 >> loop (i - 1) --- | The next attempt and the failure of the receipt deferred last, once an attempt made after since has --- deferred it - every deferral is at least the retry floor ahead, which a fresh hand-over's due time is not. -waitStoreReceiptDeferred :: HasCallStack => ChatController -> UTCTime -> IO (UTCTime, Text) -waitStoreReceiptDeferred ChatController {chatStore} since = loop (100 :: Int) +waitStoreReceiptError :: HasCallStack => ChatController -> Text -> IO () +waitStoreReceiptError ChatController {chatStore} failure = loop (100 :: Int) where - loop i = do - rows :: [(UTCTime, Text)] <- - withTransaction chatStore $ \db -> - DB.query_ db "SELECT next_attempt_at, credit_error FROM badge_store_receipts WHERE credit_error IS NOT NULL ORDER BY next_attempt_at DESC LIMIT 1" - case rows of - [r@(at, _)] | at > addUTCTime 10 since -> pure r - _ | i == 0 -> error $ "expected a store receipt deferred after " <> show since <> ", got " <> show rows - | otherwise -> threadDelay 50000 >> loop (i - 1) + loop 0 = heldFailures >>= (`shouldContain` [failure]) + loop i = heldFailures >>= \failures -> if failure `elem` failures then pure () else threadDelay 50000 >> loop (i - 1) + heldFailures = + withTransaction chatStore $ \db -> + map fromOnly <$> DB.query_ db "SELECT credit_error FROM badge_store_receipts WHERE payment IS NOT NULL AND credit_error IS NOT NULL" setStoreReceiptPayment :: ChatController -> Text -> IO () 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; 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" - inAnyOrder cc $ ["ok"] : [events | not (null events)] +-- | Past the 300 seconds the service asks a client to wait while a store is pending or unreachable. +passRetryAfter :: TestClock -> IO () +passRetryAfter clock = testClockTime clock >>= setClockAt clock . addUTCTime 301 + +fastRetryCfg :: ChatConfig -> ChatConfig +fastRetryCfg cfg = cfg {badgeRetryInterval = RetryInterval {initialInterval = 100000, increaseAfter = 0, maxInterval = 500000}} + +-- | Google answered as by a service with no Play verifier deployed, each verification counted by the hook. +notConfiguredGoogle :: IORef (IO ()) -> FakeStore -> StoreVerifier +notConfiguredGoogle hook store = + googleVerifierWithHook hook store {fakeVerifier = noStoreVerifier {verifyGoogle = Just $ \_ _ -> pure $ Left SRNotConfigured}} -- | 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. @@ -2222,6 +2190,12 @@ countGoogleVerifications hook = do writeIORef hook count pure $ readIORef n +waitGoogleVerifications :: HasCallStack => IO Int -> Int -> IO () +waitGoogleVerifications verifications n = loop (100 :: Int) + where + loop 0 = verifications `shouldReturn` n + loop i = verifications >>= \made -> if made == n then pure () else threadDelay 50000 >> loop (i - 1) + storePurchaseOpen :: HasCallStack => TestCC -> String -> IO () storePurchaseOpen cc userPrefix = cc <##. openPurchase userPrefix