core: renew badges monthly and alert when support ends (#7448)

src/Simplex/Chat.hs

@@ -69,6 +69,8 @@ defaultChatConfig =
       chatVRange = supportedChatVRange,
       badgePublicKeys = M.mapKeys fromIntegral entitlementIssuerKeys,
       badgeServiceAddress = Nothing,
+      badgeCurrentTime = getCurrentTime,
+      badgeRetryInterval = RetryInterval {initialInterval = 30_000000, increaseAfter = 0, maxInterval = 3600_000000},
       confirmMigrations = MCConsole,
       -- this property should NOT use operator = Nothing
       -- non-operator servers can be passed via options
@@ -189,6 +191,8 @@ newChatController
         deliveryTaskWorkers <- TM.emptyIO
         deliveryJobWorkers <- TM.emptyIO
         relayRequestWorkers <- TM.emptyIO
+        badgeWorkers <- TM.emptyIO
+        badgeSeq <- newTVarIO 0
         relayGroupLinkChecksAsync <- newTVarIO Nothing
         webPreviewState <- forM webPreviewConfig $ \_ -> newWebPreviewState
         chatRelayTests <- TM.emptyIO
@@ -235,6 +239,8 @@ newChatController
               deliveryTaskWorkers,
               deliveryJobWorkers,
               relayRequestWorkers,
+              badgeWorkers,
+              badgeSeq,
               relayGroupLinkChecksAsync,
               webPreviewState,
               chatRelayTests,

src/Simplex/Chat/Badges/Code.hs

@@ -3,11 +3,11 @@
 
 -- | Badge redemption codes, shared by the client, the badge service and the checkout site.
 --
--- A code is @SXB-@ and 20 Crockford base32 characters in four groups of five:
+-- A code is "SXB-" and 20 Crockford base32 characters in four groups of five:
 -- 19 payload characters and a final check character.
 --
 -- Reading folds the characters the alphabet omits so that a code copied by hand still
--- verifies: it is case-insensitive and maps @I@ and @L@ to @1@ and @O@ to @0@.
+-- verifies: it is case-insensitive and maps 'I' and 'L' to '1' and 'O' to '0'.
 --
 -- The check character is Luhn mod N with N = 32 over the payload values, which keeps it
 -- inside the same 32-character alphabet. It detects every single-character substitution

src/Simplex/Chat/Badges/Ledger.hs

@@ -0,0 +1,176 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Badges.Ledger
+  ( emptyEntry,
+    lapseEntry,
+    grantEntry,
+    issueEntry,
+    paidThrough,
+    balanceChecked,
+    addMonths,
+    endOfMondayAfter,
+    entryTypeColumns,
+    entryTypeFromColumns,
+    creditTypeTag,
+    debitTypeTag,
+  )
+where
+
+import Data.Text (Text)
+import Data.Time.Calendar (addDays, addGregorianMonthsClip, toGregorian)
+import Data.Time.Calendar.WeekDate (toWeekDate)
+import Data.Time.Clock (UTCTime (..))
+import Simplex.Chat.Badges (BadgeType)
+import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
+
+-- | balanceStartTs is always a whole number of months from the anchor; this is that number.
+-- The calendar difference overshoots by at most one month, so one comparison settles it.
+monthsFromAnchor :: StatementEntry -> Integer
+monthsFromAnchor StatementEntry {balanceStartTs, balanceAnchorTs}
+  | addMonths months balanceAnchorTs <= balanceStartTs = max 0 months
+  | otherwise = max 0 (months - 1)
+  where
+    (ay, am, _) = toGregorian (utctDay balanceAnchorTs)
+    (sy, sm, _) = toGregorian (utctDay balanceStartTs)
+    months = (sy - ay) * 12 + toInteger (sm - am)
+
+-- | The start of the month that follows n more months of this run.
+monthAfter :: StatementEntry -> Int -> UTCTime
+monthAfter e n = addMonths (monthsFromAnchor e + toInteger n) (balanceAnchorTs e)
+
+paidThrough :: StatementEntry -> UTCTime
+paidThrough e = monthAfter e (balanceMonths e)
+
+elapsedMonths :: UTCTime -> StatementEntry -> Int
+elapsedMonths t e = length $ takeWhile (\m -> monthAfter e m <= t) [1 .. balanceMonths e]
+
+-- | The seed for a purchase with no ledger yet: no months, and a run starting now.
+emptyEntry :: UTCTime -> BadgeType -> StatementEntry
+emptyEntry t badgeType =
+  StatementEntry
+    { -- this entry is never stored, and every operation puts its own id on the entry it returns
+      entryId = "",
+      changeMonths = 0,
+      balanceMonths = 0,
+      balanceStartTs = t,
+      balanceAnchorTs = t,
+      balanceBadgeType = badgeType,
+      wasPausedSince = Nothing,
+      createdAt = t,
+      entryType = SECredit SCOpening
+    }
+
+-- | Writes off the months that have passed.
+lapseEntry :: UTCTime -> Text -> StatementEntry -> Maybe StatementEntry
+lapseEntry t entryId e@StatementEntry {balanceMonths}
+  | k == 0 = Nothing
+  | otherwise =
+      Just
+        e
+          { entryId,
+            createdAt = t,
+            changeMonths = negate k,
+            balanceMonths = balanceMonths - k,
+            balanceStartTs = monthAfter e k,
+            entryType = SEDebit SDLapse
+          }
+  where
+    k = elapsedMonths t e
+
+-- | New months start where the current coverage ends, or at t if it has already lapsed - so they
+-- are neither spent on the month still running nor backdated over a gap.
+grantEntry :: UTCTime -> Text -> Int -> StatementCreditType -> StatementEntry -> StatementEntry
+grantEntry t entryId n credit e@StatementEntry {balanceMonths, balanceStartTs}
+  -- only a lapsed run restarts; topping up before coverage ends continues the run on its anchor,
+  -- so buying a month at a time keeps the same day of month as buying a year at once
+  | lapsed = credited {balanceMonths = n, balanceStartTs = t, balanceAnchorTs = t}
+  | otherwise = credited {balanceMonths = balanceMonths + n}
+  where
+    lapsed = balanceMonths == 0 && t > balanceStartTs
+    credited = e {entryId, createdAt = t, changeMonths = n, entryType = SECredit credit}
+
+-- | The period issued runs from the previous entry's balanceStartTs to this one's.
+issueEntry :: UTCTime -> Text -> StatementEntry -> Maybe StatementEntry
+issueEntry t entryId e@StatementEntry {balanceMonths, balanceStartTs}
+  | balanceMonths <= 0 || balanceStartTs > t = Nothing
+  | otherwise =
+      Just
+        e
+          { entryId,
+            createdAt = t,
+            changeMonths = -1,
+            balanceMonths = balanceMonths - 1,
+            balanceStartTs = monthAfter e 1,
+            entryType = SEDebit SDBadge
+          }
+
+-- | Pairs each arriving entry with whether its balance follows from the one before it, the stored
+-- tip standing in for the first one's predecessor. 'Nothing' is "not checked".
+-- TODO [badges] do the arithmetic.
+balanceChecked :: Maybe StatementEntry -> [StatementEntry] -> [(StatementEntry, Maybe Bool)]
+balanceChecked _tip = map (\e -> (e, Nothing))
+
+-- | The tag stored is the string the service sent, so a type this version does not know is kept
+-- as received and can be read once it does.
+entryTypeColumns :: StatementEntryType -> (Text, Maybe Text, Maybe Text)
+entryTypeColumns = \case
+  SECredit c -> ("credit", Just $ creditTypeTag c, Nothing)
+  SEDebit d -> ("debit", Nothing, Just $ debitTypeTag d)
+
+creditTypeTag :: StatementCreditType -> Text
+creditTypeTag = \case
+  SCPayment _ -> "payment"
+  SCCode -> "code"
+  SCCharge _ -> "charge"
+  SCSupport -> "support"
+  SCTransferIn _ -> "transferIn"
+  SCOpening -> "opening"
+  SCUnknown {tag} -> tag
+
+debitTypeTag :: StatementDebitType -> Text
+debitTypeTag = \case
+  SDRefund -> "refund"
+  SDUpgrade _ -> "upgrade"
+  SDTransferOut _ -> "transferOut"
+  SDSupport -> "support"
+  SDBadge -> "badge"
+  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
+  ("credit", Just t, _) -> SECredit <$> creditType t
+  ("debit", _, Just t) -> SEDebit <$> debitType t
+  _ -> Nothing
+  where
+    creditType = \case
+      "code" -> Just SCCode
+      "support" -> Just SCSupport
+      "opening" -> Just SCOpening
+      _ -> Nothing
+    debitType = \case
+      "badge" -> Just SDBadge
+      "lapse" -> Just SDLapse
+      "refund" -> Just SDRefund
+      "support" -> Just SDSupport
+      _ -> Nothing
+
+addMonths :: Integer -> UTCTime -> UTCTime
+addMonths n (UTCTime d t) = UTCTime (addGregorianMonthsClip n d) t
+
+-- Every badge in a week expires together, revealing nothing about when it was bought.
+-- The end of a Monday is the next Tuesday at 00:00, so this returns a Tuesday and 9 is right.
+-- Returning a Monday instead would put the expiry on Sunday evening in the Americas, leaving a
+-- renewal that failed there waiting for weekend support.
+endOfMondayAfter :: UTCTime -> UTCTime
+endOfMondayAfter (UTCTime d _) =
+  let (_, _, dayOfWeek) = toWeekDate d -- 1 Monday .. 7 Sunday
+   in UTCTime (addDays (toInteger (9 - dayOfWeek)) d) 0

src/Simplex/Chat/Badges/Service.hs

@@ -98,8 +98,7 @@ data BadgeServiceCommand
         balance :: BadgeBalance
       }
   | BSCIssueBadge
-      { badgeRequest :: BadgeRequest,
-        balance :: BadgeBalance
+      { balance :: BadgeBalance -- no badgeRequest: the service holds the key, the tier and the expiry
       }
   | BSCPauseBadge
 
@@ -173,6 +172,9 @@ data StatementEntry = StatementEntry
     changeMonths :: Int,
     balanceMonths :: Int,
     balanceStartTs :: UTCTime,
+    -- the start of the current run of months; every month boundary in it is counted from here,
+    -- so that the day of month survives a short month
+    balanceAnchorTs :: UTCTime,
     balanceBadgeType :: BadgeType,
     wasPausedSince :: Maybe UTCTime,
     createdAt :: UTCTime,
@@ -184,7 +186,8 @@ data StatementEntryType = SECredit {credit :: StatementCreditType} | SEDebit {de
   deriving (Show)
 
 data StatementCreditType
-  = SCPayment {invoiceId :: Maybe InvoiceId} -- absent for store and code payments
+  = SCPayment {invoiceId :: Maybe InvoiceId} -- absent for store payments
+  | SCCode -- a redeemed code; its own invoice belongs to the buyer, not to the redeemer
   | SCCharge {chargeId :: Text}
   | SCSupport
   | SCTransferIn {fromPurchaseKey :: C.PublicKeyEd25519}

src/Simplex/Chat/Badges/Types.hs

@@ -18,12 +18,13 @@ module Simplex.Chat.Badges.Types
     LedgerCreditType (..),
     LedgerDebitType (..),
     BadgeAlertKind (..),
+    BadgeFunding (..),
     BadgePurchase (..),
     BadgeLedgerEntry (..),
     BadgeCharge (..),
     BadgeIssuance (..),
     BadgeAlert (..),
-    UserBadgeState (..),
+    BadgeState (..),
   ) where
 
 import Data.Aeson (FromJSON, ToJSON)
@@ -34,12 +35,12 @@ import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word8)
 import Simplex.Chat.Badges hiding (BadgePurchase (..))
-import Simplex.Chat.PaymentService.Types (InvoiceId, StoredPayment)
+import Simplex.Chat.PaymentService.Types (InvoiceId, PaymentId, StoredPayment)
 import Simplex.Messaging.Agent.Protocol (UserId)
 import Simplex.Messaging.Agent.Store.DB (fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, taggedObjectJSON)
 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple.FromField (FromField (..))
 import Database.PostgreSQL.Simple.ToField (ToField (..))
@@ -84,8 +85,9 @@ data LedgerEntryType = LECredit {credit :: LedgerCreditType} | LEDebit {debit ::
 
 -- confirmed
 data LedgerCreditType
-  = CTPayment {invoiceId :: Int64}
-  | CTCharge {chargeId :: Int64}
+  = CTPayment {invoiceId :: InvoiceId}
+  | CTCode
+  | CTCharge {chargeId :: Text}
   | CTSupport
   | CTTransferIn {fromPurchaseId :: Maybe Int64}
   | CTOpening
@@ -107,6 +109,31 @@ data LedgerDebitType
 data BadgeAlertKind = BARenewalApproaching | BAPaymentIssue | BASubscriptionEnded | BAPrepaidEnding | BASupportEnded
   deriving (Eq, Show)
 
+instance TextEncoding BadgeAlertKind where
+  textEncode = \case
+    BARenewalApproaching -> "renewal_approaching"
+    BAPaymentIssue -> "payment_issue"
+    BASubscriptionEnded -> "subscription_ended"
+    BAPrepaidEnding -> "prepaid_ending"
+    BASupportEnded -> "support_ended"
+  textDecode = \case
+    "renewal_approaching" -> Just BARenewalApproaching
+    "payment_issue" -> Just BAPaymentIssue
+    "subscription_ended" -> Just BASubscriptionEnded
+    "prepaid_ending" -> Just BAPrepaidEnding
+    "support_ended" -> Just BASupportEnded
+    _ -> Nothing
+
+instance FromField BadgeAlertKind where fromField = fromTextField_ textDecode
+
+instance ToField BadgeAlertKind where toField = toField . textEncode
+
+-- exactly one of these funds a purchase; the schema cannot say so, both columns being nullable
+data BadgeFunding
+  = BFPayment {paymentId :: PaymentId}
+  | BFCodeRedemption {redemptionId :: Int64}
+  deriving (Eq, Show)
+
 -- to review
 data BadgePurchase = BadgePurchase
   { badgePurchaseId :: Int64,
@@ -117,7 +144,7 @@ data BadgePurchase = BadgePurchase
     badgeType :: BadgeType,
     priceId :: Maybe BadgePriceId,
     offerId :: Maybe BadgeOfferId,
-    paymentId :: Int64,
+    funding :: BadgeFunding,
     status :: BadgePurchaseStatus,
     credential :: Maybe BadgeCredential,
     alertAcked :: Maybe (BadgeAlertKind, Text),
@@ -134,6 +161,7 @@ data BadgeLedgerEntry = BadgeLedgerEntry
     changeMonths :: Int,
     balanceMonths :: Int,
     balanceStartTs :: UTCTime,
+    balanceAnchorTs :: UTCTime,
     balanceBadgeType :: BadgeType,
     wasPausedSince :: Maybe UTCTime,
     serviceCreatedAt :: UTCTime,
@@ -156,14 +184,16 @@ data BadgeCharge = BadgeCharge
   }
   deriving (Show)
 
--- unconfirmed draft
+-- every issuance covers one month and is written beside exactly one debit(badge) row
 data BadgeIssuance = BadgeIssuance
-  { issuanceId :: Int64,
+  { issuanceId :: Text,
     badgePurchaseId :: Int64,
-    periodStart :: Maybe UTCTime,
-    periodEnd :: Maybe UTCTime,
-    expiry :: Maybe UTCTime,
-    entryId :: Maybe Int64,
+    badgeType :: BadgeType,
+    periodStart :: UTCTime,
+    periodEnd :: UTCTime,
+    expiry :: UTCTime,
+    entryId :: Int64,
+    credential :: BadgeCredential,
     createdAt :: UTCTime
   }
   deriving (Show)
@@ -177,17 +207,19 @@ data BadgeAlert = BadgeAlert
   }
   deriving (Show)
 
--- unconfirmed draft
-data UserBadgeState = UserBadgeState
-  { badges :: [BadgePurchase],
-    shownBadgeId :: Maybe Int64,
-    payments :: [StoredPayment],
+-- | The user's badge as the badge surfaces render it. The purchase keys are deliberately absent:
+-- this travels to the UI and over remote control, and they are secrets that stay in core.
+data BadgeState = BadgeState
+  { badgePurchaseId :: Int64,
+    badgeType :: BadgeType,
     monthsLeft :: Int,
-    paidThrough :: Maybe UTCTime,
+    paidThrough :: UTCTime,
+    -- payments returns here with the payment types, which this slice neither writes nor encodes
     renewsAt :: Maybe UTCTime,
     willRenew :: Bool,
     alert :: Maybe BadgeAlert
   }
+  deriving (Show)
 
 instance TextEncoding BadgePurchaseStatus where
   textEncode = \case
@@ -224,3 +256,14 @@ instance ToField BadgeCodePaymentStatus where toField = toField . textEncode
 $(JQ.deriveJSON (enumJSON $ dropPrefix "BIS") ''BadgeItemStatus)
 
 $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "OD") ''OfferDiscount)
+
+instance ToJSON BadgeAlertKind where
+  toJSON = textToJSON
+  toEncoding = textToEncoding
+
+instance FromJSON BadgeAlertKind where
+  parseJSON = textParseJSON "BadgeAlertKind"
+
+$(JQ.deriveJSON defaultJSON ''BadgeAlert)
+
+$(JQ.deriveJSON defaultJSON ''BadgeState)

src/Simplex/Chat/Controller.hs

@@ -84,6 +84,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Client (HostMode (..), SMPProxyFallback (..), SMPProxyMode (..), SMPWebPortServers (..), SocksMode (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Chat.Badges (BadgeCredential, LocalBadge)
+import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeState (..))
 import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import qualified Simplex.Messaging.Crypto.File as CF
@@ -92,6 +93,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
 import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), QueueId, SMPMsgMeta (..), SubscriptionMode (..), XFTPServer)
+import Simplex.Messaging.Session (SessionVar)
 import Simplex.Messaging.TMap (TMap)
 import Simplex.Messaging.Transport (TLS, TransportPeer (..), simplexMQVersion)
 import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost)
@@ -145,6 +147,10 @@ data ChatConfig = ChatConfig
     badgePublicKeys :: Map Int BBSPublicKey,
     -- Nothing until the badge service is deployed
     badgeServiceAddress :: Maybe (ConnectTarget 'CMContact),
+    -- the only clock badge code reads, so tests can shift it; production arithmetic is unchanged
+    badgeCurrentTime :: IO UTCTime,
+    -- how long a badge worker waits before repeating a renewal that failed for a passing reason
+    badgeRetryInterval :: RetryInterval,
     confirmMigrations :: MigrationConfirmation,
     presetServers :: PresetServers,
     shortLinkPresetServers :: NonEmpty SMPServer,
@@ -278,6 +284,12 @@ defaultInlineFilesConfig =
 
 data ChatDatabase = ChatDatabase {chatStore :: DBStore, agentStore :: DBStore}
 
+-- | Signalling badgeWork wakes the worker from its own wait; a full var means it has work to do.
+data BadgeWorker = BadgeWorker
+  { badgeWorkerAsync :: Async (),
+    badgeWork :: TMVar ()
+  }
+
 data ChatController = ChatController
   { currentUser :: TVar (Maybe User),
     randomPresetServers :: NonEmpty PresetOperator,
@@ -310,6 +322,9 @@ data ChatController = ChatController
     deliveryTaskWorkers :: TMap DeliveryWorkerKey Worker,
     deliveryJobWorkers :: TMap DeliveryWorkerKey Worker,
     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),
+    badgeSeq :: TVar Int,
     relayGroupLinkChecksAsync :: TVar (Maybe (Async ())),
     webPreviewState :: Maybe WebPreviewState,
     chatRelayTests :: TMap ConnId RelayTest,
@@ -641,6 +656,10 @@ 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
+  | APIGetBadgeState {userId :: UserId} -- the user's badges, their balances and any current alert
+  -- episode is last because it is free text: it is the value that makes one occurrence of an
+  -- alert distinct from the next, and the app returns whatever it was given
+  | APIAckBadgeAlert {userId :: UserId, badgePurchaseId :: Int64, alertKind :: BadgeAlertKind, snooze :: Bool, episode :: Text}
   | ShowProfileImage
   | SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI)
   | SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)
@@ -846,6 +865,7 @@ data ChatResponse
   | CRServiceResponse {user :: User, responseData :: J.Object}
   | CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId}
   | CRBadgeRedeemed {user :: User, redeemedBadge :: LocalBadge, newBadge :: Bool}
+  | CRBadgeState {user :: User, badgeState :: Maybe BadgeState}
   | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}
   | CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool, msgSigned :: Bool}
   | CRGroupsList {user :: User, groups :: [GroupInfo]}
@@ -963,6 +983,8 @@ data ChatEvent
   | CEvtReceivedContactRequest {user :: User, contactRequest :: UserContactRequest, chat_ :: Maybe AChat}
   | CEvtServiceRequest {user :: User, requestId :: AgentInvId, signerKey :: Maybe C.PublicKeyEd25519, requestData :: J.Object}
   | 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}
   | CEvtContactRequestRejected {user :: User, contact :: Contact, rejectionReason :: Maybe ContactRejectionReason}
   | CEvtAcceptingContactRequest {user :: User, contact :: Contact} -- there is the same command response
   | CEvtAcceptingBusinessRequest {user :: User, groupInfo :: GroupInfo}

src/Simplex/Chat/Library/Commands.hs

@@ -51,14 +51,19 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
-import Data.Time.Clock (UTCTime, getCurrentTime, nominalDay)
+import Data.Word (Word32)
+import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay)
 import Data.Type.Equality
 import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as V4
 import Simplex.Chat.Library.Subscriber
-import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), LocalBadge (..), badgeServerCredential, maxXFTPFileSize, mkBadgeStatus, verifyCredential)
+import Crypto.Random (ChaChaDRG)
+import Simplex.Messaging.Session (SessionVar (..), withGetSessVar')
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, LocalBadge (..), badgeServerCredential, maxXFTPFileSize, mkBadgeStatus, verifyCredential)
+import qualified Simplex.Chat.Badges.Ledger as L
+import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeState (..))
 import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
-import Simplex.Chat.Badges.Service (BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), currentBadgeServiceVersion)
+import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), currentBadgeServiceVersion)
 import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
@@ -100,6 +105,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.Store.Entity
 import Simplex.Messaging.Agent.Store.Interface (execSQL)
 import Simplex.Messaging.Agent.Store.Shared (upMigration)
@@ -253,6 +259,7 @@ startChatController mainApp enableSndFiles serviceRequests = do
           startDeliveryWorkers
           startRelayRequestWorker_
           startCleanupManager
+          mapM_ startBadgeWork users
           void $ forkIO $ mapM_ startExpireCIs users
           startRelayChecks users
           startWebPreview users
@@ -349,7 +356,8 @@ restoreCalls = do
   atomically $ writeTVar calls callsMap
 
 stopChatController :: ChatController -> IO ()
-stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do
+stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, badgeWorkers} = do
+  stopBadgeWorkers badgeWorkers
   readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd)
   atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd)
   disconnectAgentClient smpAgent
@@ -581,6 +589,7 @@ processChatCommand cxt nm = \case
         void . forkIO $ subscribeUsers True users
         void . forkIO $ startFilesToReceive users
         setAllExpireCIFlags True
+        mapM_ startBadgeWork users
     ok_
   APISuspendChat t -> do
     chatWriteVar chatActivated False
@@ -3538,6 +3547,17 @@ 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
+  APIGetBadgeState userId -> withUserId userId $ \user -> do
+    -- the read also signals the worker, whose results follow as CEvtBadgeChanged
+    lift $ startBadgeWork user
+    CRBadgeState user <$> getUserBadgeState user
+  APIAckBadgeAlert userId badgePurchaseId alertKind snooze episode -> withUserId userId $ \user -> do
+    now <- badgeNow
+    let snoozeUntil = if snooze then Just (addUTCTime nominalDay now) else Nothing
+    withStore' $ \db -> setBadgeAlertAcked db 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
   SetBotCommands commands -> withUser $ \user@User {profile} -> do
     let LocalProfile {preferences} = profile
         prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands}
@@ -3640,6 +3660,7 @@ processChatCommand cxt nm = \case
         CLUserContact ucId -> "UserContact " <> tshow ucId
         CLContactRequest crId -> "ContactRequest " <> tshow crId
         CLFile fId -> "File " <> tshow fId
+        CLBadgeUser uId -> "BadgeUser " <> tshow uId
   DebugEvent event -> toView event >> ok_
   GetAgentSubsTotal userId -> withUserId userId $ \user -> do
     users <- withStore' $ \db -> getUsers db
@@ -5135,12 +5156,16 @@ addUserBadge user cred@(BadgeCredential _ _ _ info) =
     Just False -> throwCmdError "badge credential does not verify against configured key"
     Just True -> do
       now <- liftIO getCurrentTime
-      user' <- withFastStore' $ \db -> setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info)))
+      user' <- withFastStore $ \db -> setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info)))
       presentUserBadgeToContacts user'
 
 presentUserBadgeToContacts :: User -> CM ()
-presentUserBadgeToContacts user'@User {profile = LocalProfile {localBadge}} = do
-  asks currentUser >>= atomically . (`writeTVar` Just user')
+presentUserBadgeToContacts user'@User {userId, profile = LocalProfile {localBadge}} = do
+  -- a badge worker runs for every profile, not only the active one, so this refreshes the active
+  -- record where it is the same profile and must never switch to another
+  chatModifyVar currentUser $ \case
+    Just User {userId = activeId} | activeId == userId -> Just user'
+    active_ -> active_
   lift $ withAgent' $ \a -> setUserEntitlement a (aUserId user') (badgeServerCredential localBadge)
   cxt <- asks $ mkStoreCxt . config
   contacts <- withFastStore' $ \db -> getUserContacts db cxt user'
@@ -5157,25 +5182,34 @@ presentUserBadgeToContacts user'@User {profile = LocalProfile {localBadge}} = do
 -- stashed before the request is sent, so a retry reaches the service as the same signer.
 -- A terminal answer drops the stash; a timeout keeps it.
 redeemBadgeCode :: NetworkRequestMode -> User -> Text -> CM ChatResponse
-redeemBadgeCode nm user codeText = do
+redeemBadgeCode nm user@User {userId} codeText = do
   code <- maybe (throwCmdError "invalid badge code") pure $ parseBadgeCode codeText
   sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwCmdError "badge service not configured") pure
   g <- asks random
   now <- liftIO getCurrentTime
   let codeSent = badgeCodeText code
-  redemption@BadgeCodeRedemption {purchaseKey, purchasePrivKey, masterKey} <-
-    withStore' $ \db ->
-      getBadgeCodeRedemption db user codeSent
-        >>= maybe (createBadgeCodeRedemption db g user codeSent now) pure
-  let req = BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request = BSCRedeemBadgeCode {masterKey, code = codeSent}}
-  respData <- sendServiceRequestTo nm user sendTarget Nothing (Just purchasePrivKey) req
-  case J.fromJSON (J.Object respData) of
-    J.Error e -> throwCmdError $ "invalid badge service response, " <> show e <> ": " <> respJSON respData
-    J.Success BSPError {code = errCode} -> do
-      when (terminalCodeError errCode) $ withStore' $ \db -> deleteBadgeCodeRedemption db (redemptionId redemption)
-      throwCmdError $ "badge service error: " <> T.unpack (badgeServiceErrorText errCode)
-    J.Success BSPBadgeCredential {credential = Just cred} -> storeRedeemedBadge user redemption cred
-    J.Success _ -> throwCmdError $ "unexpected badge service response: " <> respJSON respData
+  -- 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)) $ throwCmdError "badge already active"
+    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}}
+    respData <- sendServiceRequestTo nm user sendTarget Nothing (Just purchasePrivKey) req
+    case J.fromJSON (J.Object respData) of
+      J.Error e -> throwCmdError $ "invalid badge service response, " <> show e <> ": " <> respJSON respData
+      J.Success BSPError {code = errCode} -> do
+        when (terminalCodeError errCode) $ withStore' $ \db -> deleteBadgeCodeRedemption db (redemptionId redemption)
+        throwCmdError $ "badge service error: " <> T.unpack (badgeServiceErrorText errCode)
+      J.Success BSPBadgeCredential {credential = Just cred, statement} -> storeRedeemedBadge user redemption cred statement
+      J.Success _ -> throwCmdError $ "unexpected badge service response: " <> respJSON respData
+  -- outside the badge lock: the chat lock must not be taken under it
+  mapM_ presentUserBadgeToContacts present_
+  pure redeemed
   where
     -- re-encoded, not shown as received: JSON escapes the control characters a terminal acts on
     respJSON = LB.unpack . J.encode
@@ -5197,10 +5231,317 @@ badgeServiceErrorText = \case
   where
     errorCodeChar c = isAsciiLower c || isDigit c || c == '_'
 
--- | Verify the credential before writing anything; the purchase, its issuance and the profile's
--- badge go in one transaction, and contacts are told after it commits.
-storeRedeemedBadge :: User -> BadgeCodeRedemption -> BadgeCredential -> CM ChatResponse
-storeRedeemedBadge user redemption@BadgeCodeRedemption {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeExpiry}) =
+-- | The only clock badge code reads, so a test can move the client and the service together.
+badgeNow :: CM UTCTime
+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
+
+-- | 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
+  seq' <- asks badgeSeq
+  now <- liftIO getCurrentTime
+  withGetSessVar' seq' userId ws now startWorker signalWorker
+  where
+    startWorker v = do
+      badgeWork <- newTMVarIO ()
+      badgeWorkerAsync <- async $ void $ runExceptT $ runBadgeWorker userId badgeWork
+      let w = BadgeWorker {badgeWorkerAsync, badgeWork}
+      w <$ atomically (putTMVar (sessionVar v) w)
+    signalWorker v = do
+      w <- atomically $ readTMVar $ sessionVar v
+      w <$ atomically (void $ tryPutTMVar (badgeWork w) ())
+
+-- | The alert last raised, so it is not repeated on every pass. The snooze is in the key because
+-- kind and episode do not change when it lapses: the alert would match and stay silent until a restart.
+type BadgeOccurrence = (BadgeAlertKind, Text, Maybe UTCTime)
+
+-- | Nothing ends a pass, so a persistent fault is one attempt per stall interval rather than a hot
+-- loop: every error returns a wake, and the wait is outside the retries.
+runBadgeWorker :: UserId -> TMVar () -> CM ()
+runBadgeWorker userId badgeWork = do
+  emitted <- newTVarIO Nothing
+  ri <- asks $ badgeRetryInterval . config
+  forever $ do
+    at_ <- withRetryInterval ri $ \_ loop -> do
+      lift waitChatStartedAndActivated
+      now <- badgeNow
+      let stalled = pure $ Just $ badgeStalledInterval `addUTCTime` now
+      updateUserBadge userId emitted now `catchAllErrors` retryBadgeError loop stalled
+    now <- badgeNow
+    liftIO $ waitBadgeWake badgeWork now at_
+
+retryBadgeError :: CM a -> CM a -> ChatError -> CM a
+retryBadgeError loop stalled e = eToView e >> if badgeErrorRetry e then loop else stalled
+
+-- | The signal is taken only by the wait that reports it - the take and the timer read are one
+-- transaction. now is the badge clock, so the remaining time counts down rather than re-reading it.
+waitBadgeWake :: TMVar () -> UTCTime -> Maybe UTCTime -> IO ()
+waitBadgeWake badgeWork now = \case
+  Nothing -> atomically $ takeTMVar badgeWork
+  Just at -> waitFor $ diffToMicroseconds $ min badgeMaxWake $ diffUTCTime at now
+  where
+    waitFor time
+      | time <= 0 = pure ()
+      | otherwise = do
+          let maxWait = min time $ fromIntegral (maxBound :: Int)
+          timer <- registerDelay $ fromIntegral maxWait
+          signalled <- atomically $ do
+            w <- tryTakeTMVar badgeWork
+            fired <- readTVar timer
+            unless (isJust w || fired) retry
+            pure $ isJust w
+          unless signalled $ waitFor $ time - maxWait
+
+-- | Bounds the wait: a paidThrough far enough out would overflow the microsecond conversion,
+-- wrap negative and spin the worker. Longer than any entitlement, so no real wake is early.
+badgeMaxWake :: NominalDiffTime
+badgeMaxWake = 100 * 365 * nominalDay
+
+-- | 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)
+updateUserBadge userId emitted now = do
+  user <- withStore $ \db -> getUser db userId
+  withStore' (`getUserBadgePurchase` user) >>= \case
+    Nothing -> pure Nothing
+    Just p@UserBadgePurchase {badgePurchaseId} ->
+      withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= \case
+        Nothing -> pure Nothing
+        Just balance -> do
+          -- retirement needs no service and an unbounded retry would not return before it
+          retired <- retireExpiredBadge user p now balance
+          latest <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
+          let requestDue = not retired && badgeRequestDue now (shownBadgeCredential user p) latest balance
+          (balance', serviceAt) <-
+            if requestDue
+              then either ((balance,) . Just) (,Nothing) <$> requestBadgeIssue userId p now
+              else pure (balance, Nothing)
+          -- presenting broadcasts the record it is handed, and the request above can block for the
+          -- whole service timeout, so this read belongs after it and not at the top of the pass
+          user' <- withStore $ \db -> getUser db userId
+          -- and the purchase, or an alert acked while the request was in flight is raised again
+          p' <- fromMaybe p <$> withStore' (`getBadgePurchase` badgePurchaseId)
+          let issued = balanceStartTs balance' /= balanceStartTs balance
+          -- outside the badge lock: the chat lock must not be taken under it
+          unless retired $ presentIssuedBadge user' p' now
+          emitBadgeAlert user' emitted p' now balance'
+          -- retiring and presenting both replace the badge on the record read above, so it is read again
+          user'' <- withStore $ \db -> getUser db userId
+          when (retired || issued) $ toView . CEvtBadgeChanged user'' =<< getUserBadgeState user''
+          -- a snooze is the one wake that is not in the ledger: nothing else brings the alert back,
+          -- since support having ended leaves both ledger boundaries in the past
+          let UserBadgePurchase {alertSnoozeUntil} = p'
+              snoozeAt = find (> now) alertSnoozeUntil
+              stalledAt = if requestDue && not issued then Just $ badgeStalledInterval `addUTCTime` now else Nothing
+          pure $ earliestTime [serviceAt, snoozeAt, stalledAt, badgeBoundary now (shownBadgeCredential user'' p') balance']
+
+-- | Support ended is the only alert raised here: the others need subscriptions, and warning before
+-- a prepaid badge ends is not actionable while topping up cannot credit months without issuing.
+-- TODO [badges] BAPrepaidEnding belongs here, three days before paidThrough, once that exists.
+derivedBadgeAlert :: UTCTime -> StatementEntry -> Maybe BadgeAlert
+derivedBadgeAlert now b
+  | balanceMonths b == 0 && endsAt <= now =
+      Just BadgeAlert {kind = BASupportEnded, episode = safeDecodeUtf8 $ strEncode endsAt, date = endsAt, price = Nothing}
+  | otherwise = Nothing
+  where
+    endsAt = L.paidThrough b
+
+-- | Derived from state rather than kept pending: raised unless this occurrence is the one already
+-- answered, and raised again once a snooze that answered it lapses.
+unansweredBadgeAlert :: UTCTime -> UserBadgePurchase -> StatementEntry -> Maybe BadgeAlert
+unansweredBadgeAlert now UserBadgePurchase {alertAcked, alertSnoozeUntil} balance =
+  case derivedBadgeAlert now balance of
+    Just alert@BadgeAlert {kind, episode}
+      | alertAcked /= Just (kind, episode) || maybe False (now >=) alertSnoozeUntil -> Just alert
+    _ -> Nothing
+
+emitBadgeAlert :: User -> TVar (Maybe BadgeOccurrence) -> UserBadgePurchase -> UTCTime -> StatementEntry -> CM ()
+emitBadgeAlert user emitted p@UserBadgePurchase {alertSnoozeUntil} now balance =
+  forM_ (unansweredBadgeAlert now p balance) $ \alert@BadgeAlert {kind, episode} -> do
+    let occurrence = Just (kind, episode, alertSnoozeUntil)
+    raised <- atomically $ stateTVar emitted (,occurrence)
+    when (raised /= occurrence) $ toView $ CEvtBadgeAlert user alert
+
+-- | Read from stored rows alone; the worker's results follow as CEvtBadgeChanged.
+getUserBadgeState :: User -> CM (Maybe BadgeState)
+getUserBadgeState user = do
+  now <- badgeNow
+  withStore' (`getUserBadgePurchase` user) >>= \case
+    Nothing -> pure Nothing
+    Just p@UserBadgePurchase {badgePurchaseId} ->
+      fmap (badgeStateOf now p) <$> withStore' (`getBadgeLedgerLastEntry` badgePurchaseId)
+  where
+    badgeStateOf now p@UserBadgePurchase {badgePurchaseId, badgeType} balance =
+      BadgeState
+        { badgePurchaseId,
+          badgeType,
+          monthsLeft = balanceMonths balance,
+          paidThrough = L.paidThrough balance,
+          renewsAt = Nothing,
+          willRenew = False,
+          alert = unansweredBadgeAlert now p balance
+        }
+
+-- | How long a month that did not issue waits before it is tried again, whatever stopped it. Not
+-- derived from the failure, so a misclassified one cannot leave a funded badge to expire.
+badgeStalledInterval :: NominalDiffTime
+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
+
+-- | 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.
+badgeRequestLead :: NominalDiffTime
+badgeRequestLead = nominalDay
+
+-- | The credential the profile is showing for this purchase. Nothing when the purchase is not the
+-- one being shown, or when a crash left the issuance written and the profile not.
+shownBadgeCredential :: User -> UserBadgePurchase -> Maybe BadgeCredential
+shownBadgeCredential User {profile = LocalProfile {localBadge}} UserBadgePurchase {shown}
+  | not shown = Nothing
+  | otherwise = case localBadge of
+      Just (OwnBadge cred _) -> Just cred
+      _ -> Nothing
+
+credentialExpiry :: BadgeCredential -> UTCTime
+credentialExpiry (BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) = badgeExpiry
+
+-- | Timed off the shown credential, not the period end: renewing around its shared expiry is what
+-- joins the anonymity set. Latest still equal to shown means this month has not been asked for.
+badgeRequestDue :: UTCTime -> Maybe BadgeCredential -> Maybe BadgeCredential -> StatementEntry -> Bool
+badgeRequestDue now shownCred latestCred balance =
+  balanceMonths balance > 0 && latestCred == shownCred && maybe False lapsingSoon shownCred
+  where
+    lapsingSoon cred = credentialExpiry cred <= badgeRequestLead `addUTCTime` now
+
+-- | The request and the presentation, a day apart, both read off the credential the profile shows,
+-- and the end of what is paid for. The credential's expiry window is what covers renewal, so it
+-- says nothing about entitlement: paidThrough is when that ends and the badge has to come off.
+-- TODO [badges] every client whose credential shares an expiry requests at the same instant. Only
+-- the expiry has to be shared, so the request could fall anywhere in its lead without splitting
+-- the anonymity set - spreading the load, and any outage, off a single moment.
+badgeBoundary :: UTCTime -> Maybe BadgeCredential -> StatementEntry -> Maybe UTCTime
+badgeBoundary now shownCred balance = case filter (> now) moments of
+  [] -> Nothing
+  ts -> Just $ minimum ts
+  where
+    moments = L.paidThrough balance : maybe [] renewalMoments shownCred
+    renewalMoments cred =
+      let expiry = credentialExpiry cred
+       in [negate badgeRequestLead `addUTCTime` expiry, expiry]
+
+earliestTime :: [Maybe UTCTime] -> Maybe UTCTime
+earliestTime ts = case catMaybes ts of
+  [] -> Nothing
+  ts' -> Just $ minimum ts'
+
+-- | Only a failure that can clear on its own is repeated; every other throw is terminal, and
+-- repeating it would spin. Service errors are classified by retryAfter in requestBadgeIssue.
+badgeErrorRetry :: ChatError -> Bool
+badgeErrorRetry = \case
+  ChatErrorAgent {agentError} -> retryable agentError
+  _ -> False
+  where
+    -- an unanswered request is the likeliest renewal failure and temporaryOrHostError does not
+    -- cover it: that classifies reaching the server, and this timeout is the agent's own
+    retryable = \case
+      AGENT (A_SERVICE ASETimeout) -> True
+      e -> temporaryOrHostError e
+
+-- | Ask the service for the month that is due and apply the response. A timeout writes nothing, so
+-- the same request is sent again on the next pass. 'Left' is a service error, already reported, and
+-- carries when to try again, since a service error is answered rather than thrown.
+requestBadgeIssue :: UserId -> UserBadgePurchase -> UTCTime -> CM (Either UTCTime StatementEntry)
+requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, purchaseKey, purchasePrivKey, masterKey} now = do
+  sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwCmdError "badge service not configured") pure
+  withEntityLock "badgeIssue" (CLBadgeUser userId) $ do
+    user <- withStore $ \db -> getUser db userId
+    lastEntry <- withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= maybe (throwCmdError "badge ledger has no entry to assert") pure
+    let req =
+          BadgeServiceRequest
+            { version = currentBadgeServiceVersion,
+              purchaseKey = Just purchaseKey,
+              request = BSCIssueBadge {balance = BadgeBalance {lastEntry}}
+            }
+    respData <- sendServiceRequestTo NRMBackground user sendTarget Nothing (Just purchasePrivKey) req
+    case J.fromJSON (J.Object respData) of
+      J.Success BSPBadgeCredential {credential, statement} -> do
+        cred_ <- verifyIssuedCredential masterKey credential
+        -- TODO [badges] the statement is applied either way, so a failed verification spends the
+        -- month with nothing to show for it; that needs an alert, not only a line in the log
+        g <- asks random
+        applied <- withStore' $ \db -> applyBadgeStatement db g badgePurchaseId statement cred_ now
+        unless applied $ eToView $ ChatError $ CEInternalError "issued badge credential has no ledger row to store it against"
+        Right <$> (withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= maybe (throwCmdError "badge ledger has no balance") pure)
+      J.Success BSPError {code, retryAfter} -> do
+        eToView $ ChatError $ CECommandError $ "badge service error: " <> T.unpack (badgeServiceErrorText code)
+        ri <- asks $ badgeRetryInterval . config
+        pure $ Left $ badgeRetryAfter ri retryAfter `addUTCTime` now
+      _ -> throwCmdError "unexpected badge service response"
+
+-- | The signature covers the master key inside the credential, so it verifies no matter which key
+-- that is - the credential is stored only when that key is also this purchase's.
+verifyIssuedCredential :: BadgeMasterKey -> Maybe BadgeCredential -> CM (Maybe BadgeCredential)
+verifyIssuedCredential _ Nothing = pure Nothing
+verifyIssuedCredential masterKey (Just cred@(BadgeCredential _ credMasterKey _ _)) =
+  verifyOwnBadge cred >>= \case
+    Just True | credMasterKey == masterKey -> pure $ Just cred
+    Just True -> Nothing <$ eToView (ChatError $ CEInternalError "issued badge credential is for a different master key")
+    _ -> Nothing <$ eToView (ChatError $ CEInternalError "issued badge credential does not verify")
+
+-- | Present the newest issued credential once the one on the profile has run out. It is written in
+-- a separate transaction from the issuance, so a crash between the two is repaired at the next run.
+presentIssuedBadge :: User -> UserBadgePurchase -> UTCTime -> CM ()
+presentIssuedBadge user p@UserBadgePurchase {badgePurchaseId, shown} now
+  | not shown = pure ()
+  | otherwise = do
+      cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
+      forM_ cred_ $ \cred@(BadgeCredential _ _ _ info) ->
+        when (presentDue cred) $ do
+          user' <- withStore $ \db -> setUserBadge db user (Just $ OwnBadge cred (mkBadgeStatus now (Just True) info))
+          presentUserBadgeToContacts user'
+  where
+    shownCred = shownBadgeCredential user p
+    -- Held back until the shown credential lapses, so the broadcast does not correlate with the
+    -- request that produced it. Nothing shown at all is the state a lost profile write leaves.
+    presentDue cred = Just cred /= shownCred && maybe True ((<= now) . credentialExpiry) shownCred
+
+-- | The visible half of "the badge expired".
+retireExpiredBadge :: User -> UserBadgePurchase -> UTCTime -> StatementEntry -> CM Bool
+retireExpiredBadge user UserBadgePurchase {badgePurchaseId, shown} now balance
+  | not (shown && L.paidThrough balance <= now) = pure False
+  | otherwise = do
+      user' <- withStore $ \db -> do
+        liftIO $ clearShownBadge db user badgePurchaseId
+        setUserBadge db user Nothing
+      True <$ presentUserBadgeToContacts user'
+
+-- | Waiting on the var rather than skipping an empty one is what catches a worker whose creator
+-- had not filled it when the map was swapped out.
+stopBadgeWorkers :: TM.TMap UserId (SessionVar BadgeWorker) -> IO ()
+stopBadgeWorkers workers =
+  atomically (swapTVar workers M.empty) >>= mapM_ cancelBadgeWorker
+  where
+    cancelBadgeWorker v =
+      void $ forkIO $ atomically (badgeWorkerAsync <$> readTMVar (sessionVar v)) >>= uninterruptibleCancel
+
+-- | 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) statement =
   verifyOwnBadge cred >>= \case
     Nothing -> throwCmdError "redeemed badge credential names an unknown badge key index"
     Just False -> throwCmdError "redeemed badge credential does not verify against configured key"
@@ -5209,16 +5550,37 @@ storeRedeemedBadge user redemption@BadgeCodeRedemption {masterKey} cred@(BadgeCr
     Just True | credMasterKey /= masterKey -> throwCmdError "redeemed badge credential is for a different master key"
     Just True -> do
       g <- asks random
-      now <- liftIO getCurrentTime
+      now <- badgeNow
       let badge = OwnBadge cred (mkBadgeStatus now (Just True) info)
-      -- TODO [badges] copy the statement's ledger entries, and retire a previously held badge
-      (user', newBadge) <- withStore' $ \db -> do
-        newBadge <- createCodeBadgePurchase db g user redemption cred badgeExpiry now
+      -- TODO [badges] retire a previously held badge
+      (user', newBadge, applied) <- withStore $ \db -> do
+        (purchaseId, newBadge) <- liftIO $ createCodeBadgePurchase db user redemption cred now
+        applied <- liftIO $ applyBadgeStatement db g purchaseId 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 pure user
-        pure (user', newBadge)
-      when newBadge $ presentUserBadgeToContacts user'
-      pure $ CRBadgeRedeemed user' badge newBadge
+        user' <- if newBadge then setUserBadge db user (Just badge) else getUser db userId
+        pure (user', newBadge, applied)
+      unless applied $ eToView $ ChatError $ CEInternalError "redeemed badge credential has no ledger row to store it against"
+      -- nothing is due yet, but a pass is what arms the next wake, and this is the first purchase
+      lift $ startBadgeWork user'
+      pure (if newBadge then Just user' else Nothing, CRBadgeRedeemed user' badge newBadge)
+
+-- | Store the statement's rows, then the credential against the badge debit row among them.
+-- 'False' when that row cannot be found, which the caller reports rather than drop in silence.
+applyBadgeStatement :: DB.Connection -> TVar ChaChaDRG -> Int64 -> BadgeStatement -> Maybe BadgeCredential -> UTCTime -> IO Bool
+applyBadgeStatement db g purchaseId BadgeStatement {entries} cred_ now = do
+  tip <- getBadgeLedgerLastEntry db purchaseId
+  storeBadgeStatement db purchaseId tip entries now
+  case (,) <$> cred_ <*> issuedEntryId of
+    Nothing -> pure True
+    Just (cred, entryUuid) ->
+      getBadgeLedgerEntryId db purchaseId entryUuid >>= \case
+        Nothing -> pure False
+        Just entryId -> storeBadgeIssuance db g purchaseId entryId cred now
+  where
+    -- the credential belongs to the last month the statement issued
+    issuedEntryId = case [entryId | StatementEntry {entryId, entryType = SEDebit SDBadge} <- entries] of
+      [] -> Nothing
+      ids -> Just (last ids)
 
 sendServiceRequestTo :: J.ToJSON a => NetworkRequestMode -> User -> ConnectTarget 'CMContact -> Maybe NominalDiffTime -> Maybe C.PrivateKeyEd25519 -> a -> CM J.Object
 sendServiceRequestTo nm user sendTarget requestTimeout signKey request = do
@@ -5625,6 +5987,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 state " *> (APIGetBadgeState <$> A.decimal),
+      "/_badge ack " *> (APIAckBadgeAlert <$> A.decimal <* A.space <*> A.decimal <* A.space <*> badgeAlertKindP <* A.space <*> onOffP <* A.space <*> textP),
       "/_service_response " *> (APISendServiceResponse <$> A.decimal <* A.space <*> strP <* A.space <*> jsonP),
       "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP),
       "/call " *> char_ '@' *> (SendCallInvitation <$> displayNameP <*> pure defaultCallType),
@@ -6044,6 +6408,9 @@ chatCommandP =
       descr <- A.takeWhile1 isSpace *> (T.dropWhileEnd isSpace <$> textP) <|> pure ""
       pure $ if T.null descr then Nothing else Just $ T.take 160 descr
     textP = safeDecodeUtf8 <$> A.takeByteString
+    badgeAlertKindP = do
+      t <- A.takeTill (== ' ')
+      maybe (fail "bad badge alert kind") pure $ textDecode $ safeDecodeUtf8 t
     pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' '))
     verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ')
     msgTextP = jsonP <|> textP

src/Simplex/Chat/Store/Badges.hs

@@ -7,10 +7,22 @@
 
 module Simplex.Chat.Store.Badges
   ( BadgeCodeRedemption (..),
+    UserBadgePurchase (..),
+    getUserBadgePurchase,
+    getBadgePurchase,
+    userHasBadge,
+    setBadgeAlertAcked,
+    clearShownBadge,
     getBadgeCodeRedemption,
     createBadgeCodeRedemption,
     deleteBadgeCodeRedemption,
     createCodeBadgePurchase,
+    getCodeBadgePurchase,
+    storeBadgeIssuance,
+    getLatestIssuedCredential,
+    storeBadgeStatement,
+    getBadgeLedgerLastEntry,
+    getBadgeLedgerEntryId,
   )
 where
 
@@ -19,23 +31,26 @@ import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson as J
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
+import Data.Maybe (isJust)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.Badges
-import Simplex.Chat.Badges.Types (BadgePurchaseStatus (..))
+import Simplex.Chat.Badges.Ledger
+import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
+import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgePurchaseStatus (..))
 import Simplex.Chat.Store.Shared (insertedRowId)
 import Simplex.Chat.Types
-import Simplex.Messaging.Agent.Store.DB (Binary (..))
+import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (strEncode)
-import Simplex.Messaging.Util (maybeFirstRow, safeDecodeUtf8)
+import Simplex.Messaging.Util (decodeJSON, maybeFirstRow, maybeFirstRow', safeDecodeUtf8)
 
 #if defined(dbPostgres)
-import Database.PostgreSQL.Simple (Only (..))
+import Database.PostgreSQL.Simple (Only (..), (:.) (..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 #else
-import Database.SQLite.Simple (Only (..))
+import Database.SQLite.Simple (Only (..), (:.) (..))
 import Database.SQLite.Simple.QQ (sql)
 #endif
 
@@ -90,21 +105,13 @@ deleteBadgeCodeRedemption db redemptionId =
     |]
     (redemptionId, redemptionId)
 
--- | The purchase a redeemed code created, its issuance, and the profile's pointer to it.
--- False when the code was already redeemed here: the service replays the credential it issued,
--- and that must add no purchase and leave the shown badge alone.
-createCodeBadgePurchase :: DB.Connection -> TVar ChaChaDRG -> User -> BadgeCodeRedemption -> BadgeCredential -> UTCTime -> UTCTime -> IO Bool
-createCodeBadgePurchase db g User {userId} redemption credential expiry now =
+-- | 'False' when the code was already redeemed 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
-    Just _ -> pure False
+    Just purchaseId -> pure (purchaseId, False)
     Nothing -> do
-      purchaseId <- insertPurchase
-      DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (purchaseId, userId)
-      pure True
-  where
-    BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = redemption
-    BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = credential
-    insertPurchase = do
       DB.execute
         db
         [sql|
@@ -114,19 +121,217 @@ createCodeBadgePurchase db g User {userId} redemption credential expiry now =
         |]
         (userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType, PSIssued, redemptionId, 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
+    BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = credential
+
+-- | 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.
+-- A replayed statement names a month already issued, and one month has one issuance.
+storeBadgeIssuance :: DB.Connection -> TVar ChaChaDRG -> Int64 -> Int64 -> BadgeCredential -> UTCTime -> IO Bool
+storeBadgeIssuance db g badgePurchaseId entryId credential now =
+  getIssuedPeriod db badgePurchaseId entryId >>= \case
+    Nothing -> pure False
+    Just (periodStart, periodEnd) -> do
       issuanceId <- safeDecodeUtf8 . strEncode <$> atomically (C.randomBytes 16 g)
-      -- TODO [badges] the credential's expiry stands in for the period end, which is up to a
-      -- week later, until the statement carries the real period
       DB.execute
         db
         [sql|
-          INSERT INTO badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at)
-          VALUES (?,?,?,?,?,?,?,?)
+          INSERT INTO badge_issuances (issuance_id, badge_purchase_id, entry_id, badge_type, period_start, period_end, expiry, credential, created_at)
+          VALUES (?,?,?,?,?,?,?,?,?)
+          ON CONFLICT (badge_purchase_id, entry_id) DO NOTHING
         |]
-        (issuanceId, purchaseId, badgeType, now, expiry, expiry, Binary (LB.toStrict $ J.encode credential), now)
-      pure purchaseId
+        ((issuanceId, badgePurchaseId, entryId, badgeType) :. (periodStart, periodEnd, badgeExpiry, Binary (LB.toStrict $ J.encode credential), now))
+      pure True
+  where
+    BadgeCredential {badgeInfo = BadgeInfo {badgeType, badgeExpiry}} = credential
+
+getLatestIssuedCredential :: DB.Connection -> Int64 -> IO (Maybe BadgeCredential)
+getLatestIssuedCredential db badgePurchaseId = do
+  rows <-
+    DB.query
+      db
+      [sql|
+        SELECT credential FROM badge_issuances
+        WHERE badge_purchase_id = ?
+        ORDER BY period_end DESC
+        LIMIT 1
+      |]
+      (Only badgePurchaseId)
+  pure $ case rows of
+    [Only (Binary bs)] -> J.decodeStrict' bs
+    _ -> Nothing
+
+-- the start is read from the row before rather than by subtracting a month, which clips
+getIssuedPeriod :: DB.Connection -> Int64 -> Int64 -> IO (Maybe (UTCTime, UTCTime))
+getIssuedPeriod db badgePurchaseId entryId = do
+  rows <-
+    DB.query
+      db
+      [sql|
+        SELECT
+          (SELECT prev.balance_start_ts FROM badge_ledger prev
+           WHERE prev.badge_purchase_id = issued.badge_purchase_id AND prev.entry_id < issued.entry_id
+           ORDER BY prev.entry_id DESC LIMIT 1),
+          issued.balance_start_ts
+        FROM badge_ledger issued
+        WHERE issued.badge_purchase_id = ? AND issued.entry_id = ?
+      |]
+      (badgePurchaseId, entryId)
+  -- no preceding row means no credit was ever stored, so the period this row issued is unknown
+  pure $ case rows of
+    [(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)
+
+data UserBadgePurchase = UserBadgePurchase
+  { badgePurchaseId :: Int64,
+    purchaseKey :: C.PublicKeyEd25519,
+    purchasePrivKey :: C.PrivateKeyEd25519,
+    masterKey :: BadgeMasterKey,
+    badgeType :: BadgeType,
+    shown :: Bool,
+    alertAcked :: Maybe (BadgeAlertKind, Text),
+    alertSnoozeUntil :: Maybe UTCTime
+  }
+
+-- | Newest, not the one shown_badge_id points at - retirement clears that, and the support ended
+-- alert is recomputed from this purchase after the badge stops being shown.
+getUserBadgePurchase :: DB.Connection -> User -> IO (Maybe UserBadgePurchase)
+getUserBadgePurchase db User {userId} =
+  maybeFirstRow fromOnly newestId >>= maybe (pure Nothing) (getBadgePurchase db)
+  where
+    newestId =
+      DB.query
+        db
+        [sql|
+          SELECT badge_purchase_id FROM badge_purchases
+          WHERE user_id = ? AND purchase_priv_key IS NOT NULL
+          ORDER BY badge_purchase_id DESC
+          LIMIT 1
+        |]
+        (Only userId)
+
+-- shown is a CASE because in Postgres a comparison is boolean, which BoolInt rejects.
+getBadgePurchase :: DB.Connection -> Int64 -> IO (Maybe UserBadgePurchase)
+getBadgePurchase db purchaseId =
+  maybeFirstRow toPurchase $
+    DB.query
+      db
+      [sql|
+        SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type,
+               (CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END),
+               p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until
+        FROM badge_purchases p
+        JOIN users u ON u.user_id = p.user_id
+        WHERE p.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL
+      |]
+      (Only purchaseId)
+  where
+    toPurchase (badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) =
+      UserBadgePurchase
+        { badgePurchaseId,
+          purchaseKey,
+          purchasePrivKey,
+          masterKey = BadgeMasterKey mk,
+          badgeType,
+          shown = unBI shown_,
+          alertAcked = (,) <$> ackedKind_ <*> ackedEpisode_,
+          alertSnoozeUntil
+        }
+
+-- | Whether a badge is on the profile now: set when a redemption stores one, cleared when it is
+-- retired. Read as the id rather than as a comparison, which in Postgres would be a boolean.
+userHasBadge :: DB.Connection -> User -> IO Bool
+userHasBadge db User {userId} =
+  maybeFirstRow' False shownBadge $
+    DB.query db "SELECT shown_badge_id FROM users WHERE user_id = ?" (Only userId)
+  where
+    shownBadge :: Only (Maybe Int64) -> Bool
+    shownBadge = isJust . fromOnly
+
+-- | An ack and a snooze both record the occurrence answered; a snooze also records how long it
+-- holds, so that it silences that occurrence and not whichever one is derived next.
+setBadgeAlertAcked :: DB.Connection -> Int64 -> BadgeAlertKind -> Text -> Maybe UTCTime -> IO ()
+setBadgeAlertAcked db badgePurchaseId kind episode snoozeUntil =
+  DB.execute
+    db
+    "UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?, alert_snooze_until = ? WHERE badge_purchase_id = ?"
+    (kind, episode, snoozeUntil, badgePurchaseId)
+
+-- | Stop showing a badge that has expired unrenewed; the profile update is broadcast by the caller.
+clearShownBadge :: DB.Connection -> User -> Int64 -> IO ()
+clearShownBadge db User {userId} badgePurchaseId =
+  DB.execute db "UPDATE users SET shown_badge_id = NULL WHERE user_id = ? AND shown_badge_id = ?" (userId, badgePurchaseId)
+
+-- | Verbatim, entry_uuid and type included: the client authors no row, or the two sides stop
+-- holding the same ledger. DO NOTHING makes a re-applied statement a no-op rather than a throw.
+-- An entry whose balance does not follow from the one before it is stored and marked, not refused.
+storeBadgeStatement :: DB.Connection -> Int64 -> Maybe StatementEntry -> [StatementEntry] -> UTCTime -> IO ()
+storeBadgeStatement db badgePurchaseId tip entries now =
+  mapM_ storeEntry $ balanceChecked tip entries
+  where
+    storeEntry (StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType}, checked) =
+      DB.execute
+        db
+        [sql|
+          INSERT INTO badge_ledger
+            (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
+             was_paused_since, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type,
+             entry_type_unknown, entry_type_value, balance_checked)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+          ON CONFLICT (entry_uuid) DO NOTHING
+        |]
+        ( (entryId, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince)
+            :. (createdAt, now, entryTypeT, creditType, debitType, BI typeUnknown, entryTypeValue, BI <$> checked)
+        )
+      where
+        (entryTypeT, creditType, debitType) = entryTypeColumns entryType
+        -- kept for every entry, not only for a type this version cannot decode: a tag alone does
+        -- not rebuild the types that name an invoice, a charge or another purchase
+        entryTypeValue = safeDecodeUtf8 . LB.toStrict $ case entryType of
+          SECredit c -> J.encode c
+          SEDebit d -> J.encode d
+        typeUnknown = case entryType of
+          SECredit SCUnknown {} -> True
+          SEDebit SDUnknown {} -> True
+          _ -> False
+
+-- | The balance is the last row; nothing derives it by summing the history.
+getBadgeLedgerLastEntry :: DB.Connection -> Int64 -> IO (Maybe StatementEntry)
+getBadgeLedgerLastEntry db badgePurchaseId =
+  maybeFirstRow' Nothing toEntry $
+    DB.query
+      db
+      [sql|
+        SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
+               was_paused_since, service_created_at, entry_type, entry_credit_type, entry_debit_type, entry_type_value
+        FROM badge_ledger
+        WHERE badge_purchase_id = ?
+        ORDER BY entry_id DESC
+        LIMIT 1
+      |]
+      (Only badgePurchaseId)
+  where
+    toEntry ((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_
+
+-- | 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.
+entryTypeFromValue :: Text -> Text -> Maybe StatementEntryType
+entryTypeFromValue entryTypeT value_ = case entryTypeT of
+  "credit" -> SECredit <$> decodeJSON value_
+  "debit" -> SEDebit <$> decodeJSON value_
+  _ -> Nothing
+
+getBadgeLedgerEntryId :: DB.Connection -> Int64 -> Text -> IO (Maybe Int64)
+getBadgeLedgerEntryId db badgePurchaseId entryUuid =
+  maybeFirstRow fromOnly $
+    DB.query db "SELECT entry_id FROM badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?" (badgePurchaseId, entryUuid)

src/Simplex/Chat/Store/Postgres/Migrations/M20261001_user_badges.hs

@@ -143,6 +143,7 @@ CREATE TABLE @badge_ledger(
   change_months SMALLINT NOT NULL,
   balance_months SMALLINT NOT NULL,
   balance_start_ts TIMESTAMPTZ NOT NULL,
+  balance_anchor_ts TIMESTAMPTZ NOT NULL,
   balance_badge_type TEXT NOT NULL,
   was_paused_since TIMESTAMPTZ,
   service_created_at TIMESTAMPTZ NOT NULL,
@@ -183,6 +184,8 @@ CREATE TABLE @badge_issuances(
 CREATE INDEX @idx_badge_issuances_purchase ON @badge_issuances(badge_purchase_id, issuance_id);
 
 CREATE INDEX @idx_badge_issuances_entry ON @badge_issuances(entry_id);
+
+CREATE UNIQUE INDEX @idx_badge_issuances_purchase_entry ON @badge_issuances(badge_purchase_id, entry_id);
 |]
 
 badgeSchemaTablesDown :: Text
@@ -190,6 +193,7 @@ badgeSchemaTablesDown =
   [r|
 DROP INDEX @idx_badge_issuances_purchase;
 DROP INDEX @idx_badge_issuances_entry;
+DROP INDEX @idx_badge_issuances_purchase_entry;
 DROP TABLE @badge_issuances;
 DROP INDEX @idx_badge_ledger_uuid;
 DROP INDEX @idx_badge_ledger_purchase;
@@ -237,6 +241,8 @@ ALTER TABLE badge_ledger ADD COLUMN entry_type_unknown SMALLINT NOT NULL DEFAULT
 
 ALTER TABLE badge_ledger ADD COLUMN entry_type_value TEXT;
 
+ALTER TABLE badge_ledger ADD COLUMN balance_checked SMALLINT;
+
 CREATE INDEX idx_badge_purchases_user ON badge_purchases(user_id);
 
 ALTER TABLE users ADD COLUMN shown_badge_id BIGINT REFERENCES badge_purchases ON DELETE SET NULL;

src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql

@@ -223,6 +223,7 @@ CREATE TABLE test_chat_schema.badge_ledger (
     change_months smallint NOT NULL,
     balance_months smallint NOT NULL,
     balance_start_ts timestamp with time zone NOT NULL,
+    balance_anchor_ts timestamp with time zone NOT NULL,
     balance_badge_type text NOT NULL,
     was_paused_since timestamp with time zone,
     service_created_at timestamp with time zone NOT NULL,
@@ -235,7 +236,8 @@ CREATE TABLE test_chat_schema.badge_ledger (
     from_purchase_id bigint,
     to_purchase_id bigint,
     entry_type_unknown smallint DEFAULT 0 NOT NULL,
-    entry_type_value text
+    entry_type_value text,
+    balance_checked smallint
 );
 
 
@@ -2214,6 +2216,10 @@ CREATE INDEX idx_badge_issuances_purchase ON test_chat_schema.badge_issuances US
 
 
 
+CREATE UNIQUE INDEX idx_badge_issuances_purchase_entry ON test_chat_schema.badge_issuances USING btree (badge_purchase_id, entry_id);
+
+
+
 CREATE INDEX idx_badge_ledger_charge ON test_chat_schema.badge_ledger USING btree (charge_id);
 
 

src/Simplex/Chat/Store/Profiles.hs

@@ -382,19 +382,21 @@ updateUserProfileFields_' db userId profileId Profile {displayName, fullName, sh
 
 -- store the user's own badge credential; touches only the badge columns.
 -- bumps user_member_profile_updated_at so groups receive the updated profile (with the badge) on the next message.
-setUserBadge :: DB.Connection -> User -> Maybe LocalBadge -> IO User
-setUserBadge db user@User {userId, profile = p@LocalProfile {profileId}} localBadge = do
-  ts <- getCurrentTime
-  DB.execute
-    db
-    [sql|
-      UPDATE contact_profiles
-      SET badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?, updated_at = ?
-      WHERE user_id = ? AND contact_profile_id = ?
-    |]
-    (localBadgeToRow localBadge :. (ts, userId, profileId))
-  DB.execute db "UPDATE users SET user_member_profile_updated_at = ? WHERE user_id = ?" (ts, userId)
-  pure (user :: User) {profile = p {localBadge}, userMemberProfileUpdatedAt = Just ts}
+-- answers the row as stored, or a profile edit landing since the caller's read is broadcast back stale.
+setUserBadge :: DB.Connection -> User -> Maybe LocalBadge -> ExceptT StoreError IO User
+setUserBadge db User {userId, profile = LocalProfile {profileId}} localBadge = do
+  liftIO $ do
+    ts <- getCurrentTime
+    DB.execute
+      db
+      [sql|
+        UPDATE contact_profiles
+        SET badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?, updated_at = ?
+        WHERE user_id = ? AND contact_profile_id = ?
+      |]
+      (localBadgeToRow localBadge :. (ts, userId, profileId))
+    DB.execute db "UPDATE users SET user_member_profile_updated_at = ? WHERE user_id = ?" (ts, userId)
+  getUser db userId
 
 setUserSimplexDomain :: DB.Connection -> User -> Maybe SimplexDomain -> IO User
 setUserSimplexDomain db user@User {userId, profile = p@LocalProfile {profileId}} domain_ = do

src/Simplex/Chat/Store/SQLite/Migrations/M20261001_user_badges.hs

@@ -144,6 +144,7 @@ CREATE TABLE @badge_ledger(
   change_months INTEGER NOT NULL,
   balance_months INTEGER NOT NULL,
   balance_start_ts TEXT NOT NULL,
+  balance_anchor_ts TEXT NOT NULL,
   balance_badge_type TEXT NOT NULL,
   was_paused_since TEXT,
   service_created_at TEXT NOT NULL,
@@ -184,6 +185,8 @@ CREATE TABLE @badge_issuances(
 CREATE INDEX @idx_badge_issuances_purchase ON @badge_issuances(badge_purchase_id, issuance_id);
 
 CREATE INDEX @idx_badge_issuances_entry ON @badge_issuances(entry_id);
+
+CREATE UNIQUE INDEX @idx_badge_issuances_purchase_entry ON @badge_issuances(badge_purchase_id, entry_id);
 |]
 
 badgeSchemaTablesDown :: Query
@@ -191,6 +194,7 @@ badgeSchemaTablesDown =
   [sql|
 DROP INDEX @idx_badge_issuances_purchase;
 DROP INDEX @idx_badge_issuances_entry;
+DROP INDEX @idx_badge_issuances_purchase_entry;
 DROP TABLE @badge_issuances;
 DROP INDEX @idx_badge_ledger_uuid;
 DROP INDEX @idx_badge_ledger_purchase;
@@ -238,6 +242,8 @@ ALTER TABLE badge_ledger ADD COLUMN entry_type_unknown INTEGER NOT NULL DEFAULT
 
 ALTER TABLE badge_ledger ADD COLUMN entry_type_value TEXT;
 
+ALTER TABLE badge_ledger ADD COLUMN balance_checked INTEGER;
+
 CREATE INDEX idx_badge_purchases_user ON badge_purchases(user_id);
 
 ALTER TABLE users ADD COLUMN shown_badge_id INTEGER REFERENCES badge_purchases ON DELETE SET NULL;

src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt

@@ -1204,8 +1204,19 @@ Plan:
 SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_group (group_id=? AND shared_msg_id=?)
 
 Query: 
-          INSERT INTO badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at)
-          VALUES (?,?,?,?,?,?,?,?)
+          INSERT INTO badge_issuances (issuance_id, badge_purchase_id, entry_id, badge_type, period_start, period_end, expiry, credential, created_at)
+          VALUES (?,?,?,?,?,?,?,?,?)
+          ON CONFLICT (badge_purchase_id, entry_id) DO NOTHING
+        
+Plan:
+
+Query: 
+          INSERT INTO badge_ledger
+            (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
+             was_paused_since, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type,
+             entry_type_unknown, entry_type_value, balance_checked)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+          ON CONFLICT (entry_uuid) DO NOTHING
         
 Plan:
 
@@ -2017,6 +2028,20 @@ Query:
       
 Plan:
 
+Query: 
+        SELECT
+          (SELECT prev.balance_start_ts FROM badge_ledger prev
+           WHERE prev.badge_purchase_id = issued.badge_purchase_id AND prev.entry_id < issued.entry_id
+           ORDER BY prev.entry_id DESC LIMIT 1),
+          issued.balance_start_ts
+        FROM badge_ledger issued
+        WHERE issued.badge_purchase_id = ? AND issued.entry_id = ?
+      
+Plan:
+SEARCH issued USING INTEGER PRIMARY KEY (rowid=?)
+CORRELATED SCALAR SUBQUERY 1
+SEARCH prev USING INDEX idx_badge_ledger_purchase (badge_purchase_id=? AND entry_id<?)
+
 Query: 
         SELECT
           -- Contact
@@ -3729,6 +3754,16 @@ Query:
 Plan:
 SEARCH cp USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: 
+        SELECT credential FROM badge_issuances
+        WHERE badge_purchase_id = ?
+        ORDER BY period_end DESC
+        LIMIT 1
+      
+Plan:
+SEARCH badge_issuances USING INDEX idx_badge_issuances_purchase_entry (badge_purchase_id=?)
+USE TEMP B-TREE FOR ORDER BY
+
 Query: 
         SELECT ct.contact_id
         FROM contacts ct
@@ -3781,6 +3816,17 @@ Query:
 Plan:
 SEARCH contact_profiles USING INDEX idx_contact_profiles_user_id (user_id=?)
 
+Query: 
+        SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
+               was_paused_since, service_created_at, entry_type, entry_credit_type, entry_debit_type, entry_type_value
+        FROM badge_ledger
+        WHERE badge_purchase_id = ?
+        ORDER BY entry_id DESC
+        LIMIT 1
+      
+Plan:
+SEARCH badge_ledger USING INDEX idx_badge_ledger_purchase (badge_purchase_id=?)
+
 Query: 
         SELECT f.file_id
         FROM files f
@@ -3981,6 +4027,20 @@ Plan:
 SEARCH m USING INDEX idx_group_members_user_id (user_id=?)
 SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: 
+        SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type,
+               (CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END),
+               p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until
+        FROM badge_purchases p
+        JOIN users u ON u.user_id = p.user_id
+        WHERE p.user_id = ? AND p.purchase_priv_key IS NOT NULL
+        ORDER BY p.badge_purchase_id DESC
+        LIMIT 1
+      
+Plan:
+SEARCH u USING INTEGER PRIMARY KEY (rowid=?)
+SEARCH p USING INDEX idx_badge_purchases_user (user_id=?)
+
 Query: 
         SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.msg_chat_binding, m.msg_signatures
         FROM pending_group_messages pgm
@@ -7018,6 +7078,11 @@ Plan:
 Query: INSERT INTO app_settings (app_settings) VALUES (?)
 Plan:
 
+Query: INSERT INTO badge_ledger (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts,  balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type,  entry_type_unknown, entry_type_value) SELECT 'unknown-entry', badge_purchase_id, 0, balance_months, balance_start_ts, balance_anchor_ts,  balance_badge_type, service_created_at, created_at, 'credit', 'grant', 1, '{"type":"grant"}' FROM badge_ledger ORDER BY entry_id DESC LIMIT 1
+Plan:
+SCAN badge_ledger
+SEARCH badge_issuances USING COVERING INDEX idx_badge_issuances_entry (entry_id=?)
+
 Query: INSERT INTO chat_item_mentions (chat_item_id, group_id, member_id, display_name) VALUES (?, ?, ?, ?)
 Plan:
 
@@ -7205,6 +7270,10 @@ Query: SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv
 Plan:
 SEARCH connections USING INDEX idx_connections_conn_req_inv (user_id=? AND conn_req_inv=?)
 
+Query: SELECT alert_acked_kind, alert_acked_episode FROM badge_purchases
+Plan:
+SCAN badge_purchases
+
 Query: SELECT app_settings FROM app_settings
 Plan:
 SCAN app_settings
@@ -7217,6 +7286,14 @@ Query: SELECT auth_err_counter FROM connections WHERE user_id = ? AND connection
 Plan:
 SEARCH connections USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: SELECT badge_expiry, contact_profile_id FROM contact_profiles WHERE badge_proof IS NOT NULL ORDER BY contact_profile_id
+Plan:
+SCAN contact_profiles
+
+Query: SELECT badge_expiry, contact_profile_id FROM contact_profiles WHERE badge_signature IS NOT NULL ORDER BY contact_profile_id
+Plan:
+SCAN contact_profiles
+
 Query: SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption_id = ?
 Plan:
 SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
@@ -7354,6 +7431,24 @@ 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 entry_id FROM badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?
+Plan:
+SEARCH badge_ledger USING INDEX idx_badge_ledger_uuid (entry_uuid=?)
+
+Query: SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, COALESCE(entry_credit_type, entry_debit_type) FROM badge_ledger ORDER BY entry_id
+Plan:
+SCAN badge_ledger
+
+Query: SELECT expiry, badge_purchase_id FROM badge_issuances ORDER BY period_end
+Plan:
+SCAN badge_issuances
+USE TEMP B-TREE FOR ORDER BY
+
+Query: SELECT expiry, badge_purchase_id FROM badge_issuances ORDER BY period_end DESC LIMIT 1
+Plan:
+SCAN badge_issuances
+USE TEMP B-TREE FOR ORDER BY
+
 Query: SELECT file_id FROM files WHERE user_id = ? AND redirect_file_id = ?
 Plan:
 SEARCH files USING INDEX idx_files_redirect_file_id (redirect_file_id=?)
@@ -7554,6 +7649,14 @@ Query: SELECT should_sync FROM connections_sync WHERE connections_sync_id = 1
 Plan:
 SEARCH connections_sync USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: SELECT shown_badge_id FROM users WHERE user_id = ?
+Plan:
+SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
+
+Query: SELECT shown_badge_id, user_id FROM users WHERE user_id = 1
+Plan:
+SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: SELECT stored_roster_version FROM groups WHERE group_id = ?
 Plan:
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
@@ -7582,6 +7685,10 @@ Query: SELECT xgrplinkmem_received FROM group_members WHERE group_member_id = ?
 Plan:
 SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?, alert_snooze_until = ? WHERE badge_purchase_id = ?
+Plan:
+SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
+
 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=?)
@@ -7646,6 +7753,14 @@ Query: UPDATE connections_sync SET should_sync = 1 WHERE connections_sync_id = 1
 Plan:
 SEARCH connections_sync USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE contact_profiles SET badge_expiry = ? WHERE badge_proof IS NOT NULL
+Plan:
+SCAN contact_profiles
+
+Query: UPDATE contact_profiles SET badge_expiry = ? WHERE badge_signature IS NOT NULL
+Plan:
+SCAN contact_profiles
+
 Query: UPDATE contact_profiles SET contact_domain = ?, updated_at = ? WHERE user_id = ? AND contact_profile_id = ?
 Plan:
 SEARCH contact_profiles USING INTEGER PRIMARY KEY (rowid=?)
@@ -8034,6 +8149,10 @@ Query: UPDATE users SET shown_badge_id = ? WHERE user_id = ?
 Plan:
 SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE users SET shown_badge_id = NULL WHERE user_id = ? AND shown_badge_id = ?
+Plan:
+SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: UPDATE users SET ui_themes = ?, updated_at = ? WHERE user_id = ?
 Plan:
 SEARCH users USING INTEGER PRIMARY KEY (rowid=?)

src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql

@@ -963,6 +963,7 @@ CREATE TABLE badge_ledger(
   change_months INTEGER NOT NULL,
   balance_months INTEGER NOT NULL,
   balance_start_ts TEXT NOT NULL,
+  balance_anchor_ts TEXT NOT NULL,
   balance_badge_type TEXT NOT NULL,
   was_paused_since TEXT,
   service_created_at TEXT NOT NULL,
@@ -976,7 +977,8 @@ CREATE TABLE badge_ledger(
   to_purchase_id INTEGER REFERENCES badge_purchases
   ,
   entry_type_unknown INTEGER NOT NULL DEFAULT 0,
-  entry_type_value TEXT
+  entry_type_value TEXT,
+  balance_checked INTEGER
 ) STRICT;
 CREATE TABLE badge_issuances(
   issuance_id TEXT NOT NULL PRIMARY KEY,
@@ -1556,6 +1558,10 @@ CREATE INDEX idx_badge_issuances_purchase ON badge_issuances(
   issuance_id
 );
 CREATE INDEX idx_badge_issuances_entry ON badge_issuances(entry_id);
+CREATE UNIQUE INDEX idx_badge_issuances_purchase_entry ON badge_issuances(
+  badge_purchase_id,
+  entry_id
+);
 CREATE INDEX idx_badge_purchases_user ON badge_purchases(user_id);
 CREATE INDEX idx_users_shown_badge ON users(shown_badge_id);
 CREATE INDEX idx_badge_code_redemptions_user ON badge_code_redemptions(

src/Simplex/Chat/Store/Shared.hs

@@ -73,6 +73,7 @@ data ChatLockEntity
   | CLUserContact Int64
   | CLContactRequest Int64
   | CLFile Int64
+  | CLBadgeUser Int64 -- one signed badge request per profile in flight
   deriving (Eq, Ord)
 
 -- These error type constructors must be added to mobile apps

src/Simplex/Chat/View.hs

@@ -44,6 +44,7 @@ import Simplex.Chat.Help
 import Simplex.Chat.Library.Commands (maxImageSize)
 import Simplex.Chat.Markdown
 import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus)
+import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeState (..))
 import Simplex.Chat.Messages hiding (NewChatItem (..))
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Operators
@@ -190,6 +191,7 @@ 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
   CRGroupCreated u g -> ttyUser u $ viewGroupCreated g testView
   CRPublicGroupCreated u g _groupLink _relays -> ttyUser u $ viewGroupCreated g testView
   CRPublicGroupCreationFailed u results -> ttyUser u $ viewPublicGroupCreationFailed results
@@ -476,6 +478,8 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
         <> maybe [] (\k -> [plain $ "signed by " <> safeDecodeUtf8 (strEncode k)]) sigKey_
         <> ["request: " <> viewJSON req]
   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
   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
@@ -1829,9 +1833,30 @@ viewContactBadge = maybe [] $ \lb ->
         BSExpiredOld -> "expired (old)"
         BSFailed -> "verification failed"
         BSUnknownKey -> "unknown key"
-      expiry = "expires " <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" badgeExpiry)
+      expiry = "expires " <> day badgeExpiry
    in [plain (textEncode badgeType <> " badge - " <> st), plain expiry]
 
+viewUserBadgeState :: Maybe BadgeState -> [StyledString]
+viewUserBadgeState = maybe [] viewBadge
+  where
+    viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert} =
+      plain
+        ( tshow badgePurchaseId
+            <> ": "
+            <> textEncode badgeType
+            <> ", "
+            <> tshow monthsLeft
+            <> " months left, paid through "
+            <> day paidThrough
+        )
+        : maybe [] viewBadgeAlert alert
+
+viewBadgeAlert :: BadgeAlert -> [StyledString]
+viewBadgeAlert BadgeAlert {kind, date} = [plain $ "badge alert: " <> textEncode kind <> " " <> day date]
+
+day :: UTCTime -> Text
+day = T.pack . formatTime defaultTimeLocale "%Y-%m-%d"
+
 viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString]
 viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink, localBadge, contactDomain, contactDomainVerified, description}, activeConn, uiThemes, customData} stats incognitoProfile =
   ["contact ID: " <> sShow contactId]