diff --git a/bots/src/API/Docs/Events.hs b/bots/src/API/Docs/Events.hs index dab06e9262..d625b3fd0f 100644 --- a/bots/src/API/Docs/Events.hs +++ b/bots/src/API/Docs/Events.hs @@ -221,6 +221,7 @@ undocumentedEvents = "CEvtSndFileRedirectStartXFTP", "CEvtSndFileStart", -- legacy SMP files "CEvtSndStandaloneFileComplete", + "CEvtStorePurchaseSettled", "CEvtConnectionsDiff", "CEvtSubscriptionEnd", "CEvtTerminalEvent", diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 3e6fb7e229..fc7640112a 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -195,6 +195,7 @@ newChatController deliveryJobWorkers <- TM.emptyIO relayRequestWorkers <- TM.emptyIO badgeWorkers <- TM.emptyIO + storeReceiptWorkers <- TM.emptyIO badgeSeq <- newTVarIO 0 relayGroupLinkChecksAsync <- newTVarIO Nothing webPreviewState <- forM webPreviewConfig $ \_ -> newWebPreviewState @@ -243,6 +244,7 @@ newChatController deliveryJobWorkers, relayRequestWorkers, badgeWorkers, + storeReceiptWorkers, badgeSeq, relayGroupLinkChecksAsync, webPreviewState, diff --git a/src/Simplex/Chat/Badges/Types.hs b/src/Simplex/Chat/Badges/Types.hs index 9d74cdd05c..376869f584 100644 --- a/src/Simplex/Chat/Badges/Types.hs +++ b/src/Simplex/Chat/Badges/Types.hs @@ -283,12 +283,14 @@ data BadgeState = BadgeState } deriving (Show) --- | One of a profile's open store purchases, neither credited nor closed. The app matches invoiceId --- against the transactions its store still holds; transactionRef is set once a receipt arrived. --- Neither reference is a secret: Apple's is the transaction id, Google's is a hash of the token. +-- | One of a profile's store purchases that no receipt has reached yet, or whose receipt is held until +-- the service credits it; transactionRef is set once a receipt arrived. Neither reference is a secret: +-- Apple's is the transaction id, Google's is a hash of the token. creditError is set only while the +-- held receipt's last attempt failed in a way that cannot clear on its own. data OpenStorePurchase = OpenStorePurchase { invoiceId :: Maybe Text, - transactionRef :: Maybe Text + transactionRef :: Maybe Text, + creditError :: Maybe BadgeIssueFailure } deriving (Show) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 0ce92d7543..c2da292ef6 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -328,6 +328,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), badgeSeq :: TVar Int, relayGroupLinkChecksAsync :: TVar (Maybe (Async ())), webPreviewState :: Maybe WebPreviewState, @@ -660,7 +661,7 @@ data ChatCommand | UpdateProfileImageFromFile FilePath -- set profile image from a .png/.jpg/.jpeg file | AddBadge BadgeCredential -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`) | APIRedeemBadgeCode {userId :: UserId, code :: Text} -- redeem a badge code with the configured badge service - | APIPurchaseBadge {userId :: UserId, echoedInvoiceId :: Maybe Text, payment :: ServicePayment} -- redeem an App Store or Google Play purchase; without an invoice id it is credited by transaction reference + | APIPurchaseBadge {userId :: UserId, echoedInvoiceId :: Maybe Text, payment :: ServicePayment} -- hand over an App Store or Google Play receipt, held until a worker credits it; answers from the record and sends nothing | APICreateBadgeInvoice {userId :: UserId} -- the record of a store purchase, created before the store charges; answers the id the store echoes | APIGetBadgeState {userId :: UserId} -- the user's badges, their balances and any current alert | APIGetBadgeLedger {userId :: UserId, badgePurchaseId :: Int64} -- the purchase's ledger, oldest first @@ -994,6 +995,7 @@ data ChatEvent | CEvtServiceReplySent {connectionId :: AgentConnId} | CEvtBadgeChanged {user :: User, badgeState :: Maybe BadgeState} -- badge state changed, including a renewal that arrived without a command | CEvtBadgeAlert {user :: User, badgeAlert :: BadgeAlert} + | CEvtStorePurchaseSettled {user :: User} -- a held store receipt was credited or refused, so its store transaction can be finished | CEvtContactRequestRejected {user :: User, contact :: Contact, rejectionReason :: Maybe ContactRejectionReason} | CEvtAcceptingContactRequest {user :: User, contact :: Contact} -- there is the same command response | CEvtAcceptingBusinessRequest {user :: User, groupInfo :: GroupInfo} diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 98808a3890..6050b80276 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -61,7 +61,7 @@ import Crypto.Random (ChaChaDRG) import Simplex.Messaging.Session (SessionVar (..), withGetSessVar') import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential) import qualified Simplex.Chat.Badges.Ledger as L -import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..)) +import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..), OpenStorePurchase (..)) import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode) import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), currentBadgeServiceVersion) import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim) @@ -107,7 +107,7 @@ import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSizeHar import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles) import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), withRetryInterval) +import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay, withRetryInterval) import Simplex.Messaging.Agent.Store.Entity import Simplex.Messaging.Agent.Store.Interface (execSQL) import Simplex.Messaging.Agent.Store.Shared (upMigration) @@ -263,6 +263,7 @@ startChatController mainApp enableSndFiles serviceRequests = do startRelayRequestWorker_ startCleanupManager mapM_ startBadgeWork users + mapM_ startStoreReceiptWork users void $ forkIO $ mapM_ startExpireCIs users startRelayChecks users startWebPreview users @@ -359,7 +360,7 @@ restoreCalls = do atomically $ writeTVar calls callsMap stopChatController :: ChatController -> IO () -stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, cleanupManagerAsync, relayGroupLinkChecksAsync, webPreviewState, expireCIThreads, timedItemThreads, deliveryTaskWorkers, deliveryJobWorkers, relayRequestWorkers, badgeWorkers} = do +stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, cleanupManagerAsync, relayGroupLinkChecksAsync, webPreviewState, expireCIThreads, timedItemThreads, deliveryTaskWorkers, deliveryJobWorkers, relayRequestWorkers, badgeWorkers, storeReceiptWorkers} = do readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd) atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd) disconnectAgentClient smpAgent @@ -373,6 +374,7 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, clearMap deliveryJobWorkers >>= mapM_ cancelWorker clearMap relayRequestWorkers >>= mapM_ cancelWorker stopBadgeWorkers badgeWorkers + stopBadgeWorkers storeReceiptWorkers closeFiles sndFiles closeFiles rcvFiles atomically $ do @@ -605,6 +607,7 @@ processChatCommand cxt nm = \case void . forkIO $ startFilesToReceive users setAllExpireCIFlags True mapM_ startBadgeWork users + mapM_ startStoreReceiptWork users ok_ APISuspendChat t -> do chatWriteVar chatActivated False @@ -3564,14 +3567,14 @@ processChatCommand cxt nm = \case ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile) AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user APIRedeemBadgeCode userId codeText -> withUserId userId $ \user -> redeemBadgeCode nm user codeText - APIPurchaseBadge userId echoedInvoiceId payment -> withUserId userId $ \user -> purchaseBadge nm user echoedInvoiceId payment + APIPurchaseBadge userId echoedInvoiceId payment -> withUserId userId $ \user -> handOverStoreReceipt user echoedInvoiceId payment APICreateBadgeInvoice userId -> withUserId userId $ \user -> do void requireBadgeService refuseWhileBadgeHeld user g <- asks random - now <- liftIO getCurrentTime + now <- badgeNow invoiceId <- UUID.toText <$> liftIO V4.nextRandom - _ <- withStore' $ \db -> createBadgeStoreReceipt db g user (Just invoiceId) Nothing now + withStore' $ \db -> createBadgeStoreReceipt db g user invoiceId now pure $ CRBadgeInvoice user invoiceId APIGetBadgeState userId -> withUserId' userId $ \user -> do -- the read also signals the worker, whose results follow as CEvtBadgeChanged @@ -5251,28 +5254,36 @@ redeemBadgeCode nm user@User {userId} codeText = do BSECodeExpired -> True _ -> False --- | The app presents a purchase until this returns its badge, under whichever profile is active; the --- stash stays with the profile it was first presented under, so every retry is the signer first credited. -purchaseBadge :: NetworkRequestMode -> User -> Maybe Text -> ServicePayment -> CM ChatResponse -purchaseBadge nm presentingUser echoedInvoiceId payment = do +-- | The app hands a receipt over until it is answered credited or refused, under whichever profile is +-- active; the answer is the owner's, read from the record. Nothing is sent: the owner's receipt worker is. +handOverStoreReceipt :: User -> Maybe Text -> ServicePayment -> CM ChatResponse +handOverStoreReceipt presentingUser echoedInvoiceId payment = do txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment - sendTarget <- requireBadgeService + void requireBadgeService g <- asks random - now <- liftIO getCurrentTime - user@User {userId} <- withStore $ \db -> liftIO (attachBadgeStoreReceipt db echoedInvoiceId txRef) >>= maybe (pure presentingUser) (getUser db) - (present_, purchased) <- withEntityLock "badgePurchase" (CLBadgeUser userId) $ do - stash_ <- withStore' $ \db -> getBadgeStoreReceipt db user txRef - stash@BadgeStash {masterKey} <- stashBadgeKeys user stash_ $ \db -> createBadgeStoreReceipt db g user echoedInvoiceId (Just txRef) now - redeemBadgeStash nm user sendTarget stash BSCPurchaseBadge {masterKey, payment, upgrade = Nothing} terminalReceiptError - -- outside the badge lock: the chat lock must not be taken under it - mapM_ presentUserBadgeToContacts present_ - pure purchased - where - -- the receipt will never be credited to this key; any other refusal may pass on a retry - terminalReceiptError = \case - BSEReceiptInvalid -> True - BSEReceiptUsed -> True - _ -> False + now <- badgeNow + (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 + answer <- case status of + RSHeld -> badgeStateResponse owner + RSCredited {badgePurchaseId} -> do + cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId) + cred@(BadgeCredential _ _ _ info) <- maybe (throwChatError $ CEInternalError "credited store purchase has no credential") pure cred_ + CRBadgeRedeemed owner (OwnBadge cred (mkBadgeStatus now (Just True) info)) False <$> getUserBadgeState owner + RSRefused {refusal = Just BIFServiceError {code}} -> throwRedeemError $ BREServiceError code + RSRefused {} -> throwChatError $ CEInternalError "store purchase refused for no recorded reason" + -- after the answer is read, so it shows the receipt held whatever the worker does next + when newlyHeld $ lift $ startStoreReceiptWork owner + pure answer + +-- | The receipt will never be credited to its key; any other refusal may pass on a retry. +storeReceiptRefused :: BadgeServiceErrorCode -> Bool +storeReceiptRefused = \case + BSEReceiptInvalid -> True + BSEReceiptUsed -> True + _ -> False -- | The same reference the service claims a transaction by, read without verifying anything. storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef @@ -5298,16 +5309,23 @@ refuseWhileBadgeHeld user = whenM (withStore' (`userHasBadge` user)) $ throwRede -- | One attempt to turn a stash into a badge, dropping the stash only on a refusal no retry can fix. redeemBadgeStash :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> (BadgeServiceErrorCode -> Bool) -> CM (Maybe User, ChatResponse) -redeemBadgeStash nm user sendTarget stash@BadgeStash {purchaseKey, purchasePrivKey} request stashDead = do +redeemBadgeStash nm user sendTarget stash request stashDead = + requestBadgeStash nm user sendTarget stash request >>= \case + Left (errCode, _) -> do + when (stashDead errCode) $ withStore' (`deleteBadgeStash` stash) + throwRedeemError $ BREServiceError errCode + Right redeemed -> pure redeemed + +-- | A refusal is answered rather than thrown, with the service's retryAfter. +requestBadgeStash :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (Maybe User, ChatResponse)) +requestBadgeStash nm user sendTarget stash@BadgeStash {purchaseKey, purchasePrivKey} request = do let req = BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} respBytes <- sendServiceRequestBytes nm user sendTarget Nothing (Just purchasePrivKey) req respData <- either (const $ throwRedeemError $ BREInvalidResponse "not JSON") pure $ J.eitherDecodeStrict' respBytes case J.fromJSON (J.Object respData) of J.Error _ -> throwRedeemError $ BREInvalidResponse "not a badge service response" - J.Success BSPError {code = errCode} -> do - when (stashDead errCode) $ withStore' (`deleteBadgeStash` stash) - throwRedeemError $ BREServiceError errCode - J.Success BSPBadgeCredential {credential = Just cred, statement} -> storeRedeemedBadge user stash cred statement + J.Success BSPError {code, retryAfter} -> pure $ Left (code, retryAfter) + J.Success BSPBadgeCredential {credential = Just cred, statement} -> Right <$> storeRedeemedBadge user stash cred statement J.Success _ -> throwRedeemError $ BREInvalidResponse "unexpected response type" throwRedeemError :: BadgeRedeemError -> CM a @@ -5335,20 +5353,23 @@ 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 user +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 -- | 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 :: User -> CM' BadgeWorker -getBadgeWorker User {userId} = do - ws <- asks badgeWorkers +getBadgeWorker :: (ChatController -> TM.TMap UserId (SessionVar BadgeWorker)) -> (UserId -> TMVar () -> CM ()) -> User -> CM' BadgeWorker +getBadgeWorker workers runWorker User {userId} = do + ws <- asks workers seq' <- asks badgeSeq now <- liftIO getCurrentTime withGetSessVar' seq' userId ws now startWorker signalWorker where startWorker v = do badgeWork <- newEmptyTMVarIO - badgeWorkerAsync <- async $ void $ runExceptT $ runBadgeWorker userId badgeWork + badgeWorkerAsync <- async $ void $ runExceptT $ runWorker userId badgeWork let w = BadgeWorker {badgeWorkerAsync, badgeWork} w <$ atomically (putTMVar (sessionVar v) w) signalWorker v = do @@ -5418,6 +5439,70 @@ 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_ + +-- | 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) + +data StoreReceiptOutcome = SROCredited (Maybe User) | SRORefused | SRODeferred + +-- | 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: the app answers it with a sweep, which signals this worker + case outcome of + SROCredited present_ -> do + -- outside the badge lock: the chat lock must not be taken under it + mapM_ presentUserBadgeToContacts present_ + user <- withStore $ \db -> getUser db userId + toView . CEvtBadgeChanged user =<< getUserBadgeState user + toView $ CEvtStorePurchaseSettled user + SRORefused -> withStore (`getUser` userId) >>= toView . CEvtStorePurchaseSettled + SRODeferred -> pure () + where + attempt = do + user <- withStore $ \db -> getUser db userId + refuseWhileBadgeHeld user + sendTarget <- requireBadgeService + 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 (wait, retryDelay') = storeReceiptRetry ri failure retryAfter retryDelay + withStore' $ \db -> deferStoreReceipt db receiptId (wait `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 + -- | 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. updateUserBadge :: UserId -> TVar (Maybe BadgeOccurrence) -> UTCTime -> CM (Maybe UTCTime) @@ -5499,8 +5584,10 @@ emitBadgeAlert user emitted p@UserBadgePurchase {alertSnoozeUntil} shownCred now badgeStateResponse :: User -> CM ChatResponse badgeStateResponse user = do badgeState <- getUserBadgeState user - now <- badgeNow - CRBadgeState user badgeState <$> withStore' (\db -> getOpenStorePurchases db user now) + CRBadgeState user badgeState . map finalError <$> withStore' (`getOpenStorePurchases` user) + where + -- like a renewal's, only a failure that cannot clear on its own is the user's to know about + finalError p@OpenStorePurchase {creditError} = p {creditError = find (not . badgeFailureTransient) creditError} -- | Read from stored rows alone; the worker's results follow as CEvtBadgeChanged. getUserBadgeState :: User -> CM (Maybe BadgeState) @@ -5535,9 +5622,10 @@ badgeStalledInterval = nominalDay -- | The wait after a service refusal, floored at initialInterval so answering 0 cannot spin the -- worker, and uncapped above it. badgeRetryAfter :: RetryInterval -> Maybe Word32 -> NominalDiffTime -badgeRetryAfter RetryInterval {initialInterval} = maybe badgeStalledInterval (max floorWait . fromIntegral) - where - floorWait = fromIntegral initialInterval / 1000000 +badgeRetryAfter ri = maybe badgeStalledInterval (max (retryFloor ri) . fromIntegral) + +retryFloor :: RetryInterval -> NominalDiffTime +retryFloor RetryInterval {initialInterval} = fromIntegral initialInterval / 1000000 -- | How far ahead of the shown credential's expiry the renewal is requested - a day, so a failure -- has that long to retry. The wake and the due check both derive from it and have to agree. @@ -5881,6 +5969,7 @@ cleanupManager = do cleanupDeliveryJobs `catchAllErrors` eToView -- TODO possibly, also cleanup async commands cleanupProbes `catchAllErrors` eToView + cleanupStoreReceipts `catchAllErrors` eToView liftIO $ threadDelay' $ diffToMicroseconds interval where runWithoutInitialDelay cleanupInterval = flip catchAllErrors eToView $ do @@ -5950,6 +6039,11 @@ cleanupManager = do ts <- liftIO getCurrentTime let cutoffTs = addUTCTime (-(14 * nominalDay)) ts withStore' (`deleteOldProbes` cutoffTs) + -- the badge clock, which the records are written with + cleanupStoreReceipts = do + ts <- badgeNow + let cutoffTs = addUTCTime (-(30 * nominalDay)) ts + withStore' (`deleteUnfundedStoreReceipts` cutoffTs) deleteInProgressGroup :: User -> GroupInfo -> CM () deleteInProgressGroup user gInfo = do diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 769cb47d4b..dd03a5ae55 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} module Simplex.Chat.Store.Badges @@ -19,11 +20,17 @@ module Simplex.Chat.Store.Badges clearShownBadge, getBadgeCodeRedemption, createBadgeCodeRedemption, - getBadgeStoreReceiptUserId, - attachBadgeStoreReceipt, - getOpenStorePurchases, - getBadgeStoreReceipt, + StoreReceipt (..), + StoreReceiptStatus (..), + HeldStoreReceipt (..), + holdStoreReceipt, createBadgeStoreReceipt, + getOpenStorePurchases, + getDueStoreReceipts, + getNextStoreReceiptAttempt, + deferStoreReceipt, + refuseStoreReceipt, + deleteUnfundedStoreReceipts, deleteBadgeStash, createStashBadgePurchase, getStashBadgePurchase, @@ -45,11 +52,12 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) import Data.Maybe (isJust, mapMaybe) import Data.Text (Text) -import Data.Time.Clock (UTCTime, addUTCTime, nominalDay) +import Data.Time.Clock (UTCTime) import Simplex.Chat.Badges import Simplex.Chat.Badges.Ledger import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..)) 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.Types @@ -105,80 +113,157 @@ createBadgeCodeRedemption db g User {userId} code now = do redemptionId <- insertedRowId db pure BadgeStash {stashRef = BSRCodeRedemption redemptionId, purchaseKey, purchasePrivKey, masterKey} --- | A store transaction belongs to the store account, not to a profile, so its stash is looked up --- across profiles: presented under another, it still reaches the service as the key it was credited to. -getBadgeStoreReceiptUserId :: DB.Connection -> StoreTransactionRef -> IO (Maybe UserId) -getBadgeStoreReceiptUserId db StoreTransactionRef {provider, transactionRef} = - maybeFirstRow fromOnly $ - DB.query db "SELECT user_id FROM badge_store_receipts WHERE provider = ? AND transaction_ref = ?" (provider, transactionRef) +-- | A store receipt as the record has it: held until the service credits or refuses it. +data StoreReceipt = StoreReceipt + { receiptId :: Int64, + ownerId :: UserId, + status :: StoreReceiptStatus + } --- | The profile a receipt belongs to, attaching it to the record created when Buy was tapped. A --- transaction already attached stays with its record, whose keys the service may have credited. -attachBadgeStoreReceipt :: DB.Connection -> Maybe Text -> StoreTransactionRef -> IO (Maybe UserId) -attachBadgeStoreReceipt db invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} = - getBadgeStoreReceiptUserId db txRef >>= \case - Just userId -> pure $ Just userId - Nothing -> fmap join . forM invoiceId_ $ \invoiceId -> do - userId_ <- - maybeFirstRow fromOnly $ - DB.query db "SELECT user_id FROM badge_store_receipts WHERE invoice_id = ? AND transaction_ref IS NULL" (Only invoiceId) - forM_ userId_ $ \_ -> +data StoreReceiptStatus + = RSHeld + | RSCredited {badgePurchaseId :: Int64} + | RSRefused {refusal :: Maybe BadgeIssueFailure} + +-- | A store transaction belongs to the store account, not to a profile, so it is found across profiles and +-- stays with the record whose keys the service may have credited. A new one goes to the record created when +-- Buy was tapped, or else to the presenting profile. 'True' when this hand-over is the one that held it. +holdStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Maybe Text -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO (Maybe (StoreReceipt, Bool)) +holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} payment now = + getStoreReceipt db txRef >>= \case + Just r@StoreReceipt {receiptId} -> do + -- a settled record stays settled, so a hand-over landing just after its credit cannot hold it again + DB.execute db "UPDATE badge_store_receipts SET payment = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL" (paymentJSON, receiptId) + pure $ Just (r, False) + Nothing -> do + forM_ invoiceId_ $ \invoiceId -> DB.execute db - "UPDATE badge_store_receipts SET provider = ?, transaction_ref = ? WHERE invoice_id = ?" - (provider, transactionRef, invoiceId) - pure userId_ - -getOpenStorePurchases :: DB.Connection -> User -> UTCTime -> IO [OpenStorePurchase] -getOpenStorePurchases db User {userId} now = - map (uncurry OpenStorePurchase) - <$> DB.query - db - [sql| - SELECT r.invoice_id, r.transaction_ref - FROM badge_store_receipts r - WHERE r.user_id = ? AND (r.transaction_ref IS NOT NULL OR r.created_at > ?) - AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = r.badge_store_receipt_id) - ORDER BY r.badge_store_receipt_id - |] - (userId, receiptDueSince) + "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) + getStoreReceipt db txRef >>= \case + Just r -> pure $ Just (r, True) + Nothing -> do + insertReceipt + -- read back rather than trusted: a concurrent hand-over of the same transaction may have inserted first + fmap (,True) <$> getStoreReceipt db txRef where - -- a record with no receipt is dropped after a week: longer than an Ask to Buy approval or a Play slow - -- payment can take, and those are the only waits that still need it. One a receipt reached is paid for. - receiptDueSince = addUTCTime (negate $ 7 * nominalDay) now + paymentJSON = safeDecodeUtf8 . LB.toStrict $ J.encode payment + insertReceipt = do + (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g + BadgeMasterKey mk <- generateMasterKey g + -- an invoice id another record holds is not repeated: this record is then keyed by its transaction alone + invoiceId' <- fmap join . forM invoiceId_ $ \invoiceId -> do + taken <- DB.query db "SELECT badge_store_receipt_id FROM badge_store_receipts WHERE invoice_id = ?" (Only invoiceId) :: IO [Only Int64] + pure $ if null taken then Just invoiceId else Nothing + DB.execute + 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 (?,?,?,?,?,?,?,?,?,?) + ON CONFLICT DO NOTHING + |] + ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, now)) -getBadgeStoreReceipt :: DB.Connection -> User -> StoreTransactionRef -> IO (Maybe BadgeStash) -getBadgeStoreReceipt db User {userId} StoreTransactionRef {provider, transactionRef} = - maybeFirstRow (toBadgeStash BSRStoreReceipt) $ +-- | held is a CASE because in Postgres a comparison is boolean, which BoolInt rejects. +getStoreReceipt :: DB.Connection -> StoreTransactionRef -> IO (Maybe StoreReceipt) +getStoreReceipt db StoreTransactionRef {provider, transactionRef} = + maybeFirstRow toStoreReceipt $ DB.query db [sql| - SELECT badge_store_receipt_id, purchase_key, purchase_priv_key, master_key - FROM badge_store_receipts - WHERE user_id = ? AND provider = ? AND transaction_ref = ? + SELECT r.badge_store_receipt_id, r.user_id, (CASE WHEN r.payment IS NULL THEN 0 ELSE 1 END), p.badge_purchase_id, r.credit_error + FROM badge_store_receipts r + LEFT JOIN badge_purchases p ON p.badge_store_receipt_id = r.badge_store_receipt_id + WHERE r.provider = ? AND r.transaction_ref = ? |] - (userId, provider, transactionRef) + (provider, transactionRef) + where + toStoreReceipt (receiptId, ownerId, BI held, purchaseId_, refusal) = + StoreReceipt {receiptId, ownerId, status = if held then RSHeld else maybe (RSRefused refusal) RSCredited purchaseId_} --- | An invoice id another record already holds is not repeated: the record is then keyed by its transaction alone. -createBadgeStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Maybe Text -> Maybe StoreTransactionRef -> UTCTime -> IO BadgeStash -createBadgeStoreReceipt db g User {userId} invoiceId_ txRef_ now = do +-- | The record made when Buy is tapped, before any receipt: the store echoes its invoice id. +createBadgeStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO () +createBadgeStoreReceipt db g User {userId} invoiceId now = do (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g - masterKey@(BadgeMasterKey mk) <- generateMasterKey g - invoiceId' <- fmap join . forM invoiceId_ $ \invoiceId -> do - taken <- DB.query db "SELECT badge_store_receipt_id FROM badge_store_receipts WHERE invoice_id = ?" (Only invoiceId) :: IO [Only Int64] - pure $ if null taken then Just invoiceId else Nothing - let (provider_, transactionRef_) = case txRef_ of - Just StoreTransactionRef {provider, transactionRef} -> (Just provider, Just transactionRef) - Nothing -> (Nothing, Nothing) + BadgeMasterKey mk <- generateMasterKey g DB.execute db [sql| - INSERT INTO badge_store_receipts (user_id, invoice_id, provider, transaction_ref, purchase_key, purchase_priv_key, master_key, created_at) - VALUES (?,?,?,?,?,?,?,?) + INSERT INTO badge_store_receipts (user_id, invoice_id, purchase_key, purchase_priv_key, master_key, created_at) + VALUES (?,?,?,?,?,?) |] - ((userId, invoiceId', provider_, transactionRef_) :. (purchaseKey, purchasePrivKey, Binary mk, now)) - storeReceiptId <- insertedRowId db - pure BadgeStash {stashRef = BSRStoreReceipt storeReceiptId, purchaseKey, purchasePrivKey, masterKey} + (userId, invoiceId, purchaseKey, purchasePrivKey, Binary mk, now) + +-- | No receipt yet, or one held: a credited or refused record is settled and not listed. +getOpenStorePurchases :: DB.Connection -> User -> IO [OpenStorePurchase] +getOpenStorePurchases db User {userId} = + map toOpenStorePurchase + <$> DB.query + db + [sql| + SELECT invoice_id, transaction_ref, credit_error + FROM badge_store_receipts + WHERE user_id = ? AND (transaction_ref IS NULL OR payment IS NOT NULL) + ORDER BY badge_store_receipt_id + |] + (Only userId) + where + toOpenStorePurchase (invoiceId, transactionRef, creditError) = OpenStorePurchase {invoiceId, transactionRef, creditError} + +data HeldStoreReceipt = HeldStoreReceipt + { receiptId :: Int64, + stash :: BadgeStash, + payment :: Text, + 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 + <$> DB.query + db + [sql| + SELECT badge_store_receipt_id, purchase_key, purchase_priv_key, master_key, payment, retry_delay + FROM badge_store_receipts + WHERE user_id = ? AND payment IS NOT NULL AND next_attempt_at <= ? + ORDER BY next_attempt_at + |] + (userId, now) + where + 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 "SELECT MIN(next_attempt_at) FROM badge_store_receipts WHERE user_id = ? AND payment IS NOT NULL" (Only userId) + +deferStoreReceipt :: DB.Connection -> Int64 -> UTCTime -> Maybe Int64 -> BadgeIssueFailure -> IO () +deferStoreReceipt db receiptId nextAttemptAt 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) + +-- | 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) + +-- | A held record is paid for and a credited one is referenced by its purchase, so neither is deleted. +deleteUnfundedStoreReceipts :: DB.Connection -> UTCTime -> IO () +deleteUnfundedStoreReceipts db createdBefore = + DB.execute + db + [sql| + DELETE FROM badge_store_receipts + WHERE payment IS NULL AND created_at < ? + AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id) + |] + (Only createdBefore) toBadgeStash :: (Int64 -> BadgeStashRef) -> (Int64, C.PublicKeyEd25519, C.PrivateKeyEd25519, Binary ByteString) -> BadgeStash toBadgeStash ref (stashId, purchaseKey, purchasePrivKey, Binary mk) = @@ -210,7 +295,9 @@ deleteBadgeStash db BadgeStash {stashRef} = case stashRef of -- | 'False' when the stash already funded a purchase here: the service replays the credential it -- issued, and that must add no purchase and leave the shown badge alone. createStashBadgePurchase :: DB.Connection -> User -> BadgeStash -> BadgeCredential -> UTCTime -> IO (Int64, Bool) -createStashBadgePurchase db User {userId} stash credential now = +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) 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 ca60f7f44a..cc76061291 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 @@ -8,7 +8,8 @@ import Text.RawString.QQ (r) -- | invoice_id is null for a receipt naming one another row holds: the transaction still has to be -- creditable, and its reference identifies it. provider and transaction_ref are null until a receipt --- arrives, and distinct NULLs let several rows await one at once. +-- arrives, and distinct NULLs let several rows await one at once. payment is held from the receipt's +-- arrival until the service credits or refuses it; a refused row keeps its refusal in credit_error. m20260925_badge_store_receipts :: Text m20260925_badge_store_receipts = [r| @@ -22,6 +23,10 @@ CREATE TABLE badge_store_receipts( purchase_priv_key BYTEA NOT NULL, 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 2ae58845e8..37266af7fa 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql @@ -305,7 +305,11 @@ CREATE TABLE test_chat_schema.badge_store_receipts ( purchase_key bytea NOT NULL, purchase_priv_key bytea NOT NULL, master_key bytea NOT NULL, - created_at timestamp with time zone 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 e4884395f8..4595e95cea 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 @@ -7,7 +7,8 @@ import Database.SQLite.Simple.QQ (sql) -- | invoice_id is null for a receipt naming one another row holds: the transaction still has to be -- creditable, and its reference identifies it. provider and transaction_ref are null until a receipt --- arrives, and distinct NULLs let several rows await one at once. +-- arrives, and distinct NULLs let several rows await one at once. payment is held from the receipt's +-- arrival until the service credits or refuses it; a refused row keeps its refusal in credit_error. m20260925_badge_store_receipts :: Query m20260925_badge_store_receipts = [sql| @@ -21,6 +22,10 @@ CREATE TABLE badge_store_receipts( purchase_priv_key BLOB NOT NULL, 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) ) STRICT; diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index 5484db74ff..5721eec897 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -992,6 +992,10 @@ CREATE TABLE badge_store_receipts( purchase_priv_key BLOB NOT NULL, 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) ) STRICT; CREATE INDEX contact_profiles_index ON contact_profiles( diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 13cdb539a2..b9fea0692d 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -484,6 +484,7 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView} CEvtServiceReplySent (AgentConnId cId) -> [plain $ "service reply sent, connection id: " <> safeDecodeUtf8 (strEncode cId)] CEvtBadgeChanged u st -> ttyUser u $ viewUserBadgeState st CEvtBadgeAlert u alert -> ttyUser u $ viewBadgeAlert alert + CEvtStorePurchaseSettled u -> ttyUser u ["store purchase settled"] CEvtContactRequestRejected u Contact {localDisplayName = c} _reason -> ttyUser u [ttyContact c <> ": contact request rejected"] CEvtRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci CEvtRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci @@ -1865,8 +1866,12 @@ viewBadgeAlert :: BadgeAlert -> [StyledString] viewBadgeAlert BadgeAlert {kind, date} = [plain $ "badge alert: " <> textEncode kind <> " " <> day date] viewOpenStorePurchase :: OpenStorePurchase -> StyledString -viewOpenStorePurchase OpenStorePurchase {invoiceId, transactionRef} = - plain $ "store purchase open: invoice " <> fromMaybe "none" invoiceId <> maybe "" (", transaction " <>) transactionRef +viewOpenStorePurchase OpenStorePurchase {invoiceId, transactionRef, creditError} = + plain $ + "store purchase open: invoice " + <> fromMaybe "none" invoiceId + <> maybe "" (", transaction " <>) transactionRef + <> maybe "" ((", not credited: " <>) . safeDecodeUtf8 . strEncode) creditError viewBadgeLedger :: [StatementEntry] -> [StyledString] viewBadgeLedger [] = ["no ledger entries"] diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 0cabd45e11..4fdc4261bf 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -35,7 +35,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (toLower) import Data.Either (isLeft, isRight) import Data.Int (Int64) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) import Data.List (stripPrefix) import qualified Data.Map.Strict as M import Data.Maybe (isJust, isNothing) @@ -131,27 +131,35 @@ badgeServiceTests = do it "should credit a transaction claimed twice at once only once" testStoreClaimRace it "should answer a request that lost the claim race with the credential the winner was given" testStorePurchaseRace it "should refuse as receipt_used a key that lost the claim race to another key, crediting nothing" testStorePurchaseRaceOtherKey - it "should refuse a store with no verifier with no retry, and the client should keep its keys" testPurchaseWithNoVerifier + it "should refuse a store with no verifier with no retry, and the client should hold the receipt, showing why it is not credited" testPurchaseWithNoVerifier it "should credit nothing when the verified transaction is not the one the evidence names" testStoreVerifiedOtherTransaction - it "should refuse a verified quantity other than one as internal, and the client should keep its keys" testStoreQuantityRefused + it "should refuse a verified quantity other than one as internal, and the client should hold the receipt" testStoreQuantityRefused it "should refuse a store purchase whose purchaseKey is not the verified signer" testStorePurchaseKeyMismatch - it "should redeem a Play purchase into a badge, and replay it as the same badge" testPurchaseBadge - it "should redeem an App Store purchase by its JWS" testPurchaseBadgeAppStore - it "should drop the keys of a receipt refused for good, and keep them while it is pending" testPurchaseStash - it "should drop the keys of a receipt credited to another key" testPurchaseStashReceiptUsed - it "should keep the keys of a Play token the service will not send to Play" testPurchaseUnsentPlayToken - it "should refuse a store purchase while a badge is held, before anything is sent" testPurchaseWhileBadgeHeld - it "should answer a receipt presented under a second profile as the profile that bought it" testPurchaseSameReceiptOtherProfile - it "should deliver a purchase first presented under another profile to that profile" testPurchaseStrandedUnderOtherProfile - it "should deliver a purchase to a hidden profile without naming it" testPurchaseDeliveredToHiddenProfile + it "should hold a Play receipt until the worker credits it, and answer it as credited after" testPurchaseBadge + it "should credit an App Store purchase by its JWS" testPurchaseBadgeAppStore + it "should keep a refusal on the record, and hold a pending receipt until it settles" testPurchaseStash + it "should keep a receipt credited to another key as refused" testPurchaseStashReceiptUsed + it "should hold a Play token the service will not send to Play" testPurchaseUnsentPlayToken + it "should hold a store receipt while a badge is held, deferring it with nothing sent" testPurchaseWhileBadgeHeld + it "should answer a receipt handed over under a second profile as the profile that bought it" testPurchaseSameReceiptOtherProfile + it "should credit a purchase first handed over under another profile to that profile" testPurchaseStrandedUnderOtherProfile + it "should credit a purchase to a hidden profile without naming it" testPurchaseDeliveredToHiddenProfile it "should credit a receipt to the profile that created its invoice, and answer as that profile" testInvoiceOtherProfile - it "should resolve the same receipt to the same record, and replay its credential" testInvoiceSameReceiptTwice + it "should resolve the same receipt to the same record, and answer it as credited" testInvoiceSameReceiptTwice it "should credit a receipt naming an unknown invoice to the presenting profile" testInvoiceUnknown - it "should attach a late receipt to its aged-out record, and credit the profile that created it" testInvoiceLateReceipt - it "should stop listing a record no receipt has reached once it ages out, and keep listing a presented one" testInvoiceAgedOut + it "should attach a late receipt to its record, and credit the profile that created it" testInvoiceLateReceipt + it "should list a record however old until a receipt reaching it is settled" testInvoiceAgedOut it "should refuse an invoice with no service configured or while a badge is held, creating no record" testInvoiceRefusedBeforeCharge - it "should refuse a receipt for an invoice while a badge is held, keeping the record for a retry" testInvoiceWhileBadgeHeld + it "should hold a receipt for an invoice while a badge is held, deferring it with nothing sent" 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 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 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} @@ -1583,27 +1591,33 @@ testStoreVerifiedOtherTransaction ps = testStoreQuantityRefused :: HasCallStack => TestParams -> IO () testStoreQuantityRefused ps = - withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = FakeStore {appleQuantityJWS}} -> do + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsClock, 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}) - alice <## "cannot get badge: badge service error: internal" - rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1 + storePurchaseOpen alice "" + snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error final internal" + heldStoreReceipts (chatController alice) `shouldReturn` 1 nothingPurchased cc testPurchaseWithNoVerifier :: HasCallStack => TestParams -> IO () testPurchaseWithNoVerifier ps = - withBadgeServiceVerifier ps (const noStoreVerifier) $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc} -> do + withBadgeServiceVerifier ps (const noStoreVerifier) $ \env@BadgeServiceEnv {bsClientCfg, bsClock, 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) - alice <## "cannot get badge: badge service error: provider_not_configured" - -- not yet rather than never, so the keys stay for the retry once a verifier is deployed - rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1 + 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" + heldStoreReceipts (chatController alice) `shouldReturn` 1 + alice ##> "/_badge state 1" + alice .<## ", not credited: service_error final provider_not_configured" testStoreClaimRace :: HasCallStack => TestParams -> IO () testStoreClaimRace ps = @@ -1678,10 +1692,9 @@ testPurchaseBadge ps = withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do let purchase = "/_badge purchase 1 " <> paymentArg supporterPlay alice ##> purchase - alice <## "badge redeemed" - alice <## "supporter badge - active" - alice <##. "expires " - -- the app presents a purchase until the badge is stored, and one already stored adds nothing + storePurchaseOpen alice "" + storePurchaseCredited alice "" "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" alice ##> "/p" @@ -1695,36 +1708,39 @@ 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}) - alice <## "badge redeemed" - alice <## "legend badge - active" - alice <##. "expires " + storePurchaseOpen alice "" + storePurchaseCredited alice "" "1: legend" storePayments cc `shouldReturn` [("apple", Just 7000, Just "USD", 1)] testPurchaseStash :: HasCallStack => TestParams -> IO () testPurchaseStash ps = - withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = store} -> + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} -> withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do - let stashes = rowCount (chatController alice) "badge_store_receipts" - -- the store does not vouch for it, so the keys stashed for it can never be credited - alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "not-a-purchase")) + 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 + alice ##> refused + storePurchaseOpen alice "" + alice <## "store purchase settled" + alice ##> refused alice <## "cannot get badge: badge service error: receipt_invalid" - stashes `shouldReturn` 0 - -- no store transaction to key a stash by, so nothing is stashed or sent + records `shouldReturn` 1 + heldStoreReceipts (chatController alice) `shouldReturn` 0 + -- no store transaction to key a record by, so nothing is held or sent alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = "not.a-jws"}) alice <## "cannot get badge: invalid store receipt" - stashes `shouldReturn` 0 + records `shouldReturn` 1 nothingPurchased cc - -- pending keeps the keys, and the settled purchase is credited to them, once - let unsettled = "/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" googlePendingToken) - alice ##> unsettled - alice <## "cannot get badge: badge service error: payment_pending" - stashes `shouldReturn` 1 + -- 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" settlePending store - alice ##> unsettled - alice <## "badge redeemed" - alice <## "supporter badge - active" - alice <##. "expires " - stashes `shouldReturn` 1 + retryStoreReceiptsAfter alice bsClock 300 + storePurchaseCredited alice "" "1: supporter" + records `shouldReturn` 2 + heldStoreReceipts (chatController alice) `shouldReturn` 0 rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 testPurchaseStashReceiptUsed :: HasCallStack => TestParams -> IO () @@ -1734,12 +1750,15 @@ testPurchaseStashReceiptUsed ps = withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do let purchase = "/_badge purchase 1 " <> paymentArg supporterPlay alice ##> purchase - alice <## "badge redeemed" - alice <## "supporter badge - active" - alice <##. "expires " + storePurchaseOpen alice "" + storePurchaseCredited alice "" "1: supporter" + bob ##> purchase + storePurchaseOpen bob "" + bob <## "store purchase settled" bob ##> purchase bob <## "cannot get badge: badge service error: receipt_used" - rowCount (chatController bob) "badge_store_receipts" `shouldReturn` 0 + storeReceiptRows (chatController bob) `shouldReturn` [(1, Nothing, True)] + heldStoreReceipts (chatController bob) `shouldReturn` 0 rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1 rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 bob ##> "/p" @@ -1747,22 +1766,29 @@ testPurchaseStashReceiptUsed ps = testPurchaseUnsentPlayToken :: HasCallStack => TestParams -> IO () testPurchaseUnsentPlayToken ps = - withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc} -> withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg (googlePayment "badge_supporter_01" "token/other")) - alice <## "cannot get badge: badge service error: provider_unavailable" - rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 1 + storePurchaseOpen alice "" + snd <$> waitStoreReceiptDeferred (chatController alice) since `shouldReturn` "service_error retry provider_unavailable" + heldStoreReceipts (chatController alice) `shouldReturn` 1 nothingPurchased cc testPurchaseWhileBadgeHeld :: HasCallStack => TestParams -> IO () testPurchaseWhileBadgeHeld ps = - withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc} -> withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do code <- issueCode cc BTSupporter 1 redeemFirstBadge alice code + since <- testClockTime bsClock alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) - alice <## "cannot get badge: badge already active" - rowCount (chatController alice) "badge_store_receipts" `shouldReturn` 0 + alice <##. "1: supporter" + storePurchaseOpen alice "" + (at, failure) <- waitStoreReceiptDeferred (chatController alice) since + failure `shouldSatisfy` T.isPrefixOf "unexpected " + at `shouldSatisfy` (> addUTCTime (nominalDay - 60) since) + heldStoreReceipts (chatController alice) `shouldReturn` 1 rowCount cc "sx_badge_service_payments" `shouldReturn` 0 testPurchaseSameReceiptOtherProfile :: HasCallStack => TestParams -> IO () @@ -1770,9 +1796,8 @@ testPurchaseSameReceiptOtherProfile ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) - alice <## "badge redeemed" - alice <## "supporter badge - active" - alice <##. "expires " + storePurchaseOpen alice "" + storePurchaseCredited alice "" "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 @@ -1784,19 +1809,21 @@ testPurchaseSameReceiptOtherProfile ps = testPurchaseStrandedUnderOtherProfile :: HasCallStack => TestParams -> IO () testPurchaseStrandedUnderOtherProfile ps = - withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = store} -> + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc, bsStore = store} -> withNewTestChatCfg ps 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 - alice <## "cannot get badge: badge service error: payment_pending" + storePurchaseOpen alice "" + _ <- waitStoreReceiptDeferred (chatController alice) since alice ##> "/create user alisa" showActiveUser alice "alisa" settlePending store - -- presented again under whichever profile is active, the purchase reaches the keys alice stashed + -- handed over again under whichever profile is active, the purchase stays with the keys alice holds alice ##> unsettled 2 - alice <## "[user: alice] badge redeemed" - alice <## "supporter badge - active" - alice <##. "expires " + storePurchaseOpen alice "[user: alice] " + retryStoreReceiptsAfter alice bsClock 300 + storePurchaseCredited alice "[user: alice] " "1: supporter" (alice TestParams -> IO () testPurchaseDeliveredToHiddenProfile ps = - withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsStore = store} -> + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} -> withNewTestChatCfg ps 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 - alice <## "cannot get badge: badge service error: payment_pending" + storePurchaseOpen alice "" + _ <- waitStoreReceiptDeferred (chatController alice) since alice ##> "/create user alisa" showActiveUser alice "alisa" alice ##> "/_hide user 1 \"password\"" @@ -1817,9 +1846,12 @@ testPurchaseDeliveredToHiddenProfile ps = alice <## "messages are hidden (use /tail to view)" alice <## "profile is hidden" settlePending store - -- the answer is the hidden owner's, so the view prints none of it + -- the answer and the credit are the hidden owner's, so the view prints none of them alice ##> unsettled 2 (alice "/user alice password" showActiveUser alice "alice (Alice, * supporter)" @@ -1831,9 +1863,8 @@ testInvoiceOtherProfile ps = alice ##> "/create user alisa" showActiveUser alice "alisa" alice ##> purchaseWithInvoice 2 invoiceId supporterPlay - alice <## "[user: alice] badge redeemed" - alice <## "supporter badge - active" - alice <##. "expires " + alice <##. ("[user: alice] store purchase open: invoice " <> invoiceId <> ", transaction ") + storePurchaseCredited alice "[user: alice] " "1: supporter" (alice "/user alice" @@ -1845,9 +1876,8 @@ testInvoiceSameReceiptTwice ps = withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do invoiceId <- createInvoice alice 1 alice ##> purchaseWithInvoice 1 invoiceId supporterPlay - alice <## "badge redeemed" - alice <## "supporter badge - active" - alice <##. "expires " + alice <##. ("store purchase open: invoice " <> invoiceId <> ", transaction ") + storePurchaseCredited alice "" "1: supporter" alice ##> purchaseWithInvoice 1 invoiceId supporterPlay alice <## "badge already redeemed" storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack invoiceId), True)] @@ -1862,9 +1892,8 @@ 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 <## "badge redeemed" - alice <## "supporter badge - active" - alice <##. "expires " + alice <##. ("store purchase open: invoice " <> unknown <> ", transaction ") + storePurchaseCredited alice "" "1: supporter" storeReceiptRows (chatController alice) `shouldReturn` [(2, Just (T.pack unknown), True)] testInvoiceLateReceipt :: HasCallStack => TestParams -> IO () @@ -1873,14 +1902,11 @@ testInvoiceLateReceipt ps = withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do invoiceId <- createInvoice alice 1 getCurrentTime >>= setClockAt clock . addUTCTime (8 * nominalDay) - alice ##> "/_badge state 1" - (alice "/create user alisa" showActiveUser alice "alisa" alice ##> purchaseWithInvoice 2 invoiceId supporterPlay - alice <## "[user: alice] badge redeemed" - alice <## "supporter badge - active" - alice <##. "expires " + alice <##. ("[user: alice] store purchase open: invoice " <> invoiceId <> ", transaction ") + storePurchaseCredited alice "[user: alice] " "1: supporter" (alice do 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 <## "cannot get badge: badge service error: payment_pending" + 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") + alice <## ("store purchase open: invoice " <> unpaid) + alice <##. ("store purchase open: invoice " <> presented <> ", transaction ") + alice <##. ("store purchase open: invoice " <> refused <> ", transaction ") + alice <## "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" alice <## ("store purchase open: invoice " <> unpaid) alice <##. ("store purchase open: invoice " <> presented <> ", transaction ") - getCurrentTime >>= setClockAt clock . addUTCTime (8 * nominalDay) - alice ##> "/_badge state 1" - alice <##. ("store purchase open: invoice " <> presented <> ", transaction ") (alice TestParams -> IO () testInvoiceRefusedBeforeCharge ps = do @@ -1917,14 +1951,19 @@ testInvoiceRefusedBeforeCharge ps = do testInvoiceWhileBadgeHeld :: HasCallStack => TestParams -> IO () testInvoiceWhileBadgeHeld ps = - withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsController = cc} -> withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do invoiceId <- createInvoice alice 1 code <- issueCode cc BTSupporter 1 redeemFirstBadge alice code + since <- testClockTime bsClock alice ##> purchaseWithInvoice 1 invoiceId supporterPlay - alice <## "cannot get badge: badge already active" + alice <##. "1: supporter" + alice <##. ("store purchase open: invoice " <> invoiceId <> ", transaction ") + (_, failure) <- waitStoreReceiptDeferred (chatController alice) since + failure `shouldSatisfy` T.isPrefixOf "unexpected " storeReceiptRows (chatController alice) `shouldReturn` [(1, Just (T.pack invoiceId), True)] + heldStoreReceipts (chatController alice) `shouldReturn` 1 rowCount cc "sx_badge_service_payments" `shouldReturn` 0 testInvoiceStateOtherProfile :: HasCallStack => TestParams -> IO () @@ -1943,6 +1982,164 @@ testInvoiceStateOtherProfile ps = alice <## ("store purchase open: invoice " <> invoiceId) (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 + storePurchaseCredited alice "" "1: supporter" + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + +testStoreReceiptNotSentEarly :: HasCallStack => TestParams -> IO () +testStoreReceiptNotSentEarly ps = do + hook <- newIORef (pure ()) + verifications <- countGoogleVerifications hook + withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} -> + withNewTestChatCfg ps 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) + heldStoreReceipts (chatController alice) `shouldReturn` 1 + +testStoreRefusalKept :: HasCallStack => TestParams -> IO () +testStoreRefusalKept ps = do + hook <- newIORef (pure ()) + verifications <- countGoogleVerifications hook + withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \BadgeServiceEnv {bsClientCfg} -> + 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" + alice ##> refused + alice <## "cannot get badge: badge service error: receipt_invalid" + alice ##> "/_badge state 1" + (alice TestParams -> IO () +testStoreSettledOtherProfile ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + shown <- createInvoice alice 1 + hidden <- createInvoice alice 1 + alice ##> "/create user alisa" + 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" + alice ##> "/_hide user 1 \"password\"" + alice <## "user alice:" + alice <## "messages are hidden (use /tail to view)" + alice <## "profile is hidden" + alice ##> purchaseWithInvoice 2 hidden (googlePayment "badge_supporter_01" "not-a-purchase-either") + (alice TestParams -> IO () +testStoreReceiptTwoAtOnce ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> + 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" + (alice TestParams -> IO () +testStoreReceiptCleanup ps = + withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = FakeStore {appleSupporterJWS}} -> do + let cfg = bsClientCfg {initialCleanupManagerDelay = 0, cleanupManagerInterval = 1, cleanupManagerStepDelay = 0} + withNewTestChatCfg ps cfg "alice" aliceProfile $ \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" + alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSupporterJWS}) + alice <## ("store purchase open: invoice " <> unpaid) + storePurchaseOpen alice "" + storePurchaseCredited alice "" "1: supporter" + -- held behind the badge credited above, so it stays held whatever the store says + since <- testClockTime bsClock + alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + alice <##. "1: supporter" + alice <## ("store purchase open: invoice " <> unpaid) + storePurchaseOpen alice "" + _ <- waitStoreReceiptDeferred (chatController alice) since + 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) + 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 + alice ##> "/create user alisa" + showActiveUser alice "alisa" + alice ##> purchaseWithInvoice 2 unpaid (googlePayment "badge_supporter_01" googlePendingToken) + alice <##. ("store purchase open: invoice " <> unpaid <> ", transaction ") + waitStoreReceiptRows (chatController alice) 3 >>= (`shouldContain` [(2, Just (T.pack unpaid), True)]) + +testStoreReceiptAttemptThrows :: HasCallStack => TestParams -> IO () +testStoreReceiptAttemptThrows ps = do + hook <- newIORef (pure ()) + verifications <- countGoogleVerifications hook + withBadgeServiceVerifier ps (googleVerifierWithHook hook) $ \BadgeServiceEnv {bsClientCfg, bsClock, bsStore = store} -> + 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 + 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 TestCC -> Int -> IO String createInvoice cc userId = do cc ##> ("/_badge invoice " <> show userId) @@ -1959,3 +2156,66 @@ storeReceiptRows ChatController {chatStore} = DB.query_ db $ "SELECT user_id, invoice_id, transaction_ref IS NOT NULL " <> "FROM badge_store_receipts ORDER BY badge_store_receipt_id" + +waitStoreReceiptRows :: HasCallStack => ChatController -> Int -> IO [(Int64, Maybe Text, Bool)] +waitStoreReceiptRows cc n = loop (100 :: Int) + where + loop 0 = storeReceiptRows cc >>= \rows -> error $ "expected " <> show n <> " store purchase records, got " <> show rows + loop i = do + rows <- storeReceiptRows cc + if length rows == n then pure rows else threadDelay 50000 >> loop (i - 1) + +heldStoreReceipts :: ChatController -> IO Int +heldStoreReceipts ChatController {chatStore} = + withTransaction chatStore $ \db -> do + [Only n] <- DB.query_ db "SELECT COUNT(*) FROM badge_store_receipts WHERE payment IS NOT NULL" + pure n + +waitHeldStoreReceipts :: HasCallStack => ChatController -> Int -> IO () +waitHeldStoreReceipts cc n = loop (100 :: Int) + where + 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) + 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) + +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. +retryStoreReceiptsAfter :: HasCallStack => TestCC -> TestClock -> NominalDiffTime -> IO () +retryStoreReceiptsAfter cc clock wait = do + testClockTime clock >>= setClockAt clock . addUTCTime (wait + 1) + cc ##> "/_app activate" + cc <## "ok" + +-- | Counts the Google verifications the service makes, re-arming the one-shot hook each time. +countGoogleVerifications :: IORef (IO ()) -> IO (IO Int) +countGoogleVerifications hook = do + n <- newIORef 0 + let count = modifyIORef' n (+ 1) >> writeIORef hook count + writeIORef hook count + pure $ readIORef n + +storePurchaseOpen :: HasCallStack => TestCC -> String -> IO () +storePurchaseOpen cc userPrefix = cc <##. (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")