dandri/simplex-chat
1
0 Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-10-22 11:52:32 +00:00
Code Issues Packages Projects Releases Wiki Activity

core, ui: buy a badge with an App Store or Google Play purchase (#7590)

Browse Source
This commit is contained in:
spaced4ndy authored and GitHub committed 2026-10-07 14:32:48 +00:00
1 parent 36da024394
commit 27d12f230d
83 files changed
+4183 -732
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

src/Simplex/Chat/Badges/Ledger.hs
+10 -7
View File
@@ -26,6 +26,7 @@ import Data.Time.Calendar.WeekDate (toWeekDate)
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime)
import Simplex.Chat.Badges (BadgeType)
import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
import Simplex.Chat.PaymentService.Types (InvoiceId)
-- The calendar difference overshoots by at most one month, so one comparison settles it.
monthsBetween :: UTCTime -> UTCTime -> Integer
@@ -204,13 +205,15 @@ debitTypeTag = \case
SDLapse -> "lapse"
SDUnknown {tag} -> tag
-- | Only the types a tag alone rebuilds, which is those whose constructor has no fields; the rest
-- answer Nothing rather than a type with an invented payload. The client also stores each type's
-- JSON and reads that first, so this is its fallback; the service has no such column.
-- TODO [badges] take the reference columns and rebuild payment, charge, transferIn, upgrade and
-- transferOut, without which the service cannot re-emit a statement carrying one.
entryTypeFromColumns :: Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType
entryTypeFromColumns entryType credit_ debit_ = case (entryType, credit_, debit_) of
-- | Rebuilds only what the columns determine: constructors with no fields, and a payment credit.
-- payment_ is Nothing when the row references no payment, and Just Nothing when that payment had no
-- invoice, as a store purchase has none. The rest answer Nothing rather than invent a payload.
-- The client stores each type's JSON and reads that first, so this is its fallback; the service has none.
-- TODO [badges] rebuild charge, transferIn, upgrade and transferOut from their reference columns,
-- without which the service cannot re-emit a statement carrying one.
entryTypeFromColumns :: Maybe (Maybe InvoiceId) -> Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType
entryTypeFromColumns payment_ entryType credit_ debit_ = case (entryType, credit_, debit_) of
("credit", Just "payment", _) -> SECredit . SCPayment <$> payment_
("credit", Just t, _) -> SECredit <$> creditType t
("debit", _, Just t) -> SEDebit <$> debitType t
_ -> Nothing
src/Simplex/Chat/Badges/Service.hs
+2 -2
View File
@@ -87,12 +87,12 @@ data BadgeServiceCommand
code :: Text -- no badgeRequest: a code carries no tier for the client to state
}
| BSCPurchaseBadge
{ badgeRequest :: BadgeRequest,
{ masterKey :: BadgeMasterKey, -- no badgeRequest: the tier is the product's, the expiry the one every credential of that week shares
payment :: ServicePayment,
upgrade :: Maybe BadgeUpgrade -- upgrade store 1-time badge
}
| BSCUpgradeBadgeSubscription
{ badgeRequest :: BadgeRequest,
{ badgeRequest :: BadgeRequest, -- TODO [badges] drop when implemented: a client-stated expiry leaves the week's anonymity set
payment :: ServicePayment, -- store payments only
balance :: BadgeBalance
}
src/Simplex/Chat/Badges/Types.hs
+18 -1
View File
@@ -30,6 +30,7 @@ module Simplex.Chat.Badges.Types
BadgeAlert (..),
BadgeAlertPrice (..),
BadgeState (..),
OpenStorePurchase (..),
) where
import Control.Applicative ((<|>))
@@ -43,7 +44,7 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Word (Word8)
import Simplex.Chat.Badges hiding (BadgePurchase (..))
import Simplex.Chat.PaymentService.Types (InvoiceId, PaymentId, StoredPayment)
import Simplex.Chat.PaymentService.Types (InvoiceId, PaymentId)
import Simplex.Chat.Types (BoolDef (..))
import Simplex.Messaging.Agent.Protocol (UserId)
import Simplex.Messaging.Agent.Store.DB (fromTextField_)
@@ -236,6 +237,7 @@ data BadgeServiceErrorCode
| BSEPaymentNotEntitled
| BSEPaymentPending
| BSEProviderUnavailable
| BSEProviderNotConfigured -- no verifier deployed: a dev service, not the store failing to answer
| BSERateLimited
| BSECodeInvalid
| BSECodeUsed
@@ -281,6 +283,17 @@ data BadgeState = BadgeState
}
deriving (Show)
-- | 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,
creditError :: Maybe BadgeIssueFailure
}
deriving (Show)
instance TextEncoding BadgePurchaseStatus where
textEncode = \case
PSAcquiring -> "acquiring"
@@ -325,6 +338,7 @@ instance TextEncoding BadgeServiceErrorCode where
BSEPaymentNotEntitled -> "payment_not_entitled"
BSEPaymentPending -> "payment_pending"
BSEProviderUnavailable -> "provider_unavailable"
BSEProviderNotConfigured -> "provider_not_configured"
BSERateLimited -> "rate_limited"
BSECodeInvalid -> "code_invalid"
BSECodeUsed -> "code_used"
@@ -344,6 +358,7 @@ instance TextEncoding BadgeServiceErrorCode where
"payment_not_entitled" -> BSEPaymentNotEntitled
"payment_pending" -> BSEPaymentPending
"provider_unavailable" -> BSEProviderUnavailable
"provider_not_configured" -> BSEProviderNotConfigured
"rate_limited" -> BSERateLimited
"code_invalid" -> BSECodeInvalid
"code_used" -> BSECodeUsed
@@ -410,3 +425,5 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BIF") ''BadgeIssueFailure)
$(JQ.deriveJSON defaultJSON ''BadgeIssueError)
$(JQ.deriveJSON defaultJSON ''BadgeState)
$(JQ.deriveJSON defaultJSON ''OpenStorePurchase)
src/Simplex/Chat/Controller.hs
+12 -2
View File
@@ -85,7 +85,8 @@ import Simplex.Messaging.Client (HostMode (..), SMPProxyFallback (..), SMPProxyM
import qualified Simplex.Messaging.Crypto as C
import Simplex.Chat.Badges (BadgeCredential, FileSizeLimits, LocalBadge)
import Simplex.Chat.Badges.Service (BadgeServiceErrorCode, StatementEntry)
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeState (..))
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeState (..), OpenStorePurchase (..))
import Simplex.Chat.PaymentService (ServicePayment)
import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import qualified Simplex.Messaging.Crypto.File as CF
@@ -152,6 +153,8 @@ data ChatConfig = ChatConfig
badgeCurrentTime :: IO UTCTime,
-- how long a badge worker waits before repeating a renewal that failed for a passing reason
badgeRetryInterval :: RetryInterval,
-- attempts a store receipt gets in one turn before its next one waits for the stored schedule
badgeConsecutiveRetries :: Int,
confirmMigrations :: MigrationConfirmation,
presetServers :: PresetServers,
shortLinkPresetServers :: NonEmpty SMPServer,
@@ -327,6 +330,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 Worker,
badgeSeq :: TVar Int,
relayGroupLinkChecksAsync :: TVar (Maybe (Async ())),
webPreviewState :: Maybe WebPreviewState,
@@ -659,6 +663,8 @@ 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} -- 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
-- episode is last because it is free text: it is the value that makes one occurrence of an
@@ -869,7 +875,8 @@ data ChatResponse
| CRServiceResponse {user :: User, responseData :: J.Object}
| CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId}
| CRBadgeRedeemed {user :: User, redeemedBadge :: LocalBadge, newBadge :: Bool, badgeState :: Maybe BadgeState}
| CRBadgeState {user :: User, badgeState :: Maybe BadgeState}
| CRBadgeInvoice {user :: User, invoiceId :: Text}
| CRBadgeState {user :: User, badgeState :: Maybe BadgeState, storePurchases :: [OpenStorePurchase]}
| CRBadgeLedger {user :: User, badgeLedger :: [StatementEntry]}
| CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}
| CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool, msgSigned :: Bool}
@@ -990,6 +997,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}
| CEvtStorePurchaseResolved {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}
@@ -1479,8 +1487,10 @@ data SimplexDomainError
| SDEUnknownDomain -- the resolved link's profile has no name, or a different name
deriving (Eq, Show)
-- | Why acquiring a badge failed, for a code and for a store purchase alike.
data BadgeRedeemError
= BREInvalidCode -- format or check character
| BREInvalidReceipt -- names no transaction, or is not a store payment
| BREServiceNotConfigured
| BREBadgeActive
| BREServiceError {serviceError :: BadgeServiceErrorCode}
src/Simplex/Chat/Library/Commands.hs
+204 -29
View File
@@ -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)
@@ -76,6 +76,8 @@ import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.Operators
import Simplex.Chat.Options
import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef)
import Simplex.Chat.PaymentService.Types (PaymentProvider (..), StoreTransactionRef (..))
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
import Simplex.Chat.Protocol
import Simplex.Chat.Remote
@@ -103,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, 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 (..), withRetryInterval)
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay, withRetryInterval, withRetryIntervalCount)
import Simplex.Messaging.Agent.Store.Entity
import Simplex.Messaging.Agent.Store.Interface (execSQL)
import Simplex.Messaging.Agent.Store.Shared (upMigration)
@@ -261,6 +264,7 @@ startChatController mainApp enableSndFiles serviceRequests = do
startRelayRequestWorker_
startCleanupManager
mapM_ startBadgeWork users
startStoreReceiptWorkers users
void $ forkIO $ mapM_ startExpireCIs users
startRelayChecks users
startWebPreview users
@@ -279,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
@@ -357,7 +365,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
@@ -371,6 +379,7 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles,
clearMap deliveryJobWorkers >>= mapM_ cancelWorker
clearMap relayRequestWorkers >>= mapM_ cancelWorker
stopBadgeWorkers badgeWorkers
clearMap storeReceiptWorkers >>= mapM_ cancelWorker
closeFiles sndFiles
closeFiles rcvFiles
atomically $ do
@@ -603,6 +612,7 @@ processChatCommand cxt nm = \case
void . forkIO $ startFilesToReceive users
setAllExpireCIFlags True
mapM_ startBadgeWork users
mapM_ startStoreReceiptWork users
ok_
APISuspendChat t -> do
chatWriteVar chatActivated False
@@ -3562,10 +3572,19 @@ 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 -> handOverStoreReceipt user echoedInvoiceId payment
APICreateBadgeInvoice userId -> withUserId userId $ \user -> do
void requireBadgeService
refuseWhileBadgeHeld user
g <- asks random
now <- badgeNow
invoiceId <- UUID.toText <$> liftIO V4.nextRandom
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
lift $ startBadgeWork user
CRBadgeState user <$> getUserBadgeState user
badgeStateResponse user
APIGetBadgeLedger userId badgePurchaseId -> withUserId userId $ \user ->
CRBadgeLedger user <$> withStore' (\db -> getBadgeLedger db user badgePurchaseId)
APIAckBadgeAlert userId badgePurchaseId alertKind snooze episode -> withUserId userId $ \user -> do
@@ -3574,7 +3593,7 @@ processChatCommand cxt nm = \case
withStore' $ \db -> setBadgeAlertAcked db user badgePurchaseId alertKind episode snoozeUntil
-- after the write, so the pass it signals arms a wake for the snooze rather than raising again
lift $ startBadgeWork user
CRBadgeState user <$> getUserBadgeState user
badgeStateResponse user
SetBotCommands commands -> withUser $ \user@User {profile} -> do
let LocalProfile {preferences} = profile
prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands}
@@ -5219,30 +5238,20 @@ presentUserBadgeToContacts user'@User {userId, profile = LocalProfile {localBadg
redeemBadgeCode :: NetworkRequestMode -> User -> Text -> CM ChatResponse
redeemBadgeCode nm user@User {userId} codeText = do
code <- maybe (throwRedeemError BREInvalidCode) pure $ parseBadgeCode codeText
sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwRedeemError BREServiceNotConfigured) pure
sendTarget <- requireBadgeService
g <- asks random
now <- liftIO getCurrentTime
let codeSent = badgeCodeText code
-- the guard, the request and the write are one section: without it two codes redeemed at once
-- both pass the guard and are both spent, for one badge
(present_, redeemed) <- withEntityLock "badgeRedeem" (CLBadgeUser userId) $ do
redemption_ <- withStore' $ \db -> getBadgeCodeRedemption db user codeSent
-- a code already redeemed here is allowed through: re-sending it returns the badge it bought
-- and adds nothing. Refused before its keys are stashed and before the request, so it stays unspent
replaying <- maybe (pure False) (\r -> withStore' $ \db -> isJust <$> getCodeBadgePurchase db r) redemption_
unless replaying $ whenM (withStore' (`userHasBadge` user)) $ throwRedeemError BREBadgeActive
redemption@BadgeCodeRedemption {purchaseKey, purchasePrivKey, masterKey} <-
maybe (withStore' $ \db -> createBadgeCodeRedemption db g user codeSent now) pure redemption_
let req = BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request = BSCRedeemBadgeCode {masterKey, code = codeSent}}
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 (terminalCodeError errCode) $ withStore' $ \db -> deleteBadgeCodeRedemption db (redemptionId redemption)
stash_ <- withStore' $ \db -> getBadgeCodeRedemption db user codeSent
stash@BadgeStash {masterKey} <- stashBadgeKeys user stash_ $ \db -> createBadgeCodeRedemption db g user codeSent now
requestBadgeStash nm user sendTarget stash BSCRedeemBadgeCode {masterKey, code = codeSent} >>= \case
Left (errCode, _) -> do
when (terminalCodeError errCode) $ withStore' $ \db -> deleteBadgeCodeRedemption db user codeSent
throwRedeemError $ BREServiceError errCode
J.Success BSPBadgeCredential {credential = Just cred, statement} -> storeRedeemedBadge user redemption cred statement
J.Success _ -> throwRedeemError $ BREInvalidResponse "unexpected response type"
Right redeemed -> pure redeemed
-- outside the badge lock: the chat lock must not be taken under it
mapM_ presentUserBadgeToContacts present_
pure redeemed
@@ -5254,6 +5263,69 @@ redeemBadgeCode nm user@User {userId} codeText = do
BSECodeExpired -> True
_ -> False
-- | 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
void requireBadgeService
g <- asks random
now <- badgeNow
BadgeReceiptRecord {ownerId, status} <-
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
case status of
RSHeld {} -> lift (resumeStoreReceiptWork ownerId) >> 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"
-- | 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
storeTransactionRef = \case
SPApple {jws} -> StoreTransactionRef PPApple <$> appleTransactionId jws
SPGoogle {token} -> Just $ StoreTransactionRef PPGoogle $ googlePurchaseRef token
SPInvoice {} -> Nothing
SPReceipt {} -> Nothing
-- | A stash that already bought a badge here passes, as re-sending it adds nothing; any other is
-- refused while a badge is held, before its keys are stashed or sent, so the funding stays unspent.
stashBadgeKeys :: User -> Maybe BadgeStash -> (DB.Connection -> IO BadgeStash) -> CM BadgeStash
stashBadgeKeys user stash_ createStash = do
replaying <- maybe (pure False) (\s -> withStore' $ \db -> isJust <$> getStashBadgePurchase db s) stash_
unless replaying $ refuseWhileBadgeHeld user
maybe (withStore' createStash) pure stash_
requireBadgeService :: CM (ConnectTarget 'CMContact)
requireBadgeService = asks (badgeServiceAddress . config) >>= maybe (throwRedeemError BREServiceNotConfigured) pure
refuseWhileBadgeHeld :: User -> CM ()
refuseWhileBadgeHeld user = whenM (withStore' (`userHasBadge` user)) $ throwRedeemError BREBadgeActive
-- | One attempt to turn a stash into a badge. 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, 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
throwRedeemError = throwChatError . CEBadgeRedeemError
@@ -5362,6 +5434,89 @@ waitBadgeWake badgeWork now = \case
badgeMaxWake :: NominalDiffTime
badgeMaxWake = 100 * 365 * nominalDay
startStoreReceiptWork :: User -> CM ()
startStoreReceiptWork User {userId} = do
held <- withStore' $ \db -> getNextHeldStoreReceipt db userId
when (either (const False) isJust held) $ lift $ resumeStoreReceiptWork userId
resumeStoreReceiptWork :: UserId -> CM' ()
resumeStoreReceiptWork userId = do
ws <- asks storeReceiptWorkers
a <- asks smpAgent
void $ getAgentWorker "store_receipt" True a userId ws $ runStoreReceiptWorker a userId
runStoreReceiptWorker :: AgentClient -> UserId -> Worker -> CM ()
runStoreReceiptWorker a userId Worker {doWork} = do
scheduled <- newTVarIO S.empty
forever $ do
lift $ waitForWork doWork
withWork_ a doWork (getDueReceipt scheduled) $ \case
BadgeReceiptRecord {receiptId, status = RSHeld {stash, payment, retryDelay}} -> creditStoreReceipt a userId receiptId stash payment retryDelay
BadgeReceiptRecord {receiptId} -> notHeld receiptId
where
getDueReceipt scheduled =
withStore' (`getNextHeldStoreReceipt` userId) >>= \case
Right (Just r@BadgeReceiptRecord {receiptId, status = RSHeld {nextAttemptAt}}) -> do
now <- badgeNow
if nextAttemptAt <= now
then pure $ Right (Just r)
else Right Nothing <$ scheduleReceipt scheduled receiptId (diffUTCTime nextAttemptAt now)
Right (Just BadgeReceiptRecord {receiptId}) -> Right Nothing <$ notHeld receiptId
r -> pure r
-- getNextHeldStoreReceipt reads held rows only, so this says its query and its result type disagree
notHeld receiptId = eToView $ ChatError $ CEInternalError $ "store receipt " <> show receiptId <> " is not held"
scheduleReceipt scheduled receiptId delay = do
new <- atomically $ stateTVar scheduled $ \ids -> (S.notMember receiptId ids, S.insert receiptId ids)
when new . void . liftIO . forkIO $ do
threadDelay' $ diffToMicroseconds delay
atomically $ modifyTVar' scheduled $ S.delete receiptId
void $ atomically $ tryPutTMVar doWork ()
data StoreReceiptOutcome = SROCredited (Maybe User) | SRORefused | SRORetry | SRODeferred
-- | Under the owner's badge lock, which keeps a profile's requests to the service serial.
creditStoreReceipt :: AgentClient -> UserId -> Int64 -> BadgeStash -> Text -> Maybe Int64 -> CM ()
creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} payment retryDelay = do
ChatConfig {badgeRetryInterval = ri, badgeConsecutiveRetries} <- asks config
withRetryIntervalCount (maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) retryDelay) $ \n delay loop -> do
liftIO $ waitWhileSuspended a
liftIO $ waitForUserNetwork a
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 ri delay (serviceFailure code retryAfter) retryAfter
Left e -> failed ri delay (badgeIssueFailure e) Nothing
-- only a settlement is announced, and the sweep it prompts signals this worker only for a receipt still held, so it cannot loop
case outcome of
SROCredited present_ -> do
user <- withStore $ \db -> getUser db userId
toView . CEvtBadgeChanged user =<< getUserBadgeState user
toView $ CEvtStorePurchaseResolved 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 . CEvtStorePurchaseResolved
SRORetry | n + 1 < badgeConsecutiveRetries -> loop
_ -> 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}
failed ri delay failure retryAfter = do
now <- badgeNow
let (retryIn, outcome)
| isJust retryAfter = (badgeRetryAfter ri retryAfter, SRODeferred)
-- a buyer is waiting, so unlike a renewal a failure that can clear on its own never waits the day
| badgeFailureTransient failure = (fromIntegral delay / 1000000, SRORetry)
| otherwise = (badgeStalledInterval, SRODeferred)
withStore' $ \db -> recordStoreReceiptFailure db receiptId (nextRetryDelay 0 delay ri) (retryIn `addUTCTime` now) failure
pure outcome
-- | 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)
@@ -5439,6 +5594,15 @@ emitBadgeAlert user emitted p@UserBadgePurchase {alertSnoozeUntil} shownCred now
raised <- atomically $ stateTVar emitted (,occurrence)
when (raised /= occurrence) $ toView $ CEvtBadgeAlert user alert
-- | Scoped to one profile, so another profile's store purchase, which may be hidden, never shows under it.
badgeStateResponse :: User -> CM ChatResponse
badgeStateResponse user = do
badgeState <- getUserBadgeState user
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)
getUserBadgeState user = do
@@ -5472,9 +5636,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.
@@ -5531,6 +5696,8 @@ badgeIssueFailure e = case e of
| otherwise -> BIFUnexpected {message = tshow agentError}
ChatError (CECommandError m) -> BIFUnexpected {message = T.pack m}
ChatError (CEInternalError m) -> BIFUnexpected {message = T.pack m}
ChatError (CEBadgeRedeemError BREUnknownKeyIndex) -> BIFInvalidCredential
ChatError (CEBadgeRedeemError BRECredentialNotVerified) -> BIFInvalidCredential
_ -> BIFUnexpected {message = tshow e}
-- | Whether a failure can clear on its own, which decides whether the alert waits for the shown
@@ -5654,8 +5821,8 @@ stopBadgeWorkers workers =
-- | Verify the credential before writing anything; the purchase, the statement's rows, the
-- issuance and the profile's badge go in one transaction. Answers the user to tell contacts about,
-- which the caller does once the badge lock is released.
storeRedeemedBadge :: User -> BadgeCodeRedemption -> BadgeCredential -> BadgeStatement -> CM (Maybe User, ChatResponse)
storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement =
storeRedeemedBadge :: User -> BadgeStash -> BadgeCredential -> BadgeStatement -> CM (Maybe User, ChatResponse)
storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement =
verifyOwnBadge cred >>= \case
Nothing -> throwRedeemError BREUnknownKeyIndex
Just False -> throwRedeemError BRECredentialNotVerified
@@ -5668,7 +5835,7 @@ storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey}
let badge = OwnBadge cred (mkBadgeStatus now (Just True) info)
-- TODO [badges] retire a previously held badge
(user', newBadge, applied) <- withStore $ \db -> do
(purchaseId, newBadge) <- liftIO $ createCodeBadgePurchase db user redemption cred now
(purchaseId, newBadge) <- liftIO $ createStashBadgePurchase db user stash cred now
applied <- liftIO $ applyBadgeStatement db g purchaseId badgeType statement (Just cred) now
-- a replay must not put a superseded badge back, or tell every contact again
user' <- if newBadge then setUserBadge db user (Just badge) else getUser db userId
@@ -5818,6 +5985,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
@@ -5887,6 +6055,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
@@ -6109,6 +6282,8 @@ chatCommandP =
"/_reject " *> (APIRejectContact <$> A.decimal <*> (" notify=" *> onOffP <|> pure False)),
"/_service_request " *> (APISendServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (" timeout=" *> (realToFrac <$> A.double)) <*> optional (" sign_key=" *> strP) <* A.space <*> jsonP),
"/_redeem_badge_code " *> (APIRedeemBadgeCode <$> A.decimal <* A.space <*> textP),
"/_badge purchase " *> (APIPurchaseBadge <$> A.decimal <*> optional (" invoice=" *> (safeDecodeUtf8 <$> A.takeTill (== ' '))) <* A.space <*> jsonP),
"/_badge invoice " *> (APICreateBadgeInvoice <$> A.decimal),
"/_badge state " *> (APIGetBadgeState <$> A.decimal),
"/_badge ledger " *> (APIGetBadgeLedger <$> A.decimal <* A.space <*> A.decimal),
"/_badge ack " *> (APIAckBadgeAlert <$> A.decimal <* A.space <*> A.decimal <* A.space <*> badgeAlertKindP <* A.space <*> onOffP <* A.space <*> textP),
src/Simplex/Chat/PaymentService.hs
+25 -1
View File
@@ -1,17 +1,28 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Chat.PaymentService
( ServiceInvoice (..),
ServicePayment (..),
appleTransactionId,
googlePurchaseRef,
module Simplex.Chat.PaymentService.Types,
) where
import qualified Data.Aeson as J
import qualified Data.Aeson.KeyMap as JM
import qualified Data.Aeson.TH as JQ
import qualified Data.ByteString.Base64.URL as B64U
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime)
import Simplex.Chat.PaymentService.Types
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String (strEncode)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
data ServiceInvoice = ServiceInvoice
{ invoiceId :: InvoiceId,
@@ -27,11 +38,24 @@ data ServiceInvoice = ServiceInvoice
data ServicePayment
= SPApple {jws :: Text}
| SPGoogle {token :: Text}
| SPGoogle {productId :: Text, token :: Text} -- the Publisher API finds a purchase by product and token
| SPInvoice {invoiceId :: InvoiceId}
| SPReceipt {receipt :: Text} -- transfer of unissued months
deriving (Show)
-- | Read without verifying the signature: it names the transaction, and proves nothing about it.
appleTransactionId :: Text -> Maybe Text
appleTransactionId signed = case T.splitOn "." signed of
[_, payload, _] -> do
J.Object o <- J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload)
J.String txId <- JM.lookup "transactionId" o
pure txId
_ -> Nothing
-- | A purchase token is a bearer secret, so a purchase is named by its hash.
googlePurchaseRef :: Text -> Text
googlePurchaseRef = safeDecodeUtf8 . strEncode . C.sha256Hash . encodeUtf8
$(JQ.deriveJSON defaultJSON ''ServiceInvoice)
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SP") ''ServicePayment)
src/Simplex/Chat/PaymentService/Types.hs
+38
View File
@@ -1,6 +1,9 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Chat.PaymentService.Types
@@ -8,6 +11,7 @@ module Simplex.Chat.PaymentService.Types
InvoiceId (..),
PaymentId (..),
PaymentProvider (..),
StoreTransactionRef (..),
CardProvider (..),
CryptoCurrency (..),
ServicePaymentMethod (..),
@@ -26,7 +30,16 @@ import Data.ByteString.Char8 (ByteString)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Data.Word (Word32)
import Simplex.Messaging.Agent.Store.DB (fromTextField_)
import Simplex.Messaging.Encoding.String (TextEncoding (..))
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON)
#if defined(dbPostgres)
import Database.PostgreSQL.Simple.FromField (FromField (..))
import Database.PostgreSQL.Simple.ToField (ToField (..))
#else
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
#endif
-- USD etc. are in minor units, following Stripe etc. convention
newtype CurrencyAmount = CurrencyAmount Word32
@@ -45,6 +58,31 @@ newtype PaymentId = PaymentId Text
data PaymentProvider = PPApple | PPGoogle | PPStripe | PPCrypto | PPCode | PPReceipt
deriving (Eq, Show)
instance TextEncoding PaymentProvider where
textEncode = \case
PPApple -> "apple"
PPGoogle -> "google"
PPStripe -> "stripe"
PPCrypto -> "crypto"
PPCode -> "code"
PPReceipt -> "receipt"
textDecode = \case
"apple" -> Just PPApple
"google" -> Just PPGoogle
"stripe" -> Just PPStripe
"crypto" -> Just PPCrypto
"code" -> Just PPCode
"receipt" -> Just PPReceipt
_ -> Nothing
instance FromField PaymentProvider where fromField = fromTextField_ textDecode
instance ToField PaymentProvider where toField = toField . textEncode
-- | The stable name of one store transaction, by which a retry resolves to the same row.
data StoreTransactionRef = StoreTransactionRef {provider :: PaymentProvider, transactionRef :: Text}
deriving (Eq, Show)
data CardProvider = CPStripe
deriving (Eq, Show)
src/Simplex/Chat/Store/Badges.hs
+216 -36
View File
@@ -7,7 +7,8 @@
{-# LANGUAGE TypeOperators #-}
module Simplex.Chat.Store.Badges
( BadgeCodeRedemption (..),
( BadgeStash (..),
BadgeStashRef (..),
UserBadgePurchase (..),
getUserBadgePurchase,
getBadgePurchase,
@@ -18,9 +19,18 @@ module Simplex.Chat.Store.Badges
clearShownBadge,
getBadgeCodeRedemption,
createBadgeCodeRedemption,
BadgeReceiptRecord (..),
BadgeReceiptStatus (..),
holdStoreReceipt,
createBadgeStoreReceipt,
getOpenStorePurchases,
getNextHeldStoreReceipt,
recordStoreReceiptFailure,
refuseStoreReceipt,
deleteUnfundedStoreReceipts,
deleteBadgeCodeRedemption,
createCodeBadgePurchase,
getCodeBadgePurchase,
createStashBadgePurchase,
getStashBadgePurchase,
storeBadgeIssuance,
getLatestIssuedCredential,
storeBadgeStatement,
@@ -31,8 +41,10 @@ module Simplex.Chat.Store.Badges
where
import Control.Concurrent.STM (TVar, atomically)
import Control.Monad (forM, forM_, join)
import Crypto.Random (ChaChaDRG)
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.Maybe (isJust, mapMaybe)
@@ -41,9 +53,12 @@ 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 (..))
import Simplex.Chat.Store.Shared (insertedRowId)
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 (StoreError, insertedRowId)
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (UserId)
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
import qualified Simplex.Messaging.Agent.Store.DB as DB
import qualified Simplex.Messaging.Crypto as C
@@ -58,18 +73,20 @@ import Database.SQLite.Simple (Only (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql)
#endif
-- | The keys one redemption attempt is signed with, stashed before the request is sent so that a
-- retry reaches the service as the same signer and is answered with the credential already issued.
data BadgeCodeRedemption = BadgeCodeRedemption
{ redemptionId :: Int64,
-- | The keys one attempt to fund a badge is signed with, stashed before the request is sent so that
-- a retry reaches the service as the same signer and is answered with the credential already issued.
data BadgeStash = BadgeStash
{ stashRef :: BadgeStashRef,
purchaseKey :: C.PublicKeyEd25519,
purchasePrivKey :: C.PrivateKeyEd25519,
masterKey :: BadgeMasterKey
}
getBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO (Maybe BadgeCodeRedemption)
data BadgeStashRef = BSRCodeRedemption Int64 | BSRStoreReceipt Int64
getBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO (Maybe BadgeStash)
getBadgeCodeRedemption db User {userId} code =
maybeFirstRow toRedemption $
maybeFirstRow (toBadgeStash BSRCodeRedemption) $
DB.query
db
[sql|
@@ -78,11 +95,8 @@ getBadgeCodeRedemption db User {userId} code =
WHERE user_id = ? AND code = ?
|]
(userId, code)
where
toRedemption (redemptionId, purchaseKey, purchasePrivKey, Binary mk) =
BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk}
createBadgeCodeRedemption :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO BadgeCodeRedemption
createBadgeCodeRedemption :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO BadgeStash
createBadgeCodeRedemption db g User {userId} code now = do
(purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g
masterKey@(BadgeMasterKey mk) <- generateMasterKey g
@@ -94,42 +108,205 @@ createBadgeCodeRedemption db g User {userId} code now = do
|]
(userId, code, purchaseKey, purchasePrivKey, Binary mk, now)
redemptionId <- insertedRowId db
pure BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey}
pure BadgeStash {stashRef = BSRCodeRedemption redemptionId, purchaseKey, purchasePrivKey, masterKey}
-- | Drop a stashed attempt whose code the service refused for good, unless a purchase already
-- came from it - badge_purchases references this row.
deleteBadgeCodeRedemption :: DB.Connection -> Int64 -> IO ()
deleteBadgeCodeRedemption db redemptionId =
-- | Our record of a store receipt, as against the receipt itself: held until the service credits or refuses it.
data BadgeReceiptRecord = BadgeReceiptRecord
{ receiptId :: Int64,
ownerId :: UserId,
status :: BadgeReceiptStatus
}
data BadgeReceiptStatus
= RSHeld {stash :: BadgeStash, payment :: Text, nextAttemptAt :: UTCTime, retryDelay :: Maybe Int64}
| RSCredited {badgePurchaseId :: Int64}
| RSRefused {refusal :: Maybe BadgeIssueFailure}
-- | Resolves a store transaction to the record that owns it, looking up by its reference again after each step
-- rather than trusting the write: finding none still leaves the echoed invoice's record to attach it to, and a
-- concurrent hand-over of the same transaction may win either write. It stays with the record that already has
-- it, whose keys the service may have credited; failing that it joins the record Buy created; and only when the
-- store echoed no invoice does the presenting profile get a new one, nothing else saying who paid.
holdStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Maybe Text -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO (Maybe BadgeReceiptRecord)
holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} payment now =
getReceiptRecord db txRef >>= \case
Just r@BadgeReceiptRecord {receiptId} -> do
-- a resolved record stays resolved, 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
Nothing -> do
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)
getReceiptRecord db txRef >>= \case
Just r -> pure $ Just r
Nothing -> do
insertReceipt
getReceiptRecord db txRef
where
paymentJSON = safeDecodeUtf8 . LB.toStrict $ J.encode payment
insertReceipt = do
(purchaseKey, purchasePrivKey) <- atomically (C.generateKeyPair g) :: IO C.KeyPairEd25519
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))
getReceiptRecord :: DB.Connection -> StoreTransactionRef -> IO (Maybe BadgeReceiptRecord)
getReceiptRecord db StoreTransactionRef {provider, transactionRef} =
maybeFirstRow toReceiptRecord $
DB.query
db
[sql|
SELECT r.badge_store_receipt_id, r.user_id, r.purchase_key, r.purchase_priv_key, r.master_key,
r.payment, r.next_attempt_at, r.retry_delay, 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 = ?
|]
(provider, transactionRef)
where
toReceiptRecord ((receiptId, ownerId, purchaseKey, purchasePrivKey, mk) :. (payment_, nextAttemptAt_, retryDelay, purchaseId_, refusal)) =
BadgeReceiptRecord {receiptId, ownerId, status}
where
status = case (payment_, nextAttemptAt_) of
(Just payment, Just nextAttemptAt) -> RSHeld {stash = toBadgeStash BSRStoreReceipt (receiptId, purchaseKey, purchasePrivKey, mk), payment, nextAttemptAt, retryDelay}
_ -> maybe (RSRefused refusal) RSCredited purchaseId_
-- | 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) :: IO C.KeyPairEd25519
BadgeMasterKey mk <- generateMasterKey g
DB.execute
db
[sql|
INSERT INTO badge_store_receipts (user_id, invoice_id, purchase_key, purchase_priv_key, master_key, created_at)
VALUES (?,?,?,?,?,?)
|]
(userId, invoiceId, purchaseKey, purchasePrivKey, Binary mk, now)
-- | No receipt yet, or one held: a credited or refused record is resolved 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}
getNextHeldStoreReceipt :: DB.Connection -> UserId -> IO (Either StoreError (Maybe BadgeReceiptRecord))
getNextHeldStoreReceipt db userId =
fmap Right . maybeFirstRow toHeld $
DB.query
db
[sql|
SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.payment, r.next_attempt_at, 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 u.shown_badge_id IS NULL
ORDER BY r.next_attempt_at, r.retry_count, r.badge_store_receipt_id
LIMIT 1
|]
(Only userId)
where
toHeld (stashRow@(receiptId, _, _, _) :. (payment, nextAttemptAt, retryDelay)) =
BadgeReceiptRecord {receiptId, ownerId = userId, status = RSHeld {stash = toBadgeStash BSRStoreReceipt stashRow, payment, nextAttemptAt, retryDelay}}
recordStoreReceiptFailure :: DB.Connection -> Int64 -> Int64 -> UTCTime -> BadgeIssueFailure -> IO ()
recordStoreReceiptFailure db receiptId retryDelay nextAttemptAt failure =
DB.execute
db
[sql|
UPDATE badge_store_receipts
SET retry_delay = ?, next_attempt_at = ?, retry_count = retry_count + 1, credit_error = ?
WHERE badge_store_receipt_id = ? AND payment IS NOT NULL
|]
(retryDelay, nextAttemptAt, 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, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, 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) =
BadgeStash {stashRef = ref stashId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk}
-- | Drop the keys stashed for a code the service refused for good, unless a purchase already came
-- from them - badge_purchases references their row.
deleteBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO ()
deleteBadgeCodeRedemption db User {userId} code =
DB.execute
db
[sql|
DELETE FROM badge_code_redemptions
WHERE badge_code_redemption_id = ?
AND NOT EXISTS (SELECT 1 FROM badge_purchases WHERE badge_code_redemption_id = ?)
WHERE user_id = ? AND code = ?
AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_code_redemption_id = badge_code_redemptions.badge_code_redemption_id)
|]
(redemptionId, redemptionId)
(userId, code)
-- | 'False' when the code was already redeemed here: the service replays the credential it
-- | '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.
createCodeBadgePurchase :: DB.Connection -> User -> BadgeCodeRedemption -> BadgeCredential -> UTCTime -> IO (Int64, Bool)
createCodeBadgePurchase db User {userId} redemption credential now =
getCodeBadgePurchase db redemption >>= \case
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, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0 WHERE badge_store_receipt_id = ?" (Only storeReceiptId)
getStashBadgePurchase db stash >>= \case
Just purchaseId -> pure (purchaseId, False)
Nothing -> do
DB.execute
db
[sql|
INSERT INTO badge_purchases
(user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status, badge_code_redemption_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?)
(user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status,
badge_code_redemption_id, badge_store_receipt_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?)
|]
(userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType, PSIssued, redemptionId, now, now)
((userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType) :. (PSIssued, redemptionId_, storeReceiptId_, now, now))
purchaseId <- insertedRowId db
DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (purchaseId, userId)
pure (purchaseId, True)
where
BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = redemption
BadgeStash {stashRef, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = stash
BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = credential
(redemptionId_, storeReceiptId_) = case stashRef of
BSRCodeRedemption redemptionId -> (Just redemptionId, Nothing)
BSRStoreReceipt storeReceiptId -> (Nothing, Just storeReceiptId)
-- | The period comes from the ledger, the expiry from the credential, which runs a week longer.
-- 'False' means no issuance row was written, which the caller reports rather than drop in silence.
@@ -194,10 +371,13 @@ getIssuedPeriod db badgePurchaseId entryId = do
[(Just periodStart, periodEnd)] -> Just (periodStart, periodEnd)
_ -> Nothing
getCodeBadgePurchase :: DB.Connection -> BadgeCodeRedemption -> IO (Maybe Int64)
getCodeBadgePurchase db BadgeCodeRedemption {redemptionId} =
maybeFirstRow fromOnly $
DB.query db "SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption_id = ?" (Only redemptionId)
getStashBadgePurchase :: DB.Connection -> BadgeStash -> IO (Maybe Int64)
getStashBadgePurchase db BadgeStash {stashRef} =
maybeFirstRow fromOnly $ case stashRef of
BSRCodeRedemption redemptionId ->
DB.query db "SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption_id = ?" (Only redemptionId)
BSRStoreReceipt storeReceiptId ->
DB.query db "SELECT badge_purchase_id FROM badge_purchases WHERE badge_store_receipt_id = ?" (Only storeReceiptId)
data UserBadgePurchase = UserBadgePurchase
{ badgePurchaseId :: Int64,
@@ -370,7 +550,7 @@ getBadgeLedger db User {userId} badgePurchaseId =
toStatementEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType) :. (Maybe UTCTime, UTCTime, Text, Maybe Text, Maybe Text, Maybe Text) -> Maybe StatementEntry
toStatementEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType) :. (wasPausedSince, createdAt, entryType_, credit_, debit_, value_)) =
(\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType})
<$> maybe (entryTypeFromColumns entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_
<$> maybe (entryTypeFromColumns Nothing entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_
-- | Decodes the stored JSON rather than rebuilding from the tag, so a version that has since
-- learnt the type reads it with its fields, and one that has not still gets it back verbatim.
src/Simplex/Chat/Store/Postgres/Migrations.hs
+3 -1
View File
@@ -53,6 +53,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260904_file_badges
import Simplex.Chat.Store.Postgres.Migrations.M20260915_user_badges
import Simplex.Chat.Store.Postgres.Migrations.M20260918_badge_issue_errors
import Simplex.Chat.Store.Postgres.Migrations.M20260923_preferences_json
import Simplex.Chat.Store.Postgres.Migrations.M20260925_badge_store_receipts
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Text, Maybe Text)]
@@ -105,7 +106,8 @@ schemaMigrations =
("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges),
("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges),
("20260918_badge_issue_errors", m20260918_badge_issue_errors, Just down_m20260918_badge_issue_errors),
("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json)
("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json),
("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts)
]
-- | The list of migrations in ascending order by date
src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs
+1 -12
View File
@@ -152,6 +152,7 @@ DROP TABLE @badge_prices;
|]
{- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
CREATE TABLE @subscription_charges(
charge_id TEXT NOT NULL PRIMARY KEY,
@@ -165,10 +166,6 @@ CREATE TABLE @subscription_charges(
UNIQUE(payment_id, provider_charge_ref)
);
ALTER TABLE @badge_purchases ADD COLUMN payment_id TEXT REFERENCES @payments;
CREATE UNIQUE INDEX @idx_badge_purchases_payment ON @badge_purchases(payment_id);
CREATE TABLE @badge_invoices(
invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE,
badge_purchase_id BIGINT NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE,
@@ -200,16 +197,12 @@ CREATE TABLE @badge_subscription_changes(
CREATE INDEX @idx_badge_subscription_changes_purchase ON @badge_subscription_changes(badge_purchase_id);
ALTER TABLE @badge_ledger ADD COLUMN payment_id TEXT REFERENCES @payments;
ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges;
ALTER TABLE @badge_ledger ADD COLUMN from_purchase_id BIGINT REFERENCES @badge_purchases;
ALTER TABLE @badge_ledger ADD COLUMN to_purchase_id BIGINT REFERENCES @badge_purchases;
CREATE INDEX @idx_badge_ledger_payment ON @badge_ledger(payment_id);
CREATE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id);
CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id);
@@ -217,11 +210,9 @@ CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id);
CREATE INDEX @idx_badge_ledger_to_purchase ON @badge_ledger(to_purchase_id);
-- down
DROP INDEX @idx_badge_ledger_payment;
DROP INDEX @idx_badge_ledger_charge;
DROP INDEX @idx_badge_ledger_from_purchase;
DROP INDEX @idx_badge_ledger_to_purchase;
ALTER TABLE @badge_ledger DROP COLUMN payment_id;
ALTER TABLE @badge_ledger DROP COLUMN charge_id;
ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id;
ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id;
@@ -231,8 +222,6 @@ DROP INDEX @idx_badge_invoices_purchase;
DROP INDEX @idx_badge_invoices_offer;
DROP INDEX @idx_badge_invoices_price;
DROP TABLE @badge_invoices;
DROP INDEX @idx_badge_purchases_payment;
ALTER TABLE @badge_purchases DROP COLUMN payment_id;
DROP TABLE @subscription_charges;
-}
src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs
+51
View File
@@ -0,0 +1,51 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.Postgres.Migrations.M20260925_badge_store_receipts where
import Data.Text (Text)
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. 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|
CREATE TABLE badge_store_receipts(
badge_store_receipt_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY,
user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE,
invoice_id TEXT UNIQUE,
provider TEXT,
transaction_ref TEXT,
purchase_key BYTEA NOT NULL,
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,
retry_count BIGINT NOT NULL DEFAULT 0,
credit_error TEXT,
UNIQUE(provider, transaction_ref)
);
CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id);
ALTER TABLE badge_purchases ADD COLUMN badge_store_receipt_id BIGINT REFERENCES badge_store_receipts;
CREATE UNIQUE INDEX idx_badge_purchases_store_receipt ON badge_purchases(badge_store_receipt_id);
|]
down_m20260925_badge_store_receipts :: Text
down_m20260925_badge_store_receipts =
[r|
DROP INDEX idx_badge_purchases_store_receipt;
ALTER TABLE badge_purchases DROP COLUMN badge_store_receipt_id;
DROP INDEX idx_badge_store_receipts_user;
DROP TABLE badge_store_receipts;
|]
src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql
+65 -1
View File
@@ -279,7 +279,8 @@ CREATE TABLE test_chat_schema.badge_purchases (
issue_failed_since timestamp with time zone,
issue_error_at timestamp with time zone,
issue_error text,
next_wake_at timestamp with time zone
next_wake_at timestamp with time zone,
badge_store_receipt_id bigint
);
@@ -295,6 +296,36 @@ ALTER TABLE test_chat_schema.badge_purchases ALTER COLUMN badge_purchase_id ADD
CREATE TABLE test_chat_schema.badge_store_receipts (
badge_store_receipt_id bigint NOT NULL,
user_id bigint NOT NULL,
invoice_id text,
provider text,
transaction_ref text,
purchase_key bytea NOT NULL,
purchase_priv_key bytea NOT NULL,
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,
retry_count bigint DEFAULT 0 NOT NULL,
credit_error text
);
ALTER TABLE test_chat_schema.badge_store_receipts ALTER COLUMN badge_store_receipt_id ADD GENERATED ALWAYS AS IDENTITY (
SEQUENCE NAME test_chat_schema.badge_store_receipts_badge_store_receipt_id_seq
START WITH 1
INCREMENT BY 1
NO MINVALUE
NO MAXVALUE
CACHE 1
);
CREATE TABLE test_chat_schema.calls (
call_id bigint NOT NULL,
contact_id bigint NOT NULL,
@@ -1793,6 +1824,21 @@ ALTER TABLE ONLY test_chat_schema.badge_purchases
ALTER TABLE ONLY test_chat_schema.badge_store_receipts
ADD CONSTRAINT badge_store_receipts_invoice_id_key UNIQUE (invoice_id);
ALTER TABLE ONLY test_chat_schema.badge_store_receipts
ADD CONSTRAINT badge_store_receipts_pkey PRIMARY KEY (badge_store_receipt_id);
ALTER TABLE ONLY test_chat_schema.badge_store_receipts
ADD CONSTRAINT badge_store_receipts_provider_transaction_ref_key UNIQUE (provider, transaction_ref);
ALTER TABLE ONLY test_chat_schema.calls
ADD CONSTRAINT calls_pkey PRIMARY KEY (call_id);
@@ -2192,10 +2238,18 @@ CREATE UNIQUE INDEX idx_badge_purchases_code_redemption ON test_chat_schema.badg
CREATE UNIQUE INDEX idx_badge_purchases_store_receipt ON test_chat_schema.badge_purchases USING btree (badge_store_receipt_id);
CREATE INDEX idx_badge_purchases_user ON test_chat_schema.badge_purchases USING btree (user_id);
CREATE INDEX idx_badge_store_receipts_user ON test_chat_schema.badge_store_receipts USING btree (user_id);
CREATE INDEX idx_calls_chat_item_id ON test_chat_schema.calls USING btree (chat_item_id);
@@ -2994,11 +3048,21 @@ ALTER TABLE ONLY test_chat_schema.badge_purchases
ALTER TABLE ONLY test_chat_schema.badge_purchases
ADD CONSTRAINT badge_purchases_badge_store_receipt_id_fkey FOREIGN KEY (badge_store_receipt_id) REFERENCES test_chat_schema.badge_store_receipts(badge_store_receipt_id);
ALTER TABLE ONLY test_chat_schema.badge_purchases
ADD CONSTRAINT badge_purchases_user_id_fkey FOREIGN KEY (user_id) REFERENCES test_chat_schema.users(user_id) ON DELETE CASCADE;
ALTER TABLE ONLY test_chat_schema.badge_store_receipts
ADD CONSTRAINT badge_store_receipts_user_id_fkey FOREIGN KEY (user_id) REFERENCES test_chat_schema.users(user_id) ON DELETE CASCADE;
ALTER TABLE ONLY test_chat_schema.calls
ADD CONSTRAINT calls_chat_item_id_fkey FOREIGN KEY (chat_item_id) REFERENCES test_chat_schema.chat_items(chat_item_id) ON DELETE CASCADE;
src/Simplex/Chat/Store/SQLite/Migrations.hs
+3 -1
View File
@@ -176,6 +176,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260904_file_badges
import Simplex.Chat.Store.SQLite.Migrations.M20260915_user_badges
import Simplex.Chat.Store.SQLite.Migrations.M20260918_badge_issue_errors
import Simplex.Chat.Store.SQLite.Migrations.M20260923_preferences_json
import Simplex.Chat.Store.SQLite.Migrations.M20260925_badge_store_receipts
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -351,7 +352,8 @@ schemaMigrations =
("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges),
("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges),
("20260918_badge_issue_errors", m20260918_badge_issue_errors, Just down_m20260918_badge_issue_errors),
("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json)
("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json),
("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts)
]
-- | The list of migrations in ascending order by date
src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs
+1 -12
View File
@@ -153,6 +153,7 @@ DROP TABLE @badge_prices;
|]
{- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
CREATE TABLE @subscription_charges(
charge_id TEXT NOT NULL PRIMARY KEY,
@@ -166,10 +167,6 @@ CREATE TABLE @subscription_charges(
UNIQUE(payment_id, provider_charge_ref)
) STRICT;
ALTER TABLE @badge_purchases ADD COLUMN payment_id TEXT REFERENCES @payments;
CREATE UNIQUE INDEX @idx_badge_purchases_payment ON @badge_purchases(payment_id);
CREATE TABLE @badge_invoices(
invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE,
badge_purchase_id INTEGER NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE,
@@ -201,16 +198,12 @@ CREATE TABLE @badge_subscription_changes(
CREATE INDEX @idx_badge_subscription_changes_purchase ON @badge_subscription_changes(badge_purchase_id);
ALTER TABLE @badge_ledger ADD COLUMN payment_id TEXT REFERENCES @payments;
ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges;
ALTER TABLE @badge_ledger ADD COLUMN from_purchase_id INTEGER REFERENCES @badge_purchases;
ALTER TABLE @badge_ledger ADD COLUMN to_purchase_id INTEGER REFERENCES @badge_purchases;
CREATE INDEX @idx_badge_ledger_payment ON @badge_ledger(payment_id);
CREATE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id);
CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id);
@@ -218,11 +211,9 @@ CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id);
CREATE INDEX @idx_badge_ledger_to_purchase ON @badge_ledger(to_purchase_id);
-- down
DROP INDEX @idx_badge_ledger_payment;
DROP INDEX @idx_badge_ledger_charge;
DROP INDEX @idx_badge_ledger_from_purchase;
DROP INDEX @idx_badge_ledger_to_purchase;
ALTER TABLE @badge_ledger DROP COLUMN payment_id;
ALTER TABLE @badge_ledger DROP COLUMN charge_id;
ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id;
ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id;
@@ -232,8 +223,6 @@ DROP INDEX @idx_badge_invoices_purchase;
DROP INDEX @idx_badge_invoices_offer;
DROP INDEX @idx_badge_invoices_price;
DROP TABLE @badge_invoices;
DROP INDEX @idx_badge_purchases_payment;
ALTER TABLE @badge_purchases DROP COLUMN payment_id;
DROP TABLE @subscription_charges;
-}
src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs
+50
View File
@@ -0,0 +1,50 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.SQLite.Migrations.M20260925_badge_store_receipts where
import Database.SQLite.Simple (Query)
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. 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|
CREATE TABLE badge_store_receipts(
badge_store_receipt_id INTEGER PRIMARY KEY AUTOINCREMENT,
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
invoice_id TEXT UNIQUE,
provider TEXT,
transaction_ref TEXT,
purchase_key BLOB NOT NULL,
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,
retry_count INTEGER NOT NULL DEFAULT 0,
credit_error TEXT,
UNIQUE(provider, transaction_ref)
) STRICT;
CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id);
ALTER TABLE badge_purchases ADD COLUMN badge_store_receipt_id INTEGER REFERENCES badge_store_receipts;
CREATE UNIQUE INDEX idx_badge_purchases_store_receipt ON badge_purchases(badge_store_receipt_id);
|]
down_m20260925_badge_store_receipts :: Query
down_m20260925_badge_store_receipts =
[sql|
DROP INDEX idx_badge_purchases_store_receipt;
ALTER TABLE badge_purchases DROP COLUMN badge_store_receipt_id;
DROP INDEX idx_badge_store_receipts_user;
DROP TABLE badge_store_receipts;
|]
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+118 -6
View File
@@ -1223,8 +1223,17 @@ Plan:
Query:
INSERT INTO badge_purchases
(user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status, badge_code_redemption_id, created_at, updated_at)
(user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status,
badge_code_redemption_id, badge_store_receipt_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?)
Plan:
Query:
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
Plan:
@@ -4034,6 +4043,15 @@ Query:
Plan:
SCAN group_members
Query:
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
Plan:
SEARCH badge_store_receipts USING INDEX idx_badge_store_receipts_user (user_id=?)
Query:
SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type,
l.was_paused_since, l.service_created_at, l.entry_type, l.entry_credit_type, l.entry_debit_type, l.entry_type_value
@@ -4092,6 +4110,30 @@ Query:
Plan:
SEARCH file_badge_proofs USING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
Query:
SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.payment, r.next_attempt_at, 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 u.shown_badge_id IS NULL
ORDER BY r.next_attempt_at, r.retry_count, r.badge_store_receipt_id
LIMIT 1
Plan:
SEARCH u USING INTEGER PRIMARY KEY (rowid=?)
SEARCH r USING INDEX idx_badge_store_receipts_user (user_id=?)
USE TEMP B-TREE FOR ORDER BY
Query:
SELECT r.badge_store_receipt_id, r.user_id, r.purchase_key, r.purchase_priv_key, r.master_key,
r.payment, r.next_attempt_at, r.retry_delay, 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 = ?
Plan:
SEARCH r USING INDEX sqlite_autoindex_badge_store_receipts_2 (provider=? AND transaction_ref=?)
SEARCH p USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) LEFT-JOIN
Query:
SELECT r.contact_id, g.group_id, r.group_member_id
FROM received_probes r
@@ -4427,15 +4469,26 @@ SEARCH ug USING AUTOMATIC COVERING INDEX (group_id=?)
Query:
DELETE FROM badge_code_redemptions
WHERE badge_code_redemption_id = ?
AND NOT EXISTS (SELECT 1 FROM badge_purchases WHERE badge_code_redemption_id = ?)
WHERE user_id = ? AND code = ?
AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_code_redemption_id = badge_code_redemptions.badge_code_redemption_id)
Plan:
SEARCH badge_code_redemptions USING INTEGER PRIMARY KEY (rowid=?)
SCALAR SUBQUERY 1
SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
SEARCH badge_code_redemptions USING INDEX sqlite_autoindex_badge_code_redemptions_1 (user_id=? AND code=?)
CORRELATED SCALAR SUBQUERY 1
SEARCH p USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
Query:
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)
Plan:
SCAN badge_store_receipts
CORRELATED SCALAR SUBQUERY 1
SEARCH p USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
Query:
DELETE FROM chat_items
WHERE group_scope_group_member_id = ?
@@ -4928,6 +4981,12 @@ Query:
Plan:
Query:
INSERT INTO badge_store_receipts (user_id, invoice_id, purchase_key, purchase_priv_key, master_key, created_at)
VALUES (?,?,?,?,?,?)
Plan:
Query:
INSERT INTO calls
(contact_id, shared_call_id, call_uuid, chat_item_id, call_state, call_ts, user_id, created_at, updated_at)
@@ -5162,6 +5221,14 @@ Query:
Plan:
SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
Query:
UPDATE badge_store_receipts
SET retry_delay = ?, next_attempt_at = ?, retry_count = retry_count + 1, credit_error = ?
WHERE badge_store_receipt_id = ? AND payment IS NOT NULL
Plan:
SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
Query:
UPDATE chat_items
SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted_ts = ?, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ?
@@ -7109,6 +7176,7 @@ SEARCH connections USING COVERING INDEX idx_connections_user_contact_link_id (us
Query: DELETE FROM users WHERE user_id = ?
Plan:
SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
SEARCH badge_store_receipts USING COVERING INDEX idx_badge_store_receipts_user (user_id=?)
SEARCH badge_code_redemptions USING COVERING INDEX idx_badge_code_redemptions_user (user_id=?)
SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_user (user_id=?)
SEARCH chat_relays USING COVERING INDEX idx_chat_relays_user_id (user_id=?)
@@ -7266,6 +7334,14 @@ Query: SELECT 1 FROM settings WHERE user_id = ? LIMIT 1
Plan:
SEARCH settings USING COVERING INDEX idx_settings_user_id (user_id=?)
Query: SELECT COUNT(*) FROM badge_store_receipts
Plan:
SCAN badge_store_receipts USING COVERING INDEX idx_badge_store_receipts_user
Query: SELECT COUNT(*) FROM badge_store_receipts WHERE payment IS NOT NULL
Plan:
SCAN badge_store_receipts
Query: SELECT COUNT(*) FROM groups WHERE relay_own_status IS NOT NULL
Plan:
SCAN groups
@@ -7365,6 +7441,14 @@ Query: SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption
Plan:
SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
Query: SELECT badge_purchase_id FROM badge_purchases WHERE badge_store_receipt_id = ?
Plan:
SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
Query: SELECT badge_store_receipt_id FROM badge_store_receipts WHERE invoice_id = ?
Plan:
SEARCH badge_store_receipts USING COVERING INDEX sqlite_autoindex_badge_store_receipts_1 (invoice_id=?)
Query: SELECT balance_checked FROM badge_ledger ORDER BY entry_id
Plan:
SCAN badge_ledger
@@ -7502,6 +7586,10 @@ Query: SELECT count(1) FROM pending_group_messages
Plan:
SCAN pending_group_messages USING COVERING INDEX idx_pending_group_messages_group_member_id
Query: SELECT credit_error FROM badge_store_receipts WHERE payment IS NOT NULL AND credit_error IS NOT NULL
Plan:
SCAN badge_store_receipts
Query: SELECT entry_id FROM badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?
Plan:
SEARCH badge_ledger USING INDEX idx_badge_ledger_uuid (entry_uuid=?)
@@ -7768,6 +7856,10 @@ Query: SELECT user_id FROM users WHERE local_display_name = ?
Plan:
SEARCH users USING COVERING INDEX sqlite_autoindex_users_2 (local_display_name=?)
Query: SELECT user_id, invoice_id, transaction_ref IS NOT NULL FROM badge_store_receipts ORDER BY badge_store_receipt_id
Plan:
SCAN badge_store_receipts
Query: SELECT via_contact_uri FROM connections WHERE connection_id = ?
Plan:
SEARCH connections USING INTEGER PRIMARY KEY (rowid=?)
@@ -7792,6 +7884,26 @@ Query: UPDATE badge_purchases SET next_wake_at = ? WHERE badge_purchase_id = ?
Plan:
SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE badge_store_receipts SET payment = ?
Plan:
SCAN badge_store_receipts
Query: UPDATE badge_store_receipts SET payment = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL
Plan:
SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0 WHERE badge_store_receipt_id = ?
Plan:
SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = ? WHERE badge_store_receipt_id = ?
Plan:
SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE badge_store_receipts SET provider = ?, transaction_ref = ?, payment = ?, next_attempt_at = ? WHERE invoice_id = ? AND transaction_ref IS NULL
Plan:
SEARCH badge_store_receipts USING INDEX sqlite_autoindex_badge_store_receipts_1 (invoice_id=?)
Query: UPDATE chat_items SET item_msg_body = ?, item_chat_binding = ?, item_signatures = ?, item_signed_by_group_member_id = ? WHERE chat_item_id = ? AND include_in_history = 1
Plan:
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+22
View File
@@ -938,6 +938,7 @@ CREATE TABLE badge_purchases(
issue_error_at TEXT,
issue_error TEXT,
next_wake_at TEXT,
badge_store_receipt_id INTEGER REFERENCES badge_store_receipts,
UNIQUE(purchase_key)
) STRICT;
CREATE TABLE badge_ledger(
@@ -981,6 +982,23 @@ CREATE TABLE badge_code_redemptions(
created_at TEXT NOT NULL,
UNIQUE(user_id, code)
) STRICT;
CREATE TABLE badge_store_receipts(
badge_store_receipt_id INTEGER PRIMARY KEY AUTOINCREMENT,
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
invoice_id TEXT UNIQUE,
provider TEXT,
transaction_ref TEXT,
purchase_key BLOB NOT NULL,
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,
retry_count INTEGER NOT NULL DEFAULT 0,
credit_error TEXT,
UNIQUE(provider, transaction_ref)
) STRICT;
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@@ -1544,6 +1562,10 @@ CREATE INDEX idx_badge_code_redemptions_user ON badge_code_redemptions(
CREATE UNIQUE INDEX idx_badge_purchases_code_redemption ON badge_purchases(
badge_code_redemption_id
);
CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id);
CREATE UNIQUE INDEX idx_badge_purchases_store_receipt ON badge_purchases(
badge_store_receipt_id
);
CREATE TRIGGER on_group_members_insert_update_summary
AFTER INSERT ON group_members
FOR EACH ROW
src/Simplex/Chat/View.hs
+14 -3
View File
@@ -46,7 +46,7 @@ import Simplex.Chat.Markdown
import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus)
import Simplex.Chat.Badges.Ledger (creditTypeTag, debitTypeTag)
import Simplex.Chat.Badges.Service (StatementEntry (..), StatementEntryType (..))
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeIssueError (..), BadgeState (..))
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeIssueError (..), BadgeState (..), OpenStorePurchase (..))
import Simplex.Chat.Messages hiding (NewChatItem (..))
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Operators
@@ -193,7 +193,8 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
CRServiceReplyAccepted u (AgentConnId cId) -> ttyUser u [plain $ "service reply accepted, connection id: " <> safeDecodeUtf8 (strEncode cId)]
-- the badge is only shown when it is the one now on the profile; a replayed code's badge may not be
CRBadgeRedeemed u badge newBadge _ -> ttyUser u $ if newBadge then "badge redeemed" : viewContactBadge (Just badge) else ["badge already redeemed"]
CRBadgeState u st -> ttyUser u $ viewUserBadgeState st
CRBadgeInvoice u invoiceId -> ttyUser u ["badge invoice: " <> plain invoiceId]
CRBadgeState u st storePurchases -> ttyUser u $ viewUserBadgeState st <> map viewOpenStorePurchase storePurchases
CRBadgeLedger u entries -> ttyUser u $ viewBadgeLedger entries
CRGroupCreated u g -> ttyUser u $ viewGroupCreated g testView
CRPublicGroupCreated u g _groupLink _relays -> ttyUser u $ viewGroupCreated g testView
@@ -483,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
CEvtStorePurchaseResolved u -> ttyUser u ["store purchase resolved"]
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
@@ -1863,6 +1865,14 @@ viewBadgeIssueError BadgeIssueError {failedSince, lastAttemptAt, reason} =
viewBadgeAlert :: BadgeAlert -> [StyledString]
viewBadgeAlert BadgeAlert {kind, date} = [plain $ "badge alert: " <> textEncode kind <> " " <> day date]
viewOpenStorePurchase :: OpenStorePurchase -> StyledString
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"]
viewBadgeLedger entries = map viewEntry entries
@@ -2867,13 +2877,14 @@ viewChatError isCmd logLevel testView = \case
CEBadgeRedeemError e ->
let reason = case e of
BREInvalidCode -> "invalid code"
BREInvalidReceipt -> "invalid store receipt"
BREServiceNotConfigured -> "badge service not configured"
BREBadgeActive -> "badge already active"
BREServiceError code -> "badge service error: " <> T.unpack (badgeServiceErrorText code)
BREInvalidResponse m -> "invalid service response: " <> m
BREUnknownKeyIndex -> "credential names an unknown badge key index"
BRECredentialNotVerified -> "credential does not verify against configured key"
in ["cannot redeem badge code: " <> plain reason]
in ["cannot get badge: " <> plain reason]
CEAgentCommandError e -> ["agent command error: " <> plain e]
CEInvalidFileDescription e -> ["invalid file description: " <> plain e]
CEConnectionIncognitoChangeProhibited -> ["incognito mode change prohibited"]