Merge remote-tracking branch 'origin/master' into ab/wallet

src/Simplex/Chat.hs

@@ -28,7 +28,7 @@ import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime, nominalDay)
-import Simplex.Chat.Badges (badgeServerCredential)
+import Simplex.Chat.Badges (badgeServerCredential, defaultFileSizeLimits)
 import Simplex.Chat.Controller
 import Simplex.Chat.Library.Commands
 import Simplex.Chat.Operators
@@ -53,6 +53,7 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConf
 import Simplex.Messaging.Client (defaultNetworkConfig)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Entitlement (entitlementIssuerKeys)
+import Simplex.Messaging.Encoding.String (strDecode)
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolType (..), SProtocolType (..), SubscriptionMode (..), UserProtocol)
 import qualified Simplex.Messaging.TMap as TM
 import qualified UnliftIO.Exception as E
@@ -68,6 +69,9 @@ defaultChatConfig =
           },
       chatVRange = supportedChatVRange,
       badgePublicKeys = M.mapKeys fromIntegral entitlementIssuerKeys,
+      badgeServiceAddress = Just $ either error id $ strDecode "https://smp5.simplex.im/a#ooSNWlEZTO2RPE0Ff5ZoybAs5zEhWLMlQrXesnhaZHM",
+      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
@@ -102,10 +106,12 @@ defaultChatConfig =
       shortLinkPresetServers = allPresetServers,
       presetDomains = [".simplex.im", ".simplexonflux.com"],
       tbqSize = 1024,
+      maxChats = 5000,
       fileChunkSize = 15780, -- do not change
       xftpDescrPartSize = 14000,
       inlineFiles = defaultInlineFilesConfig,
       autoAcceptFileSize = 0,
+      fileSizeLimits = defaultFileSizeLimits,
       showReactions = False,
       showFullLinks = False,
       showReceipts = False,
@@ -146,11 +152,11 @@ newChatController
   ChatDatabase {chatStore, agentStore}
   user
   cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations}
-  ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, deviceName, webPreviewConfig, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, showFullLinks, allowInstantFiles, autoAcceptFileSize}
+  ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, maxChats, deviceName, webPreviewConfig, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, showFullLinks, allowInstantFiles, autoAcceptFileSize}
   backgroundMode = do
     let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
         confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
-        config = cfg {logLevel, showReactions, showFullLinks, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, webPreviewConfig, highlyAvailable, confirmMigrations = confirmMigrations'}
+        config = cfg {logLevel, showReactions, showFullLinks, tbqSize, maxChats, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, webPreviewConfig, highlyAvailable, confirmMigrations = confirmMigrations'}
     randomPresetServers <- chooseRandomServers presetServers'
     let rndSrvs = L.toList randomPresetServers
         operatorWithId (i, op) = (\o -> o {operatorId = DBEntityId i}) <$> pOperator op
@@ -188,6 +194,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
@@ -234,6 +242,8 @@ newChatController
               deliveryTaskWorkers,
               deliveryJobWorkers,
               relayRequestWorkers,
+              badgeWorkers,
+              badgeSeq,
               relayGroupLinkChecksAsync,
               webPreviewState,
               chatRelayTests,

src/Simplex/Chat/Badges.hs

@@ -25,7 +25,11 @@ module Simplex.Chat.Badges
     BBSPublicKeyStr (..),
     localBadgeInfo,
     localBadgeStatus,
+    FileSizeLimits (..),
+    defaultFileSizeLimits,
     maxXFTPFileSize,
+    maxSndXFTPFileSize,
+    badgeSndGraceInterval,
     badgeServerCredential,
     maxFileSizeSupporter,
     maxFileSizeLegend,
@@ -46,6 +50,10 @@ module Simplex.Chat.Badges
     verifyBadge_,
     mkBadgeStatus,
     BadgeRow,
+    BadgeProofKind (..),
+    BadgeProofRow,
+    badgeProofToRow,
+    rowToBadgeProof,
     badgeToRow,
     localBadgeToRow,
     rowToBadge,
@@ -66,11 +74,13 @@ import Data.String
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, nominalDay)
+import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
 import Simplex.FileTransfer.Description (gb, maxFileSize)
 import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS
 import Simplex.Messaging.Crypto.Entitlement (Entitlement (Entitlement), EntitlementCredential (EntitlementCredential), MasterKey (MasterKey), entitlementBBSHeader)
+import Simplex.Messaging.Encoding (Encoding (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
 #if defined(dbPostgres)
@@ -114,6 +124,35 @@ instance FromJSON BadgeType where
 data BadgeStatus = BSActive | BSExpired | BSExpiredOld | BSFailed | BSUnknownKey
   deriving (Eq, Show)
 
+instance TextEncoding BadgeStatus where
+  textEncode = \case
+    BSActive -> "active"
+    BSExpired -> "expired"
+    BSExpiredOld -> "expired_old"
+    BSFailed -> "failed"
+    BSUnknownKey -> "unknown_key"
+  textDecode = \case
+    "active" -> Just BSActive
+    "expired" -> Just BSExpired
+    "expired_old" -> Just BSExpiredOld
+    "failed" -> Just BSFailed
+    "unknown_key" -> Just BSUnknownKey
+    _ -> Nothing
+
+-- Badge proof kind - a file has at most one proof of each kind
+
+data BadgeProofKind = BPKInvitation | BPKDescription
+  deriving (Eq, Show)
+
+instance TextEncoding BadgeProofKind where
+  textEncode = \case
+    BPKInvitation -> "inv"
+    BPKDescription -> "descr"
+  textDecode = \case
+    "inv" -> Just BPKInvitation
+    "descr" -> Just BPKDescription
+    _ -> Nothing
+
 -- Disclosed badge content (BBS messages 1, 2, 3)
 
 data BadgeInfo = BadgeInfo
@@ -186,10 +225,10 @@ localBadgeStatus = \case
   ShownBadge _ st -> st
 
 -- XFTP file size limit raised by an active badge: a legend badge to 5GB, any other to 2GB, otherwise the default.
-maxFileSizeSupporter :: Int64
+maxFileSizeSupporter :: Integer
 maxFileSizeSupporter = gb 2
 
-maxFileSizeLegend :: Int64
+maxFileSizeLegend :: Integer
 maxFileSizeLegend = gb 5
 
 badgeServerCredential :: Maybe LocalBadge -> Maybe EntitlementCredential
@@ -198,31 +237,62 @@ badgeServerCredential = \case
     Just $ EntitlementCredential (fromIntegral idx) (MasterKey mk) (Entitlement badgeExpiry (textEncode badgeType) badgeExtra) sig
   _ -> Nothing
 
-maxXFTPFileSize :: Maybe LocalBadge -> Int64
-maxXFTPFileSize = \case
-  Just b | localBadgeStatus b == BSActive -> case badgeType (localBadgeInfo b) of
-    BTLegend -> maxFileSizeLegend
-    _ -> maxFileSizeSupporter
-  _ -> maxFileSize
+data FileSizeLimits = FileSizeLimits
+  { noBadge :: Integer,
+    supporter :: Integer,
+    legend :: Integer
+  }
+  deriving (Eq, Show)
+
+defaultFileSizeLimits :: FileSizeLimits
+defaultFileSizeLimits = FileSizeLimits {noBadge = toInteger maxFileSize, supporter = maxFileSizeSupporter, legend = maxFileSizeLegend}
+
+-- a badge raises the size limit at send for this long after its expiry, shorter than badgeGraceInterval so the receiver still accepts the size
+badgeSndGraceInterval :: NominalDiffTime
+badgeSndGraceInterval = nominalDay
+
+badgeFileSize :: FileSizeLimits -> LocalBadge -> Integer
+badgeFileSize FileSizeLimits {supporter, legend} b = case badgeType (localBadgeInfo b) of
+  BTLegend -> legend
+  _ -> supporter
+
+maxXFTPFileSize :: FileSizeLimits -> Maybe LocalBadge -> Integer
+maxXFTPFileSize lims = \case
+  Just b | localBadgeStatus b == BSActive -> badgeFileSize lims b
+  _ -> noBadge lims
+
+maxSndXFTPFileSize :: FileSizeLimits -> UTCTime -> Maybe LocalBadge -> Integer
+maxSndXFTPFileSize lims now = \case
+  Just b | localBadgeStatus b == BSActive && addUTCTime badgeSndGraceInterval (badgeExpiry (localBadgeInfo b)) >= now -> badgeFileSize lims b
+  _ -> noBadge lims
 
 -- Presentation header: a tag char + payload. PHTest is unbound - a fresh random nonce per
 -- presentation, not bound to any context; the 'T' tag marks it so master rejects it.
 -- PHUnknown is the forward-compat catch-all for tags this version does not interpret.
 
-data ProofPresHeaderTag = PHTestTag | PHUnknownTag Char
+data ProofPresHeaderTag = PHTestTag | PHChatTag | PHFileInvTag | PHFileDescrTag | PHUnknownTag Char
 
 instance StrEncoding ProofPresHeaderTag where
   strEncode = B.singleton . \case
     PHTestTag -> 'T'
+    PHChatTag -> 'C'
+    PHFileInvTag -> 'F'
+    PHFileDescrTag -> 'D'
     PHUnknownTag c -> c
   strP = tag <$> A.anyChar
     where
       tag = \case
         'T' -> PHTestTag
+        'C' -> PHChatTag
+        'F' -> PHFileInvTag
+        'D' -> PHFileDescrTag
         c -> PHUnknownTag c
 
 data ProofPresHeader
   = PHTest ByteString
+  | PHChat ByteString
+  | PHFileInv {chatBinding :: ByteString, fileSize :: Int64}
+  | PHFileDescr {chatBinding :: ByteString, fileSize :: Int64, descrHash :: ByteString, fileExpires :: Maybe UTCTime}
   | PHUnknown Char ByteString
   deriving (Eq, Show)
   deriving (ToJSON, FromJSON) via (StrJSON "ProofPresHeader" ProofPresHeader)
@@ -230,16 +300,31 @@ data ProofPresHeader
 instance StrEncoding ProofPresHeader where
   strEncode = \case
     PHTest nonce -> strEncode PHTestTag <> nonce
+    PHChat binding -> strEncode PHChatTag <> binding
+    PHFileInv {chatBinding, fileSize} ->
+      strEncode PHFileInvTag <> smpEncode (chatBinding, fileSize)
+    PHFileDescr {chatBinding, fileSize, descrHash, fileExpires} ->
+      strEncode PHFileDescrTag <> smpEncode (chatBinding, fileSize, descrHash, utcToSystemTime <$> fileExpires)
     PHUnknown c b -> strEncode (PHUnknownTag c) <> b
   strP =
     strP >>= \case
       PHTestTag -> PHTest <$> A.takeByteString
+      PHChatTag -> PHChat <$> A.takeByteString
+      PHFileInvTag -> do
+        (chatBinding, fileSize) <- smpP
+        pure PHFileInv {chatBinding, fileSize}
+      PHFileDescrTag -> do
+        (chatBinding, fileSize, descrHash, expires_) <- smpP
+        pure PHFileDescr {chatBinding, fileSize, descrHash, fileExpires = systemToUTCTime <$> expires_}
       PHUnknownTag c -> PHUnknown c <$> A.takeByteString
 
 -- v6.5.x accepts both; v7 will reject PHTest/PHUnknown
 proofPresHeaderAccepted :: ProofPresHeader -> Bool
 proofPresHeaderAccepted = \case
   PHTest _ -> True
+  PHChat _ -> True
+  PHFileInv {} -> True
+  PHFileDescr {} -> True
   PHUnknown _ _ -> True
 
 -- Payment proof
@@ -348,6 +433,26 @@ instance FromField BadgeType where fromField = fromTextField_ textDecode
 
 instance ToField BadgeType where toField = toField . textEncode
 
+instance FromField BadgeStatus where fromField = fromTextField_ textDecode
+
+instance ToField BadgeStatus where toField = toField . textEncode
+
+instance FromField BadgeProofKind where fromField = fromTextField_ textDecode
+
+instance ToField BadgeProofKind where toField = toField . textEncode
+
+-- (proof, pres_header, key_idx, type, expiry, extra) - the fields of BadgeProof as stored in file_badge_proofs
+type BadgeProofRow = (Binary ByteString, Binary ByteString, Int, Text, UTCTime, Text)
+
+badgeProofToRow :: BadgeProof -> BadgeProofRow
+badgeProofToRow (BadgeProof idx (BBSPresHeader ph) (BBSProof p) BadgeInfo {badgeType, badgeExpiry, badgeExtra}) =
+  (Binary p, Binary ph, idx, textEncode badgeType, badgeExpiry, badgeExtra)
+
+rowToBadgeProof :: BadgeProofRow -> Maybe BadgeProof
+rowToBadgeProof (Binary p, Binary ph, idx, type_, badgeExpiry, badgeExtra) = do
+  badgeType <- textDecode type_
+  pure $ BadgeProof idx (BBSPresHeader ph) (BBSProof p) BadgeInfo {badgeType, badgeExpiry, badgeExtra}
+
 -- (proof, pres_header, expiry, type, verified, extra, master_key, signature, key_idx) - binary columns wrapped in Binary (BLOB/bytea)
 type BadgeRow = (Maybe (Binary ByteString), Maybe (Binary ByteString), Maybe UTCTime, Maybe Text, Maybe BoolInt, Maybe Text, Maybe (Binary ByteString), Maybe (Binary ByteString), Maybe Int)
 

src/Simplex/Chat/Badges/Code.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Badge redemption codes, shared by the client, the badge service and the checkout site.
+--
+-- A code is "SB-" 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'.
+--
+-- 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
+-- and every transposition of adjacent characters except '0' next to 'Z' - the values 0 and
+-- N-1, which is Luhn's one blind spot at any base.
+--
+-- 'BadgeCode' is only constructed by 'parseBadgeCode' and 'randomBadgeCode', so a code
+-- whose check character fails cannot be hashed, looked up or sent.
+module Simplex.Chat.Badges.Code
+  ( BadgeCode,
+    parseBadgeCode,
+    randomBadgeCode,
+    badgeCodeText,
+    badgeCodeHash,
+    formatBadgeCode,
+  )
+where
+
+import Control.Concurrent.STM
+import Crypto.Random (ChaChaDRG)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Char (isAlphaNum, toUpper)
+import Data.List (elemIndex)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import qualified Simplex.Messaging.Crypto as C
+
+-- | A code that has passed its check character, in canonical form: 'codePrefix' followed by
+-- 20 upper-case alphabet characters, without separators.
+newtype BadgeCode = BadgeCode Text
+  deriving (Eq, Show)
+
+-- Crockford base32: the digits and the upper-case letters except I, L, O and U.
+alphabet :: String
+alphabet = "0123456789ABCDEFGHJKMNPQRSTVWXYZ"
+
+base :: Int
+base = 32
+
+codeLength :: Int
+codeLength = 20
+
+groupLength :: Int
+groupLength = 5
+
+codePrefix :: Text
+codePrefix = "SB"
+
+-- | The Crockford value of a character, folding the omitted characters onto the digits they
+-- are mistaken for.
+charValue :: Char -> Maybe Int
+charValue c = case toUpper c of
+  'I' -> Just 1
+  'L' -> Just 1
+  'O' -> Just 0
+  u -> elemIndex u alphabet
+
+valueChar :: Int -> Char
+valueChar v = alphabet !! v
+
+-- | Luhn mod N (N = 32): the value that makes the whole code sum to zero modulo the base.
+checkValue :: [Int] -> Int
+checkValue payload = (base - total `mod` base) `mod` base
+  where
+    -- doubling every second value from the right, as the check character sits to the right of the payload
+    total = fst $ foldr step (0, 2) payload
+    step v (sum', factor) =
+      let addend = factor * v
+       in (sum' + addend `div` base + addend `mod` base, if factor == 2 then 1 else 2)
+
+-- | Read a code as typed: any case, separators optional, ambiguous characters folded.
+-- 'Nothing' for anything not well-formed, a failed check character included.
+parseBadgeCode :: Text -> Maybe BadgeCode
+parseBadgeCode t = do
+  body <- T.stripPrefix codePrefix $ T.toUpper $ T.filter isAlphaNum t
+  vs <- mapM charValue $ T.unpack body
+  let (payload, checkChar) = splitAt (codeLength - 1) vs
+  if T.length body == codeLength && checkChar == [checkValue payload]
+    -- rebuilt from the values, not from body: that is what folds I/L/O into the canonical form
+    then Just $ BadgeCode $ codePrefix <> T.pack (map valueChar vs)
+    else Nothing
+
+-- | A new code from the CSPRNG. 256 is a multiple of the base, so a byte reduces without bias.
+randomBadgeCode :: TVar ChaChaDRG -> IO BadgeCode
+randomBadgeCode drg = do
+  bs <- atomically $ C.randomBytes (codeLength - 1) drg
+  let payload = map ((`mod` base) . fromEnum) $ B.unpack bs
+      vs = payload <> [checkValue payload]
+  pure $ BadgeCode $ codePrefix <> T.pack (map valueChar vs)
+
+-- | The canonical form: the only representation of a code that is hashed or sent.
+badgeCodeText :: BadgeCode -> Text
+badgeCodeText (BadgeCode t) = t
+
+-- | The only thing about a code stored service-side: SHA-256 over the ASCII bytes of the
+-- canonical form, prefix included.
+badgeCodeHash :: BadgeCode -> ByteString
+badgeCodeHash = C.sha256Hash . encodeUtf8 . badgeCodeText
+
+-- | The code as it is shown and printed, in four groups of five.
+formatBadgeCode :: BadgeCode -> Text
+formatBadgeCode (BadgeCode t) = T.intercalate "-" $ codePrefix : groups (T.drop (T.length codePrefix) t)
+  where
+    groups s
+      | T.null s = []
+      | otherwise = let (g, rest) = T.splitAt groupLength s in g : groups rest

src/Simplex/Chat/Badges/Ledger.hs

@@ -0,0 +1,240 @@
+{-# 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.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Time.Calendar (addDays, addGregorianMonthsClip, toGregorian)
+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 (..))
+
+-- The calendar difference overshoots by at most one month, so one comparison settles it.
+monthsBetween :: UTCTime -> UTCTime -> Integer
+monthsBetween from to
+  | addMonths months from <= to = max 0 months
+  | otherwise = max 0 (months - 1)
+  where
+    (fy, fm, _) = toGregorian (utctDay from)
+    (ty, tm, _) = toGregorian (utctDay to)
+    months = (ty - fy) * 12 + toInteger (tm - fm)
+
+monthsFromAnchor :: StatementEntry -> Integer
+monthsFromAnchor e = monthsBetween (balanceAnchorTs e) (balanceStartTs e)
+
+-- | 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)
+
+-- Counted from the anchor: 31 Jan plus a month clips to 28 Feb, and counting on from there would
+-- retire the next month three days early.
+elapsedMonths :: UTCTime -> StatementEntry -> Int
+elapsedMonths t e = fromInteger $ max 0 $ min (toInteger $ balanceMonths e) elapsed
+  where
+    elapsed = monthsBetween (balanceAnchorTs e) t - monthsFromAnchor 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
+          }
+
+-- Generous because postdating only writes off a month by crossing a month boundary, which takes
+-- days, while a device clock a few minutes slow would otherwise leave every row unverified.
+maxCreatedAtSkew :: NominalDiffTime
+maxCreatedAtSkew = 60 * 60
+
+-- | Each entry is checked by re-running the operation it claims: checking only that its numbers
+-- follow from the previous entry would pass a lapse of three months where one elapsed. So 'True'
+-- means the service ran these functions, not that it ran the right one. 'Nothing' is "not re-run":
+-- no operation rebuilds that type, or its timestamp is not credible.
+balanceChecked :: UTCTime -> BadgeType -> Maybe StatementEntry -> [StatementEntry] -> [(StatementEntry, Maybe Bool)]
+balanceChecked _ _ _ [] = []
+balanceChecked now badgeType tip entries@(first : _) = zipWith withVerdict (opening : entries) entries
+  where
+    -- the purchase's own type, not the statement's: on the seed path nothing else contradicts it
+    opening = fromMaybe (emptyEntry (createdAt first) badgeType) tip
+    withVerdict prev e = (e, entryChecked now badgeType prev e)
+
+entryChecked :: UTCTime -> BadgeType -> StatementEntry -> StatementEntry -> Maybe Bool
+entryChecked now badgeType prev e
+  -- the recompute runs on createdAt, so a stamp our own clock contradicts makes every verdict
+  -- below meaningless - which is not the same as the row being wrong, and is not marked as it
+  | postdated = Nothing
+  | backdated = Just False
+  | otherwise = case entryType e of
+      SEDebit SDLapse -> maybe (Just False) matches $ lapseEntry t "" prev
+      SEDebit SDBadge -> maybe (Just False) matches $ issueEntry t "" prev
+      SEDebit SDRefund -> uncontradicted
+      SEDebit SDUpgrade {} -> uncontradicted
+      SEDebit SDTransferOut {} -> uncontradicted
+      SEDebit SDSupport -> uncontradicted
+      SEDebit SDUnknown {} -> uncontradicted
+      -- an opening credit resets the ledger to the amount it states, with no relation to the entry
+      -- before it (badges-rpc.md), so it is checked against nothing but itself
+      SECredit SCOpening -> Just restated
+      SECredit SCUnknown {} -> uncontradicted
+      SECredit c
+        -- grantEntry is given the row's month count, so the check agrees with whatever it claims -
+        -- including a negative count, which shortens what the user paid for.
+        -- TODO [badges] a purchase made in the app knows the months it bought; check them here.
+        | changeMonths e < 0 -> Just False
+        | otherwise -> matches $ grantEntry t "" (changeMonths e) c prev
+  where
+    t = createdAt e
+    postdated = t > addUTCTime maxCreatedAtSkew now
+    -- two of the service's own stamps, so no allowance and no doubt about whose clock is wrong.
+    -- Equal is not behind: a service pass writes its lapse and its issue with one clock reading
+    backdated = t < createdAt prev
+    matches = Just . sameBalance e
+    restated = balanceMonths e == changeMonths e && balanceMonths e >= 0 && balanceBadgeType e == badgeType
+    uncontradicted
+      | balanceMonths e /= balanceMonths prev + changeMonths e = Just False
+      | balanceMonths e < 0 = Just False
+      | balanceStartTs e < balanceStartTs prev = Just False
+      | otherwise = Nothing
+
+sameBalance :: StatementEntry -> StatementEntry -> Bool
+sameBalance a b =
+  balanceMonths a == balanceMonths b
+    && balanceStartTs a == balanceStartTs b
+    && balanceAnchorTs a == balanceAnchorTs b
+    && balanceBadgeType a == balanceBadgeType b
+    && changeMonths a == changeMonths b
+
+-- | 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

@@ -0,0 +1,328 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.Badges.Service
+  ( BadgeServiceRequest (..),
+    BadgeServiceCommand (..),
+    BadgeServiceVersion,
+    VersionBadgeService,
+    VersionRangeBadgeService,
+    pattern VersionBadgeService,
+    initialBadgeServiceVersion,
+    currentBadgeServiceVersion,
+    supportedBadgeServiceVRange,
+    BadgeUpgrade (..),
+    BadgeServiceResponse (..),
+    BadgeServiceErrorCode (..),
+    BadgeCatalog (..),
+    BadgePrice (..),
+    BadgeOffer (..),
+    BadgeStatement (..),
+    BadgeBalance (..),
+    StatementEntry (..),
+    StatementEntryType (..),
+    StatementCreditType (..),
+    StatementDebitType (..),
+  ) where
+
+import Control.Applicative ((<|>))
+import Data.Aeson (FromJSON (..), ToJSON (..), (.:))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Encoding as JE
+import qualified Data.Aeson.TH as JQ
+import qualified Data.Aeson.Types as JT
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Data.Word (Word8, Word16, Word32)
+import Simplex.Chat.Badges
+import Simplex.Chat.Badges.Types
+import Simplex.Chat.PaymentService
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
+import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
+import Simplex.Messaging.Version.Internal (Version (..))
+
+data BadgeServiceVersion
+
+instance VersionScope BadgeServiceVersion
+
+type VersionBadgeService = Version BadgeServiceVersion
+
+pattern VersionBadgeService :: Word16 -> VersionBadgeService
+pattern VersionBadgeService v = Version v
+
+type VersionRangeBadgeService = VersionRange BadgeServiceVersion
+
+initialBadgeServiceVersion :: VersionBadgeService
+initialBadgeServiceVersion = VersionBadgeService 1
+
+currentBadgeServiceVersion :: VersionBadgeService
+currentBadgeServiceVersion = VersionBadgeService 1
+
+-- the service is deployed ahead of app releases, so it answers within the client's version
+supportedBadgeServiceVRange :: VersionRangeBadgeService
+supportedBadgeServiceVRange = mkVersionRange initialBadgeServiceVersion currentBadgeServiceVersion
+
+data BadgeServiceRequest = BadgeServiceRequest
+  { version :: VersionBadgeService,
+    purchaseKey :: Maybe C.PublicKeyEd25519, -- optional for BSCGetBadgeCatalog, required for other commands
+    request :: BadgeServiceCommand
+  }
+
+data BadgeServiceCommand
+  = BSCGetBadgeCatalog
+  | BSCGetBadgeInvoice
+      { priceId :: BadgePriceId,
+        offerId :: Maybe BadgeOfferId, -- absent for 1 month at the badge price
+        badgeInfo :: BadgeInfo,
+        paymentVia :: ServicePaymentMethod,
+        upgrade :: Maybe BadgeUpgrade -- upgrade non-store badge
+      }
+  | BSCRedeemBadgeCode
+      { masterKey :: BadgeMasterKey,
+        code :: Text -- no badgeRequest: a code carries no tier for the client to state
+      }
+  | BSCPurchaseBadge
+      { badgeRequest :: BadgeRequest,
+        payment :: ServicePayment,
+        upgrade :: Maybe BadgeUpgrade -- upgrade store 1-time badge
+      }
+  | BSCUpgradeBadgeSubscription
+      { badgeRequest :: BadgeRequest,
+        payment :: ServicePayment, -- store payments only
+        balance :: BadgeBalance
+      }
+  | BSCIssueBadge
+      { balance :: BadgeBalance -- no badgeRequest: the service holds the key, the tier and the expiry
+      }
+  | BSCPauseBadge
+
+data BadgeUpgrade = BadgeUpgrade
+  { fromPurchaseKey :: C.PublicKeyEd25519,
+    receipt :: Text,
+    receiptSignature :: C.Signature 'C.Ed25519,
+    balance :: BadgeBalance
+  }
+
+data BadgeServiceResponse
+  = BSPBadgeCatalog
+      { catalog :: BadgeCatalog,
+        badgeStatement :: Maybe BadgeStatement -- for signed getBadgeCatalog
+      }
+  | BSPBadgeInvoice
+      { invoice :: ServiceInvoice,
+        badgeType :: BadgeType,
+        months :: Word8
+      }
+  | BSPBadgeCredential
+      { credential :: Maybe BadgeCredential, -- Nothing when no balance to issueBadge or no current credential for pause
+        receipt :: Maybe Text, -- not provided for lifetime badges
+        statement :: BadgeStatement
+      }
+  | BSPError
+      { code :: BadgeServiceErrorCode,
+        message :: Maybe Text,
+        retryAfter :: Maybe Word32
+      }
+
+data BadgeCatalog = BadgeCatalog
+  { prices :: [BadgePrice],
+    offers :: [BadgeOffer]
+  }
+  deriving (Show)
+
+data BadgePrice = BadgePrice
+  { priceId :: BadgePriceId,
+    badgeType :: BadgeType,
+    monthPrice :: CurrencyAmount,
+    currency :: Text,
+    status :: BadgeItemStatus,
+    createdAt :: UTCTime
+  }
+  deriving (Show)
+
+data BadgeOffer = BadgeOffer
+  { offerId :: BadgeOfferId,
+    priceId :: Maybe BadgePriceId, -- absent applies to any price
+    months :: Word8,
+    discount :: OfferDiscount,
+    status :: BadgeItemStatus,
+    createdAt :: UTCTime
+  }
+  deriving (Show)
+
+data BadgeStatement = BadgeStatement
+  { entries :: [StatementEntry],
+    previousEntryId :: Maybe Text -- matches the client's asserted entryId, absent for the full ledger
+  }
+  deriving (Show)
+
+data BadgeBalance = BadgeBalance
+  { lastEntry :: StatementEntry
+  }
+  deriving (Show)
+
+data StatementEntry = StatementEntry
+  { entryId :: Text,
+    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,
+    entryType :: StatementEntryType
+  }
+  deriving (Show)
+
+data StatementEntryType = SECredit {credit :: StatementCreditType} | SEDebit {debit :: StatementDebitType}
+  deriving (Show)
+
+data StatementCreditType
+  = 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}
+  | SCOpening
+  | SCUnknown {tag :: Text, json :: J.Object}
+  deriving (Show)
+
+data StatementDebitType
+  = SDRefund
+  | SDUpgrade {toPurchaseKey :: C.PublicKeyEd25519}
+  | SDTransferOut {toPurchaseKey :: C.PublicKeyEd25519}
+  | SDSupport
+  | SDBadge
+  | SDLapse
+  | SDUnknown {tag :: Text, json :: J.Object}
+  deriving (Show)
+
+data BadgeServiceErrorCode
+  = BSEBadRequest
+  | BSEUnsupportedVersion
+  | BSEUnknownPurchaseKey
+  | BSEUnknownOfferId
+  | BSEOfferDisabled
+  | BSEOfferMismatch
+  | BSEProductUnavailable
+  | BSEPaymentNotEntitled
+  | BSEPaymentPending
+  | BSEProviderUnavailable
+  | BSERateLimited
+  | BSECodeInvalid
+  | BSECodeUsed
+  | BSECodeExpired
+  | BSEReceiptInvalid
+  | BSEReceiptUsed
+  | BSEInternal
+  | BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients
+  deriving (Eq, Show)
+
+instance TextEncoding BadgeServiceErrorCode where
+  textEncode = \case
+    BSEBadRequest -> "bad_request"
+    BSEUnsupportedVersion -> "unsupported_version"
+    BSEUnknownPurchaseKey -> "unknown_purchase_key"
+    BSEUnknownOfferId -> "unknown_offer_id"
+    BSEOfferDisabled -> "offer_disabled"
+    BSEOfferMismatch -> "offer_mismatch"
+    BSEProductUnavailable -> "product_unavailable"
+    BSEPaymentNotEntitled -> "payment_not_entitled"
+    BSEPaymentPending -> "payment_pending"
+    BSEProviderUnavailable -> "provider_unavailable"
+    BSERateLimited -> "rate_limited"
+    BSECodeInvalid -> "code_invalid"
+    BSECodeUsed -> "code_used"
+    BSECodeExpired -> "code_expired"
+    BSEReceiptInvalid -> "receipt_invalid"
+    BSEReceiptUsed -> "receipt_used"
+    BSEInternal -> "internal"
+    BSEUnknown t -> t
+  textDecode s = Just $ case s of
+    "bad_request" -> BSEBadRequest
+    "unsupported_version" -> BSEUnsupportedVersion
+    "unknown_purchase_key" -> BSEUnknownPurchaseKey
+    "unknown_offer_id" -> BSEUnknownOfferId
+    "offer_disabled" -> BSEOfferDisabled
+    "offer_mismatch" -> BSEOfferMismatch
+    "product_unavailable" -> BSEProductUnavailable
+    "payment_not_entitled" -> BSEPaymentNotEntitled
+    "payment_pending" -> BSEPaymentPending
+    "provider_unavailable" -> BSEProviderUnavailable
+    "rate_limited" -> BSERateLimited
+    "code_invalid" -> BSECodeInvalid
+    "code_used" -> BSECodeUsed
+    "code_expired" -> BSECodeExpired
+    "receipt_invalid" -> BSEReceiptInvalid
+    "receipt_used" -> BSEReceiptUsed
+    "internal" -> BSEInternal
+    t -> BSEUnknown t
+
+instance ToJSON BadgeServiceErrorCode where
+  toJSON = textToJSON
+  toEncoding = textToEncoding
+
+instance FromJSON BadgeServiceErrorCode where
+  parseJSON = textParseJSON "BadgeServiceErrorCode"
+
+$(pure [])
+
+instance FromJSON StatementCreditType where
+  parseJSON v@(J.Object j) =
+    $(JQ.mkParseJSON (taggedObjectJSON $ dropPrefix "SC") ''StatementCreditType) v
+      <|> SCUnknown <$> j .: "type" <*> pure j
+  parseJSON invalid =
+    JT.prependFailure "bad StatementCreditType, " (JT.typeMismatch "Object" invalid)
+
+instance ToJSON StatementCreditType where
+  toJSON = \case
+    SCUnknown _ j -> J.Object j
+    v -> $(JQ.mkToJSON (taggedObjectJSON $ dropPrefix "SC") ''StatementCreditType) v
+  toEncoding = \case
+    SCUnknown _ j -> JE.value $ J.Object j
+    v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "SC") ''StatementCreditType) v
+
+instance FromJSON StatementDebitType where
+  parseJSON v@(J.Object j) =
+    $(JQ.mkParseJSON (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v
+      <|> SDUnknown <$> j .: "type" <*> pure j
+  parseJSON invalid =
+    JT.prependFailure "bad StatementDebitType, " (JT.typeMismatch "Object" invalid)
+
+instance ToJSON StatementDebitType where
+  toJSON = \case
+    SDUnknown _ j -> J.Object j
+    v -> $(JQ.mkToJSON (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v
+  toEncoding = \case
+    SDUnknown _ j -> JE.value $ J.Object j
+    v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SE") ''StatementEntryType)
+
+$(JQ.deriveJSON defaultJSON ''StatementEntry)
+
+$(JQ.deriveJSON defaultJSON ''BadgeStatement)
+
+$(JQ.deriveJSON defaultJSON ''BadgeBalance)
+
+$(JQ.deriveJSON defaultJSON ''BadgeUpgrade)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "BSC") ''BadgeServiceCommand)
+
+$(JQ.deriveJSON defaultJSON ''BadgeServiceRequest)
+
+$(JQ.deriveJSON defaultJSON ''BadgePrice)
+
+$(JQ.deriveJSON defaultJSON ''BadgeOffer)
+
+$(JQ.deriveJSON defaultJSON ''BadgeCatalog)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "BSP") ''BadgeServiceResponse)

src/Simplex/Chat/Badges/Types.hs

@@ -0,0 +1,276 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.Badges.Types
+  ( BadgePriceId (..),
+    BadgeOfferId (..),
+    BadgePlan (..),
+    BadgeItemStatus (..),
+    OfferDiscount (..),
+    BadgePurchaseStatus (..),
+    BadgeCodePaymentStatus (..),
+    LedgerEntryType (..),
+    LedgerCreditType (..),
+    LedgerDebitType (..),
+    BadgeAlertKind (..),
+    BadgeFunding (..),
+    BadgePurchase (..),
+    BadgeLedgerEntry (..),
+    BadgeCharge (..),
+    BadgeIssuance (..),
+    BadgeAlert (..),
+    BadgeAlertPrice (..),
+    BadgeState (..),
+  ) where
+
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
+import Data.Int (Int64)
+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, PaymentId, StoredPayment)
+import Simplex.Chat.Types (BoolDef (..))
+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 (defaultJSON, 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
+
+-- confirmed
+newtype BadgePriceId = BadgePriceId Text
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
+
+-- confirmed
+newtype BadgeOfferId = BadgeOfferId Text
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
+
+-- unconfirmed draft
+data BadgePlan = BPOneTime | BPMonthly | BPAnnual
+  deriving (Eq, Show)
+
+-- confirmed
+data BadgeItemStatus = BISActive | BISDeprecated | BISDisabled -- disabled is not sent
+  deriving (Eq, Show)
+
+-- confirmed
+data OfferDiscount
+  = ODFreeMonths {freeMonths :: Word8}
+  | ODDiscount {discount :: Word8} -- percent
+  deriving (Eq, Show)
+
+-- unconfirmed draft
+data BadgePurchaseStatus = PSAcquiring | PSIssued | PSSuperseded | PSFailed
+  deriving (Eq, Show)
+
+-- unconfirmed draft
+data BadgeCodePaymentStatus = CPSPaid | CPSUnpaid | CPSFree
+  deriving (Eq, Show)
+
+-- confirmed
+data LedgerEntryType = LECredit {credit :: LedgerCreditType} | LEDebit {debit :: LedgerDebitType}
+  deriving (Eq, Show)
+
+-- confirmed
+data LedgerCreditType
+  = CTPayment {invoiceId :: InvoiceId}
+  | CTCode
+  | CTCharge {chargeId :: Text}
+  | CTSupport
+  | CTTransferIn {fromPurchaseId :: Maybe Int64}
+  | CTOpening
+  | CTUnknown {tag :: Text, json :: J.Object}
+  deriving (Eq, Show)
+
+-- confirmed
+data LedgerDebitType
+  = DTRefund
+  | DTUpgrade {toPurchaseId :: Int64}
+  | DTTransferOut {toPurchaseId :: Int64}
+  | DTSupport
+  | DTBadge
+  | DTLapse
+  | DTUnknown {tag :: Text, json :: J.Object}
+  deriving (Eq, Show)
+
+-- unconfirmed draft
+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,
+    userId :: UserId,
+    purchaseKey :: C.PublicKeyEd25519,
+    purchasePrivKey :: C.PrivateKeyEd25519,
+    masterKey :: BadgeMasterKey,
+    badgeType :: BadgeType,
+    priceId :: Maybe BadgePriceId,
+    offerId :: Maybe BadgeOfferId,
+    funding :: BadgeFunding,
+    status :: BadgePurchaseStatus,
+    credential :: Maybe BadgeCredential,
+    alertAcked :: Maybe (BadgeAlertKind, Text),
+    alertSnoozeUntil :: Maybe UTCTime,
+    createdAt :: UTCTime,
+    updatedAt :: UTCTime
+  }
+
+-- confirmed
+data BadgeLedgerEntry = BadgeLedgerEntry
+  { entryId :: Int64,
+    entryUuid :: Text,
+    badgePurchaseId :: Int64,
+    changeMonths :: Int,
+    balanceMonths :: Int,
+    balanceStartTs :: UTCTime,
+    balanceAnchorTs :: UTCTime,
+    balanceBadgeType :: BadgeType,
+    wasPausedSince :: Maybe UTCTime,
+    serviceCreatedAt :: UTCTime,
+    createdAt :: UTCTime,
+    entryType :: LedgerEntryType
+  }
+  deriving (Show)
+
+-- unconfirmed draft
+data BadgeCharge = BadgeCharge
+  { chargeId :: Int64,
+    paymentId :: Int64,
+    invoiceUuid :: InvoiceId,
+    providerChargeRef :: Text,
+    periodStart :: UTCTime,
+    periodEnd :: UTCTime,
+    amount :: Int64,
+    currency :: Text,
+    chargedAt :: UTCTime
+  }
+  deriving (Show)
+
+-- every issuance covers one month and is written beside exactly one debit(badge) row
+data BadgeIssuance = BadgeIssuance
+  { issuanceId :: Text,
+    badgePurchaseId :: Int64,
+    badgeType :: BadgeType,
+    periodStart :: UTCTime,
+    periodEnd :: UTCTime,
+    expiry :: UTCTime,
+    entryId :: Int64,
+    credential :: BadgeCredential,
+    createdAt :: UTCTime
+  }
+  deriving (Show)
+
+-- unconfirmed draft
+data BadgeAlert = BadgeAlert
+  { kind :: BadgeAlertKind,
+    episode :: Text,
+    date :: UTCTime,
+    price :: Maybe BadgeAlertPrice
+  }
+  deriving (Show)
+
+data BadgeAlertPrice = BadgeAlertPrice
+  { amount :: Int64,
+    currency :: Text
+  }
+  deriving (Show)
+
+-- | The user's badge as the badge surfaces render it. The private purchase key is deliberately
+-- absent: this travels to the UI and over remote control, and it is a secret that stays in core.
+data BadgeState = BadgeState
+  { badgePurchaseId :: Int64,
+    purchaseKey :: C.PublicKeyEd25519, -- the purchase's identifier on the service
+    badgeType :: BadgeType,
+    shown :: BoolDef,
+    monthsLeft :: Int,
+    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
+    PSAcquiring -> "acquiring"
+    PSIssued -> "issued"
+    PSSuperseded -> "superseded"
+    PSFailed -> "failed"
+  textDecode = \case
+    "acquiring" -> Just PSAcquiring
+    "issued" -> Just PSIssued
+    "superseded" -> Just PSSuperseded
+    "failed" -> Just PSFailed
+    _ -> Nothing
+
+instance FromField BadgePurchaseStatus where fromField = fromTextField_ textDecode
+
+instance ToField BadgePurchaseStatus where toField = toField . textEncode
+
+instance TextEncoding BadgeCodePaymentStatus where
+  textEncode = \case
+    CPSPaid -> "paid"
+    CPSUnpaid -> "unpaid"
+    CPSFree -> "free"
+  textDecode = \case
+    "paid" -> Just CPSPaid
+    "unpaid" -> Just CPSUnpaid
+    "free" -> Just CPSFree
+    _ -> Nothing
+
+instance FromField BadgeCodePaymentStatus where fromField = fromTextField_ textDecode
+
+instance ToField BadgeCodePaymentStatus where toField = toField . textEncode
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "BIS") ''BadgeItemStatus)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "OD") ''OfferDiscount)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "BA") ''BadgeAlertKind)
+
+$(JQ.deriveJSON defaultJSON ''BadgeAlertPrice)
+
+$(JQ.deriveJSON defaultJSON ''BadgeAlert)
+
+$(JQ.deriveJSON defaultJSON ''BadgeState)

src/Simplex/Chat/Bot.hs

@@ -47,16 +47,17 @@ chatBotRepl welcome answer _user cc = do
     contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
 
 initializeBotAddress :: ChatController -> IO ()
-initializeBotAddress = initializeBotAddress' True
+initializeBotAddress = initializeBotAddress' True Nothing True
 
-initializeBotAddress' :: Bool -> ChatController -> IO ()
-initializeBotAddress' logAddress cc = do
+-- pqRatchet_ selects the address type when creating: Just True (IKUsePQ) is required for service RPC, Nothing is the legacy non-DR contact address.
+initializeBotAddress' :: Bool -> Maybe Bool -> Bool -> ChatController -> IO ()
+initializeBotAddress' logAddress pqRatchet_ doAutoAccept cc = do
   sendChatCmd cc ShowMyAddress >>= \case
     Right (CRUserContactLink _ UserContactLink {connLinkContact}) -> showBotAddress connLinkContact
     Left (ChatErrorStore SEUserContactLinkNotFound) -> do
       when logAddress $ putStrLn "No bot address, creating..."
       -- TODO [short links] create short link by default
-      sendChatCmd cc (CreateMyAddress Nothing) >>= \case
+      sendChatCmd cc (CreateMyAddress pqRatchet_) >>= \case
         Right (CRUserContactLinkCreated _ ccLink) -> showBotAddress ccLink
         _ -> putStrLn "can't create bot address" >> exitFailure
     _ -> putStrLn "unexpected response" >> exitFailure
@@ -65,7 +66,8 @@ initializeBotAddress' logAddress cc = do
       when logAddress $ do
         putStrLn $ "Bot's contact address is: " <> B.unpack (maybe (strEncode uri) strEncode shortUri)
         when (isJust shortUri) $ putStrLn $ "Full contact address for old clients: " <> B.unpack (strEncode uri)
-      let settings = AddressSettings {businessAddress = False, autoAccept = Just AutoAccept {acceptIncognito = False}, autoReply = Nothing}
+      let aa = if doAutoAccept then Just AutoAccept {acceptIncognito = False} else Nothing
+          settings = AddressSettings {businessAddress = False, autoAccept = aa, autoReply = Nothing}
       void $ sendChatCmd cc $ SetAddressSettings Nothing settings
 
 sendMessage :: ChatController -> Contact -> Text -> IO ()

src/Simplex/Chat/Bot/Store.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Simplex.Chat.Bot.Store
+  ( withDB,
+    withDB',
+  )
+where
+
+import Control.Logger.Simple
+import Control.Monad.Except
+import Data.Text (Text)
+import qualified Data.Text as T
+import Simplex.Chat.Controller
+import Simplex.Chat.Types
+import Simplex.Messaging.Agent.Store.Common (withTransaction)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import Simplex.Messaging.Util (catchAll)
+
+withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Either String a)
+withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a
+
+withDB :: Text -> ChatController -> (DB.Connection -> ExceptT String IO a) -> IO (Either String a)
+withDB cxt ChatController {chatStore} action = do
+  r_ <- withTransaction chatStore (runExceptT . action) `catchAll` (pure . Left . show)
+  case r_ of
+    Left e -> logError $ "Database error: " <> cxt <> " " <> T.pack e
+    Right _ -> pure ()
+  pure r_

src/Simplex/Chat/Controller.hs

@@ -84,7 +84,9 @@ import Simplex.Messaging.Agent.Store.DB (SQLError)
 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)
+import Simplex.Chat.Badges (BadgeCredential, FileSizeLimits, LocalBadge)
+import Simplex.Chat.Badges.Service (BadgeServiceErrorCode, StatementEntry)
+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
@@ -93,10 +95,11 @@ 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)
-import Simplex.Messaging.Util (AnyError (..), catchAllErrors, (<$$>))
+import Simplex.Messaging.Util (AnyError (..), catchAllErrors, catchOwn', (<$$>))
 import Simplex.RemoteControl.Client
 import Simplex.RemoteControl.Invitation (RCSignedInvitation, RCVerifiedInvitation)
 import Simplex.RemoteControl.Types
@@ -144,15 +147,23 @@ data ChatConfig = ChatConfig
     chatVRange :: VersionRangeChat,
     -- issuer public keys by index: credentials and proofs name the key that signed them, for rotation
     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,
     presetDomains :: [HostName],
     tbqSize :: Natural,
+    maxChats :: Int,
     fileChunkSize :: Integer,
     xftpDescrPartSize :: Int,
     inlineFiles :: InlineFilesConfig,
     autoAcceptFileSize :: Integer,
+    fileSizeLimits :: FileSizeLimits,
     showReactions :: Bool,
     showFullLinks :: Bool,
     showReceipts :: Bool,
@@ -218,9 +229,9 @@ newWebPreviewState = do
 
 -- | Builds the read-only context threaded through store functions from chat config.
 -- The single construction point, so new store-wide config (e.g. server keys) is added in one place.
-mkStoreCxt :: ChatConfig -> StoreCxt
-mkStoreCxt ChatConfig {chatVRange, badgePublicKeys} = StoreCxt chatVRange badgePublicKeys
-{-# INLINE mkStoreCxt #-}
+storeCxt :: ChatController -> StoreCxt
+storeCxt ChatController {config = ChatConfig {chatVRange, badgePublicKeys}, random} = StoreCxt chatVRange badgePublicKeys random
+{-# INLINE storeCxt #-}
 
 data RandomAgentServers = RandomAgentServers
   { smpServers :: NonEmpty (ServerCfg 'PSMP),
@@ -277,6 +288,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,
@@ -309,6 +326,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,
@@ -381,7 +401,7 @@ data ChatCommand
   | APISaveAppSettings AppSettings
   | APIGetAppSettings (Maybe AppSettings)
   | APIGetChatTags UserId
-  | APIGetChats {userId :: UserId, pendingConnections :: Bool, pagination :: PaginationByTime, query :: ChatListQuery}
+  | APIGetChats {userId :: UserId, pendingConnections :: Bool, pagination :: Maybe PaginationByTime, query :: ChatListQuery}
   | APIGetChat {chatRef :: ChatRef, contentTag :: Maybe MsgContentTag, chatPagination :: ChatPagination, search :: Maybe Text}
   | APIGetChatContentTypes ChatRef
   | APIGetChatItems {chatPagination :: ChatPagination, search :: Maybe Text}
@@ -646,6 +666,12 @@ data ChatCommand
   | UpdateProfileImage (Maybe ImageData) -- UserId (not used in UI)
   | 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
+  | 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
+  -- 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)
@@ -663,10 +689,10 @@ data ChatCommand
   | DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data
   | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
   | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
-  | ConnectRemoteCtrl RCSignedInvitation -- Connect new or existing controller via OOB data
+  | ConnectRemoteCtrl {remoteInvitation :: RCSignedInvitation} -- Connect new or existing controller via OOB data
   | FindKnownRemoteCtrl -- Start listening for announcements from all existing controllers
   | ConfirmRemoteCtrl RemoteCtrlId -- Confirm the connection with found controller
-  | VerifyRemoteCtrlSession Text -- Verify remote controller session
+  | VerifyRemoteCtrlSession {sessionCode :: Text} -- Verify remote controller session
   | ListRemoteCtrls
   | StopRemoteCtrl -- Stop listening for announcements or terminate an active session
   | DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session
@@ -850,6 +876,9 @@ data ChatResponse
   | CRContactRequestRejected {user :: User, contactRequest :: UserContactRequest, contact_ :: Maybe Contact}
   | 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}
+  | CRBadgeLedger {user :: User, badgeLedger :: [StatementEntry]}
   | CRWallet {user :: User, accountIndexes_ :: Maybe [AccountIndex]}
   | CRWalletMnemonic {user :: User, mnemonic :: Text}
   | CRWalletAddress {user :: User, walletAddress :: WalletAddress}
@@ -884,7 +913,7 @@ data ChatResponse
   | CRAcceptingContactRequest {user :: User, contact :: Contact}
   | CRContactAlreadyExists {user :: User, contact :: Contact}
   | CRLeftMemberUser {user :: User, groupInfo :: GroupInfo}
-  | CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool}
+  | CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool, localDeletion :: Bool}
   | CRForwardPlan {user :: User, itemsCount :: Int, chatItemIds :: [ChatItemId], forwardConfirmation :: Maybe ForwardConfirmation}
   | CRChatMsgContent {user :: User, msgContent :: MsgContent}
   | CRRcvFileAccepted {user :: User, chatItem :: AChatItem}
@@ -971,6 +1000,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}
@@ -1460,6 +1491,16 @@ data SimplexDomainError
   | SDEUnknownDomain -- the resolved link's profile has no name, or a different name
   deriving (Eq, Show)
 
+data BadgeRedeemError
+  = BREInvalidCode -- format or check character
+  | BREServiceNotConfigured
+  | BREBadgeActive
+  | BREServiceError {serviceError :: BadgeServiceErrorCode}
+  | BREInvalidResponse {message :: String}
+  | BREUnknownKeyIndex
+  | BRECredentialNotVerified
+  deriving (Eq, Show)
+
 data ChatErrorType
   = CENoActiveUser
   | CENoConnectionUser {agentConnId :: AgentConnId}
@@ -1533,6 +1574,7 @@ data ChatErrorType
   | CEAgentVersion
   | CEAgentNoSubResult {agentConnId :: AgentConnId}
   | CECommandError {message :: String}
+  | CEBadgeRedeemError {badgeRedeemError :: BadgeRedeemError}
   | CEServerProtocol {serverProtocol :: AProtocolType}
   | CEAgentCommandError {message :: String}
   | CEInvalidFileDescription {message :: String}
@@ -1766,12 +1808,12 @@ withFastStore = withStorePriority True
 withStorePriority :: Bool -> (DB.Connection -> ExceptT StoreError IO a) -> CM a
 withStorePriority priority action = do
   ChatController {chatStore} <- ask
-  liftIOEither $ withTransactionPriority chatStore priority (runExceptT . withExceptT ChatErrorStore . action) `E.catch` handleDBErrors
+  liftIOEither $ withTransactionPriority chatStore priority (runExceptT . withExceptT ChatErrorStore . action) `catchOwn'` handleDBErrors
 
 withStoreBatch :: Traversable t => (DB.Connection -> t (IO (Either ChatError a))) -> CM' (t (Either ChatError a))
 withStoreBatch actions = do
   ChatController {chatStore} <- ask
-  liftIO $ withTransaction chatStore $ mapM (`E.catch` handleDBErrors) . actions
+  liftIO $ withTransaction chatStore $ mapM (`catchOwn'` handleDBErrors) . actions
 
 handleDBErrors :: E.SomeException -> IO (Either ChatError a)
 handleDBErrors e = pure $ Left $ ChatErrorStore $ case E.fromException e of
@@ -1817,6 +1859,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "FC") ''ForwardConfirmation)
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "SDE") ''SimplexDomainError)
 
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BRE") ''BadgeRedeemError)
+
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CE") ''ChatErrorType)
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RHE") ''RemoteHostError)

src/Simplex/Chat/Library/Internal.hs

@@ -40,7 +40,7 @@ import Data.Foldable (foldr')
 import Data.Functor (($>))
 import Data.Functor.Identity
 import Data.Int (Int64)
-import Data.List (foldl', mapAccumL, partition)
+import Data.List (find, foldl', mapAccumL, partition)
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
@@ -53,7 +53,7 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Time (addUTCTime)
 import Data.Time.Calendar (fromGregorian)
 import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToDiffTime)
-import Simplex.Chat.Badges (BadgeCredential (..), ProofPresHeader (..), BadgeProof (..), BadgeStatus (..), LocalBadge (..), badgeProof, mkBadgeStatus, verifyBadge)
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), ProofPresHeader (..), BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), LocalBadge (..), badgeProof, badgeSndGraceInterval, generateBadgeProof, localBadgeStatus, maxXFTPFileSize, mkBadgeStatus, verifyBadge)
 import Simplex.Chat.Names (SimplexDomainClaim (..), claimDomain)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
@@ -98,7 +98,8 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
 import qualified Simplex.Messaging.Crypto.File as CF
 import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
-import Simplex.Messaging.Encoding (smpEncode)
+import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..))
+import Simplex.Messaging.Encoding (smpDecode, smpEncode)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (MsgBody, MsgFlags (..), ProtoServerWithAuth (..), ProtocolServer, ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer)
 import qualified Simplex.Messaging.Protocol as SMP
@@ -435,10 +436,11 @@ roundedFDCount n
   | n <= 0 = 4
   | otherwise = max 4 $ fromIntegral $ (2 :: Integer) ^ (ceiling (logBase 2 (fromIntegral n) :: Double) :: Integer)
 
-xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
-xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ = do
+xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> Maybe ByteString -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
+xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ binding_ = do
+  fileBadge <- pure binding_ $>>= \chatBinding -> sndBadgeProof user PHFileInv {chatBinding, fileSize = fromInteger fileSize}
   let fileName = takeFileName filePath
-      fInv = xftpFileInvitation fileName fileSize dummyFileDescr
+      fInv = (xftpFileInvitation fileName fileSize dummyFileDescr :: FileInvitation) {fileBadge}
   fsFilePath <- lift $ toFSFilePath filePath
   let srcFile = CryptoFile fsFilePath cfArgs
   aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n) Nothing
@@ -446,9 +448,32 @@ xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOr
   chSize <- asks $ fileChunkSize . config
   ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup_ file fInv (AgentSndFileId aFileId) Nothing chSize
   let fileSource = Just $ CryptoFile filePath cfArgs
-      ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP, fileExpires = Nothing}
+      ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP, fileExpires = Nothing, fileProhibited = Nothing}
   pure (fInv, ciFile, ft)
 
+fileNeedsBadge :: Integer -> CM Bool
+fileNeedsBadge fileSize = (fileSize >) . noBadge <$> asks (fileSizeLimits . config)
+
+sndBadgeProof :: User -> ProofPresHeader -> CM (Maybe BadgeProof)
+sndBadgeProof user = sndBadgeProof_ user . BBSPresHeader . strEncode
+
+sndBadgeProof_ :: User -> BBSPresHeader -> CM (Maybe BadgeProof)
+sndBadgeProof_ User {profile = LocalProfile {localBadge}} ph = case localBadge of
+  Just (OwnBadge cred@(BadgeCredential keyIdx _ _ _) _) -> do
+    keys <- asks $ badgePublicKeys . config
+    case M.lookup keyIdx keys of
+      Nothing -> Nothing <$ logError "sndBadgeProof: badge key index not in config"
+      Just key ->
+        liftIO (generateBadgeProof key cred ph) >>= \case
+          Right proof -> pure $ Just proof
+          Left e -> Nothing <$ logError ("sndBadgeProof: proof generation failed: " <> T.pack e)
+  _ -> pure Nothing
+
+sndGroupChatBinding :: GroupInfo -> ShowGroupAsSender -> Maybe ByteString
+sndGroupChatBinding gInfo@GroupInfo {membership = GroupMember {memberId, memberPubKey}} asGroup
+  | asGroup = (\PublicGroupProfile {publicGroupId} -> encodeChatBinding CBChannel $ smpEncode publicGroupId) <$> publicGroup' gInfo
+  | otherwise = (\k -> encodeChatBinding CBGroup $ groupBindingData gInfo memberId k) <$> memberPubKey
+
 cryptoFileDigest :: CryptoFile -> CM FD.FileDigest
 cryptoFileDigest (CryptoFile filePath cfArgs) = do
   fsPath <- lift $ toFSFilePath filePath
@@ -744,10 +769,11 @@ rctFileCancelled = \case
   _ -> False
 
 acceptFileReceive :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM AChatItem
-acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId, cryptoArgs} userApprovedRelays rcvInline_ filePath_ = do
+acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileProhibited, fileStatus, grpMemberId, cryptoArgs} userApprovedRelays rcvInline_ filePath_ = do
   unless (fileStatus == RFSNew) $ case fileStatus of
     RFSCancelled _ -> throwChatError $ CEFileCancelled fName
     _ -> throwChatError $ CEFileAlreadyReceiving fName
+  when (isJust fileProhibited) $ throwChatError $ CEFileSize fName
   cxt <- chatStoreCxt
   case (xftpRcvFile, fileConnReq) of
     -- XFTP
@@ -970,7 +996,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
           incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
           pure (ct, conn, ExistingIncognito <$> incognitoProfile)
   profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
-  dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend
+  dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend Nothing
   (ct,conn,) <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode)
 
 acceptContactRequestAsync :: User -> Int64 -> Contact -> UserContactRequest -> Maybe IncognitoProfile -> CM Contact
@@ -991,14 +1017,14 @@ acceptContactRequestAsync
       Connection {connId} <- liftIO $ createAcceptedContactConn db user (Just uclId) contactId acId chatV cReqChatVRange cReqPQSup incognitoProfile subMode currentTs
       liftIO $ setCommandConnId db user cmdId connId
       getContact db cxt user contactId
-    agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend) cReqPQSup subMode
+    agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend Nothing) cReqPQSup subMode
     pure ct'
 
-acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
+acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfoKeys -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
 acceptGroupJoinRequestAsync
   user@User {userId}
   uclId
-  gInfo@GroupInfo {groupProfile, membership, businessChat}
+  (GIK gInfo@GroupInfo {groupProfile, membership, businessChat} gks)
   cReqInvId
   cReqChatVRange
   cReqProfile
@@ -1032,6 +1058,7 @@ acceptGroupJoinRequestAsync
             GroupLinkInvitation
               { fromMember = MemberIdRole userMemberId userRole,
                 fromMemberName = displayName,
+                fromMemberKey = Just $ groupMemberKey gks,
                 invitedMember = MemberIdRole memberId gLinkMemRole,
                 groupProfile,
                 accepted = Just gAccepted,
@@ -1079,11 +1106,11 @@ acceptGroupJoinSendRejectAsync
     agentAcceptContactAsync cmdId acId False cReqInvId msg PQSupportOff subMode
     pure m
 
-acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfo -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
+acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfoKeys -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
 acceptBusinessJoinRequestAsync
   user
   uclId
-  gInfo@GroupInfo {membership = GroupMember {memberRole = userRole, memberId = userMemberId}}
+  (GIK gInfo@GroupInfo {membership = GroupMember {memberRole = userRole, memberId = userMemberId}} gks)
   clientMember@GroupMember {groupMemberId, memberId}
   UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId} = do
     cxt <- chatStoreCxt
@@ -1095,6 +1122,7 @@ acceptBusinessJoinRequestAsync
             GroupLinkInvitation
               { fromMember = MemberIdRole userMemberId userRole,
                 fromMemberName = displayName,
+                fromMemberKey = Just $ groupMemberKey gks,
                 invitedMember = MemberIdRole memberId GRMember,
                 groupProfile = businessGroupProfile userProfile groupPreferences,
                 accepted = Just GAAccepted,
@@ -1169,15 +1197,15 @@ businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile
 businessGroupProfile Profile {displayName, fullName, shortDescr, description, image} groupPreferences =
   GroupProfile {displayName, fullName, description, shortDescr, image, publicGroup = Nothing, groupPreferences = Just groupPreferences, memberAdmission = Nothing}
 
-introduceToModerators :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
-introduceToModerators cxt user gInfo@GroupInfo {groupId} m@GroupMember {memberRole, memberId} = do
+introduceToModerators :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
+introduceToModerators cxt user gInfo@(GIK g@GroupInfo {groupId} _) m@GroupMember {memberRole, memberId} = do
   forM_ (memberConn m) $ \mConn -> do
     let msg =
           if maxVersion (memberChatVRange m) >= groupKnockingVersion
             then XGrpLinkAcpt GAPendingReview memberRole memberId
             else XMsgNew $ mcSimple (MCText pendingReviewMessage)
     void $ sendDirectMemberMessage mConn msg groupId
-  modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
+  modMs <- withStore' $ \db -> getGroupModerators db cxt user g
   let rcpModMs = filter shouldIntroduceToMod modMs
   introduceMember user gInfo m rcpModMs (Just $ MSMember $ memberId' m)
   where
@@ -1187,15 +1215,15 @@ introduceToModerators cxt user gInfo@GroupInfo {groupId} m@GroupMember {memberRo
         && groupMemberId' mem /= groupMemberId' m
         && maxVersion (memberChatVRange mem) >= groupKnockingVersion
 
-introduceToAll :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
-introduceToAll cxt user gInfo m = do
-  (members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
+introduceToAll :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
+introduceToAll cxt user gInfo@(GIK g _) m = do
+  (members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user g) (getMemberRelationsVector db m)
   let recipients = filter (shouldIntroduce m vector) members
   introduceMember user gInfo m recipients Nothing
 
-introduceToRemaining :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
-introduceToRemaining cxt user gInfo m = do
-  (members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
+introduceToRemaining :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
+introduceToRemaining cxt user gInfo@(GIK g _) m = do
+  (members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user g) (getMemberRelationsVector db m)
   let recipients = filter (shouldIntroduce m vector) members
   introduceMember user gInfo m recipients Nothing
 
@@ -1205,17 +1233,17 @@ shouldIntroduce m vec mem =
     && groupMemberId' mem /= groupMemberId' m
     && getRelation (indexInGroup mem) vec == MRNew
 
-introduceMember :: User -> GroupInfo -> GroupMember -> [GroupMember] -> Maybe MsgScope -> CM ()
+introduceMember :: User -> GroupInfoKeys -> GroupMember -> [GroupMember] -> Maybe MsgScope -> CM ()
 introduceMember _ _ GroupMember {activeConn = Nothing} _ _ = throwChatError $ CEInternalError "member connection not active"
-introduceMember user gInfo toMember@GroupMember {activeConn = Just conn} introduceToMembers msgScope = do
-  void . sendGroupMessage' user gInfo introduceToMembers $ XGrpMemNew (memberInfo gInfo toMember) msgScope
+introduceMember user gInfo@(GIK g _) toMember@GroupMember {activeConn = Just conn} introduceToMembers msgScope = do
+  void . sendGroupMessage' user gInfo introduceToMembers $ XGrpMemNew (memberInfo g toMember) msgScope
   sendIntroductions introduceToMembers
   where
     sendIntroductions reMembers = do
       updateToMemberVector reMembers
       updateReMembersVectors reMembers
       shuffledReMembers <- liftIO $ shuffleMembers reMembers
-      let events = map (memberIntroEvt gInfo) shuffledReMembers
+      let events = map (memberIntroEvt g) shuffledReMembers
       forM_ (L.nonEmpty events) $ \events' ->
         sendGroupMemberMessages user gInfo conn events'
     updateToMemberVector :: [GroupMember] -> CM ()
@@ -1244,11 +1272,11 @@ memberIntroEvt gInfo reMember =
 
 -- Forward the saved owner-signed roster verbatim (reusing its signed shared_msg_id), then the
 -- blob chunks, so the recipient verifies the owner signature.
-serveRoster :: User -> GroupInfo -> GroupMember -> CM ()
-serveRoster user gInfo member =
+serveRoster :: User -> GroupInfoKeys -> GroupMember -> CM ()
+serveRoster user gInfo@(GIK g _) member =
   when (member `supportsVersion` groupRosterVersion) $ do
     cxt <- chatStoreCxt
-    withStore' (\db -> getStoredGroupRoster db gInfo) >>= \case
+    withStore' (\db -> getStoredGroupRoster db g) >>= \case
       Just (ownerGMId, brokerTs, sm@SignedMsg {signedBody}, blob_, storedVer_) ->
         case J.eitherDecodeStrict' signedBody :: Either String (ChatMessage 'Json) of
           Left e -> logError $ "serveRoster: cannot decode saved roster message: " <> tshow e
@@ -1269,24 +1297,24 @@ serveRoster user gInfo member =
 -- Used in groups with relays to introduce moderators and above to a new member,
 -- and to announce the new member to moderators and above.
 -- This doesn't create introduction records in db, compared to above methods.
-introduceInChannel :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
+introduceInChannel :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
 introduceInChannel _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
-introduceInChannel cxt user gInfo subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
+introduceInChannel cxt user g@(GIK gInfo _) subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
   (owners, adminsMods) <- withStore' $ \db ->
     (,) <$> getGroupOwners db cxt user gInfo <*> getGroupAdminsMods db cxt user gInfo
   let modMs = owners <> adminsMods
-  void $ sendGroupMessage' user gInfo modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
+  void $ sendGroupMessage' user g modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
   withStore' $ \db ->
     setMemberVectorNewRelations db subscriber [(indexInGroup m, (IDSubjectIntroduced, MRIntroduced)) | m <- modMs]
   -- owner intros first so the joiner has the owner profile loaded before applying the saved roster (signed by the owner)
   sendIntros owners
-  serveRoster user gInfo subscriber
+  serveRoster user g subscriber
   sendIntros adminsMods
   withStore' $ \db ->
     setMembersVectorsNewRelation db modMs subscriberIdx IDSubjectIntroduced MRIntroduced
   where
     sendIntros ms = forM_ (L.nonEmpty $ map (memberIntroEvt gInfo) ms) $ \evts ->
-      sendGroupMemberMessages user gInfo conn evts
+      sendGroupMemberMessages user g conn evts
 
 userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile
 userProfileInGroup user g = userProfileInGroup' user (Just g)
@@ -1417,15 +1445,17 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
         resolveAuthor (Just gmId) = do
           cxt <- chatStoreCxt
           eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupMemberById db cxt user gmId)
-        getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime))
+        getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe HistoryFile)
         getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus, fileExpires} = do
           expired <- fileExpired fileExpires
           if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired
             then pure Nothing
             else do
-              rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId
-              pure $ invCompleteDescr ciFile rfd
-        getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime))
+              (rfd, (invBadge, descrBadge)) <- withStore $ \db -> do
+                rfd <- getRcvFileDescrByRcvFileId db fileId
+                (rfd,) <$> liftIO (getFileBadgeProofs db fileId)
+              pure $ invCompleteDescr ciFile rfd invBadge descrBadge
+        getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe HistoryFile)
         getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus, fileExpires} = do
           expired <- fileExpired fileExpires
           if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired
@@ -1433,28 +1463,54 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
             else do
               -- can also lookup in extra_xftp_file_descriptions, though it can be empty;
               -- would be best if snd file had a single rcv description for all members saved in files table
-              rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId
-              pure $ invCompleteDescr ciFile rfd
+              now <- liftIO getCurrentTime
+              (rfd, (invBadge, descrBadge)) <- withStore $ \db -> do
+                rfd <- getRcvFileDescrBySndFileId db fileId
+                (rfd,) <$> liftIO (getFileBadgeProofs db fileId)
+              -- a signed item forwards the author's original bytes, so its invitation proof cannot be replaced
+              (invBadge', descrBadge') <-
+                if isNothing signedMsg_ && ownBadgeActive && (staleBadge now invBadge || staleBadge now descrBadge)
+                  then refreshSndBadges fileId invBadge descrBadge
+                  else pure (invBadge, descrBadge)
+              pure $ invCompleteDescr ciFile rfd invBadge' descrBadge'
+        staleBadge :: UTCTime -> Maybe BadgeProof -> Bool
+        staleBadge now = \case
+          Just BadgeProof {badgeInfo = BadgeInfo {badgeExpiry}} -> addUTCTime badgeSndGraceInterval badgeExpiry < now
+          Nothing -> False
+        ownBadgeActive :: Bool
+        ownBadgeActive = maybe False ((BSActive ==) . localBadgeStatus) localBadge
+          where
+            User {profile = LocalProfile {localBadge}} = user
+        -- both proofs are made with the same badge, and are re-made with the current badge over the stored headers
+        refreshSndBadges :: FileTransferId -> Maybe BadgeProof -> Maybe BadgeProof -> CM (Maybe BadgeProof, Maybe BadgeProof)
+        refreshSndBadges fileId invBadge descrBadge = do
+          invBadge' <- mapM reProve invBadge
+          descrBadge' <- mapM reProve descrBadge
+          withStore' $ \db -> do
+            forM_ invBadge' $ createFileBadgeProof db fileId BPKInvitation
+            forM_ descrBadge' $ createFileBadgeProof db fileId BPKDescription
+          pure (invBadge', descrBadge')
+          where
+            reProve badge@BadgeProof {presHeader} = fromMaybe badge <$> sndBadgeProof_ user presHeader
         fileExpired :: Maybe UTCTime -> CM Bool
         fileExpired fileExpires = do
           ttl <- asks $ rcvFilesTTL . agentConfig . config
           now <- liftIO getCurrentTime
           pure $ fromMaybe (addUTCTime ttl $ chatItemTs cci) fileExpires < now
-        invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime)
-        invCompleteDescr CIFile {fileName, fileSize, fileExpires} RcvFileDescr {fileDescrText, fileDescrComplete}
+        invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe BadgeProof -> Maybe BadgeProof -> Maybe HistoryFile
+        invCompleteDescr CIFile {fileName, fileSize, fileExpires} RcvFileDescr {fileDescrText, fileDescrComplete} invBadge descrBadge
           | fileDescrComplete =
-              let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
-                  fInv = xftpFileInvitation fileName fileSize fInvDescr
-               in Just (fInv, fileDescrText, fileExpires)
+              let fInv = (xftpFileInvitation fileName fileSize dummyFileDescr :: FileInvitation) {fileBadge = invBadge}
+               in Just (fInv, fileDescrText, fileExpires, descrBadge)
           | otherwise = Nothing
-        processContentItem :: Maybe GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime) -> CM [(GrpMsgForward, VerifiedMsg 'Json)]
+        processContentItem :: Maybe GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe HistoryFile -> CM [(GrpMsgForward, VerifiedMsg 'Json)]
         processContentItem member_ ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ =
           if isNothing fInvDescr_ && not (msgContentHasText mc)
             then pure []
             else do
               let CIMeta {itemTs, itemSharedMsgId, itemTimed, showGroupAsSender} = meta
                   quotedItemId_ = quoteItemId =<< quotedItem
-                  fInv_ = (\(fInv, _, _) -> fInv) <$> fInvDescr_
+                  fInv_ = (\(fInv, _, _, _) -> fInv) <$> fInvDescr_
                   (mc', _, mentions') = updatedMentionNames mc formattedText mentions
                   mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions'
                   -- for channel messages default chat version range to membership range
@@ -1473,10 +1529,10 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
                   (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing showGroupAsSender mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False
                   pure $ VMUnsigned ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent}
               fileDescrEvents <- case (fInvDescr_, itemSharedMsgId) of
-                (Just (_, fileDescrText, fileExpires), Just msgId) -> do
+                (Just (_, fileDescrText, fileExpires, descrBadge), Just msgId) -> do
                   partSize <- asks $ xftpDescrPartSize . config
-                  let parts = splitFileDescr partSize fileDescrText
-                  pure . L.toList $ L.map (\fd -> XMsgFileDescr msgId fd fileExpires) parts
+                  let parts = splitFileDescr partSize (maybe partSize (const badgeDescrPartSize) descrBadge) fileDescrText
+                  pure . L.toList $ L.map (\fd@FileDescr {fileDescrComplete} -> XMsgFileDescr msgId fd fileExpires (if fileDescrComplete then descrBadge else Nothing)) parts
                 _ -> pure []
               let fileDescrVMs = map (VMUnsigned . ChatMessage senderVRange Nothing) fileDescrEvents
               pure $ map ((,) fwd) (contentVM : fileDescrVMs)
@@ -1486,40 +1542,45 @@ memberShortenedName GroupMember {memberProfile = LocalProfile {displayName}}
   | T.length displayName <= 16 = displayName
   | otherwise = T.take 16 displayName `T.snoc` '…'
 
-splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr
-splitFileDescr partSize rfdText = splitParts 1 rfdText
+-- the description proof travels on the last part, so that part leaves room for it
+badgeDescrPartSize :: Int
+badgeDescrPartSize = 13500
+
+splitFileDescr :: Int -> Int -> RcvFileDescrText -> NonEmpty FileDescr
+splitFileDescr partSize lastSize rfdText = splitParts 1 rfdText
   where
     splitParts partNo remText =
-      let (part, rest) = T.splitAt partSize remText
+      let n = T.length remText
+          (part, rest) = T.splitAt (if n <= lastSize then n else if n <= partSize then lastSize else partSize) remText
           complete = T.null rest
           fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete}
        in if complete
             then fileDescr :| []
             else fileDescr <| splitParts (partNo + 1) rest
 
-setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfo -> CM (Maybe GroupLink)
-setGroupLinkData' nm user gInfo =
-  withFastStore' (\db -> runExceptT $ getGroupLink db user gInfo) >>= \case
+setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfoKeys -> CM (Maybe GroupLink)
+setGroupLinkData' nm user gInfo@(GIK g _) =
+  withFastStore' (\db -> runExceptT $ getGroupLink db user g) >>= \case
     Right gLink@GroupLink {shortLinkDataSet}
       | shortLinkDataSet -> Just <$> setGroupLinkData nm user gInfo gLink
     _ -> pure Nothing
 
-setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM GroupLink
-setGroupLinkData nm user gInfo gLink = do
+setGroupLinkData :: NetworkRequestMode -> User -> GroupInfoKeys -> GroupLink -> CM GroupLink
+setGroupLinkData nm user g@(GIK gInfo _) gLink = do
   cxt <- chatStoreCxt
   (conn, groupRelays) <- withFastStore $ \db ->
     (,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
-  let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
+  let (userLinkData, crClientData) = groupLinkData g gLink groupRelays
       linkType = if useRelays' gInfo then CCTChannel else CCTGroup
   sLnk <- shortenShortLink' . setShortLinkType_ linkType =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData) False Nothing)
   withFastStore' $ \db -> setGroupLinkShortLink db gLink sLnk
 
-setGroupLinkDataAsync :: User -> GroupInfo -> GroupLink -> CM ()
-setGroupLinkDataAsync user gInfo gLink = do
+setGroupLinkDataAsync :: User -> GroupInfoKeys -> GroupLink -> CM ()
+setGroupLinkDataAsync user g@(GIK gInfo _) gLink = do
   cxt <- chatStoreCxt
   (conn, groupRelays) <- withStore $ \db ->
     (,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
-  let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
+  let (userLinkData, crClientData) = groupLinkData g gLink groupRelays
   setAgentConnShortLinkAsync user conn userLinkData (Just crClientData)
 
 connectToRelayAsync :: User -> GroupInfo -> ShortLinkContact -> CM ()
@@ -1534,15 +1595,15 @@ connectToRelayAsync user gInfo relayLink = do
       newConnIds <- getAgentConnShortLinkAsync user CFGetRelayDataJoin Nothing relayLink
       withFastStore' $ \db -> createRelayMemberConnectionAsync db user gInfo relayMember relayLink newConnIds subMode
 
-updatePublicGroupData :: User -> GroupInfo -> CM GroupInfo
-updatePublicGroupData user gInfo
+updatePublicGroupData :: User -> GroupInfo -> GroupKeys -> CM GroupInfo
+updatePublicGroupData user gInfo gks
   | useRelays' gInfo && memberRole' (membership gInfo) == GROwner = do
       cxt <- chatStoreCxt
       (gInfo', gLink) <- withStore $ \db -> do
         gInfo' <- updatePublicMemberCount db cxt user gInfo
         gLink <- getGroupLink db user gInfo'
         pure (gInfo', gLink)
-      setGroupLinkDataAsync user gInfo' gLink
+      setGroupLinkDataAsync user (GIK gInfo' gks) gLink
       pure gInfo'
   | useRelays' gInfo && isRelay (membership gInfo) = do
       cxt <- chatStoreCxt
@@ -1586,14 +1647,14 @@ updateContactFromLinkData user ct@Contact {profile = profile@LocalProfile {conta
     verifyChanged = contactDomainVerified /= Just True || claimChanged
 
 -- TODO [relays] owner: set owners on updating link data (multi-owner)
-groupLinkData :: GroupInfo -> GroupLink -> [GroupRelay] -> (UserConnLinkData 'CMContact, CRClientData)
-groupLinkData gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {publicMemberCount}, membership = GroupMember {memberId}, groupKeys} GroupLink {groupLinkId} groupRelays =
+groupLinkData :: GroupInfoKeys -> GroupLink -> [GroupRelay] -> (UserConnLinkData 'CMContact, CRClientData)
+groupLinkData (GIK gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {publicMemberCount}, membership = GroupMember {memberId}} gks) GroupLink {groupLinkId} groupRelays =
   let direct = not $ useRelays' gInfo
       relays = mapMaybe (\GroupRelay {relayLink} -> relayLink) groupRelays
       publicGroupData_ = PublicGroupData <$> publicMemberCount
       userData = encodeShortLinkData $ GroupShortLinkData {groupProfile, publicGroupData = publicGroupData_}
-      owners = case groupKeys of
-        Just GroupKeys {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey} ->
+      owners = case gks of
+        GKPublicGroup {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey} ->
           let ownerId = unMemberId memberId
               ownerKey = C.publicKey memberPrivKey
               authOwnerSig = C.sign' rootPrivKey (ownerId <> C.encodePubKey ownerKey)
@@ -2247,28 +2308,105 @@ createSndMessages idsEvents = do
         encodeMessage sharedMsgId =
           encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt}
 
-groupMsgSigning :: Bool -> GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning
-groupMsgSigning sign gInfo@GroupInfo {membership = GroupMember {memberId}, groupKeys = Just GroupKeys {publicGroupId, memberPrivKey}} evt
-  | useRelays' gInfo && shouldSign =
-      Just $ MsgSigning CBGroup (smpEncode (publicGroupId, memberId)) KRMember memberPrivKey
+groupMsgSigning :: Bool -> GroupInfoKeys -> ChatMsgEvent e -> Maybe MsgSigning
+groupMsgSigning sign (GIK gInfo@GroupInfo {membership = GroupMember {memberId}} gks) evt
+  | shouldSign = Just $ MsgSigning CBGroup bindingData KRMember memberPrivKey'
+  | otherwise = Nothing
   where
+    memberPrivKey' = memberPrivKey gks
     tag = toCMEventTag evt
     shouldSign = requiresSignature tag || (sign && signableContent tag)
-groupMsgSigning _ _ _ = Nothing
+    bindingData = groupBindingData gInfo memberId (C.publicKey memberPrivKey')
 
-sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfo -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
-sendGroupMemberMessages user gInfo@GroupInfo {groupId} conn events = do
+groupBindingData :: GroupInfo -> MemberId -> C.PublicKeyEd25519 -> ByteString
+groupBindingData gInfo memberId memberKey = case publicGroup' gInfo of
+  Just PublicGroupProfile {publicGroupId} -> smpEncode (publicGroupId, memberId)
+  Nothing -> smpEncode (memberId, memberKey)
+
+type HistoryFile = (FileInvitation, RcvFileDescrText, Maybe UTCTime, Maybe BadgeProof)
+
+directChatBinding :: Contact -> CM (Maybe ByteString)
+directChatBinding ct =
+  forM (contactConn ct) $ \conn ->
+    encodeChatBinding CBDirect <$> withAgent (`getConnectionRatchetAdHash` aConnId conn)
+
+rcvGroupChatBinding :: GroupInfo -> Maybe GroupMember -> ShowGroupAsSender -> Maybe BadgeProof -> Maybe ByteString
+rcvGroupChatBinding gInfo m_ asGroup badge_ =
+  case (publicGroup' gInfo, asGroup, m_) of
+    (Just PublicGroupProfile {publicGroupId}, True, _) ->
+      Just $ encodeChatBinding CBChannel $ smpEncode publicGroupId
+    (Just PublicGroupProfile {publicGroupId}, False, Just GroupMember {memberId}) ->
+      Just $ encodeChatBinding CBGroup $ smpEncode (publicGroupId, memberId)
+    (Nothing, False, Just GroupMember {memberId, memberPubKey}) ->
+      (\k -> encodeChatBinding CBGroup $ smpEncode (memberId, k)) <$> (memberPubKey <|> proofMemberKey memberId badge_)
+    _ -> Nothing
+
+proofMemberKey :: MemberId -> Maybe BadgeProof -> Maybe C.PublicKeyEd25519
+proofMemberKey memberId badge_ = do
+  BadgeProof _ (BBSPresHeader phBytes) _ _ <- badge_
+  binding <- headerChatBinding =<< eitherToMaybe (strDecode phBytes)
+  d <- B.stripPrefix (smpEncode CBGroup) binding
+  (mId, k) <- eitherToMaybe (smpDecode d :: Either String (MemberId, C.PublicKeyEd25519))
+  if mId == memberId then Just k else Nothing
+  where
+    headerChatBinding = \case
+      PHFileInv {chatBinding} -> Just chatBinding
+      PHFileDescr {chatBinding} -> Just chatBinding
+      _ -> Nothing
+
+badgeProofStatus :: Maybe ProofPresHeader -> BadgeProof -> CM BadgeStatus
+badgeProofStatus expected_ badge@BadgeProof {presHeader = BBSPresHeader phBytes, badgeInfo} =
+  case expected_ of
+    Just expected | phBytes == strEncode expected -> do
+      keys <- asks $ badgePublicKeys . config
+      verified <- liftIO $ verifyBadge keys badge
+      now <- liftIO getCurrentTime
+      pure $ mkBadgeStatus now verified badgeInfo
+    _ -> pure BSFailed
+
+rcvDirectFileProhibited :: Contact -> FileInvitation -> CM (Maybe FileProhibited)
+rcvDirectFileProhibited ct fInv@FileInvitation {fileBadge} = do
+  binding_ <- if isJust fileBadge then directChatBinding ct else pure Nothing
+  rcvFileProhibited binding_ fInv
+
+rcvGroupFileProhibited :: GroupInfo -> Maybe GroupMember -> ShowGroupAsSender -> FileInvitation -> CM (Maybe FileProhibited)
+rcvGroupFileProhibited gInfo m_ asGroup fInv@FileInvitation {fileBadge} =
+  rcvFileProhibited (rcvGroupChatBinding gInfo m_ asGroup fileBadge) fInv
+
+rcvFileProhibited :: Maybe ByteString -> FileInvitation -> CM (Maybe FileProhibited)
+rcvFileProhibited binding_ FileInvitation {fileSize, fileBadge} = do
+  lims <- asks $ fileSizeLimits . config
+  if fileSize <= noBadge lims
+    then pure Nothing
+    else case fileBadge of
+      Nothing -> pure $ Just FileProhibited {maxSize = noBadge lims, badgeStatus = Nothing}
+      Just badge -> do
+        st <- badgeProofStatus ((\chatBinding -> PHFileInv {chatBinding, fileSize = fromInteger fileSize}) <$> binding_) badge
+        let maxSize = maxXFTPFileSize lims $ Just $ PeerBadge badge st
+        pure $
+          if fileSize <= maxSize
+            then Nothing
+            else Just FileProhibited {maxSize, badgeStatus = Just st}
+
+groupMemberKey :: GroupKeys -> MemberKey
+groupMemberKey gks = MemberKey $ C.publicKey $ memberPrivKey gks
+
+sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfoKeys -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
+sendGroupMemberMessages user g@(GIK gInfo@GroupInfo {groupId} _) conn events = do
   when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
-  let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning False gInfo evt, evt)) events
-      mode = if useRelays' gInfo then BMBinary else BMJson
+  let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning False g evt, evt)) events
   (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts
   unless (null errs) $ toView $ CEvtChatErrors errs
   forM_ (L.nonEmpty msgs) $ \msgs' ->
-    batchSendConnMessages mode user conn MsgFlags {notification = True} msgs'
+    batchSendConnMessages gInfo user conn MsgFlags {notification = True} msgs'
 
-batchSendConnMessages :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
-batchSendConnMessages mode user conn msgFlags msgs =
+batchSendConnMessages :: GroupInfo -> User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
+batchSendConnMessages gInfo user conn msgFlags msgs =
   batchSendConnMessagesB mode user conn msgFlags $ L.map Right msgs
+  where
+    mode
+      | useRelays' gInfo || maxVersion (peerChatVRange conn) >= relayWebCapVersion = BMBinary
+      | otherwise = BMJson
 
 batchSendConnMessagesB :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
 batchSendConnMessagesB mode _user conn msgFlags msgs_ = do
@@ -2323,14 +2461,13 @@ encodeSignedConnInfo signing chatMsgEvent = do
 
 -- signed XMember for a relay-group join: proves the joiner holds the member key it asserts, and carries
 -- viaRelay = the target relay's memberId inside the signed body so a sibling relay can't accept a replay
-encodeXMemberConnInfo :: GroupInfo -> MemberId -> Profile -> CM ByteString
-encodeXMemberConnInfo GroupInfo {membership = GroupMember {memberId}, groupKeys} relayMemberId profileToSend =
-  case groupKeys of
-    Just GroupKeys {publicGroupId, memberPrivKey} ->
-      let xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey) (Just relayMemberId)
-          signing = MsgSigning CBGroup (smpEncode (publicGroupId, memberId)) KRMember memberPrivKey
-       in encodeSignedConnInfo signing xMemberEvt
-    Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
+encodeXMemberConnInfo :: GroupInfoKeys -> MemberId -> Profile -> CM ByteString
+encodeXMemberConnInfo (GIK gInfo@GroupInfo {membership = GroupMember {memberId}} gks) relayMemberId profileToSend =
+  let memberPrivKey' = memberPrivKey gks
+      xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey') (Just relayMemberId)
+      bindingData = groupBindingData gInfo memberId (C.publicKey memberPrivKey')
+      signing = MsgSigning CBGroup bindingData KRMember memberPrivKey'
+   in encodeSignedConnInfo signing xMemberEvt
 
 deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
 deliverMessage conn cmEventTag msgBody msgId = do
@@ -2393,13 +2530,13 @@ deliverMessagesB msgReqs = do
       where
         updatePQ = updateConnPQSndEnabled db connId pqSndEnabled'
 
-sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> [GroupMember] -> Bool -> ChatMsgEvent e -> CM SndMessage
+sendGroupMessage :: MsgEncodingI e => User -> GroupInfoKeys -> Maybe GroupChatScope -> [GroupMember] -> Bool -> ChatMsgEvent e -> CM SndMessage
 sendGroupMessage user gInfo gcScope members sign chatMsgEvent = do
   sendGroupMessages user gInfo gcScope False members sign (chatMsgEvent :| []) >>= \case
     ((Right msg) :| [], _) -> pure msg
     _ -> throwChatError $ CEInternalError "sendGroupMessage: expected 1 message"
 
-sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
+sendGroupMessage' :: MsgEncodingI e => User -> GroupInfoKeys -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
 sendGroupMessage' user gInfo members chatMsgEvent =
   sendGroupMessages_ user gInfo members False (chatMsgEvent :| []) >>= \case
     ((Right msg) :| [], _) -> pure msg
@@ -2425,8 +2562,8 @@ applyRosterDelta delta current = case delta of
 -- advances past a version the owner hasn't recorded), then broadcast the matching blob with the change projected
 -- onto the served roster (so it excludes demoted/removed members). Returns the reserved version for the delta
 -- that follows. The blob send is best-effort - a failed send heals on the next change or on resume.
-broadcastRoster :: User -> GroupInfo -> RosterDelta -> CM VersionRoster
-broadcastRoster user gInfo delta = do
+broadcastRoster :: User -> GroupInfoKeys -> RosterDelta -> CM VersionRoster
+broadcastRoster user g@(GIK gInfo _) delta = do
   let rosterVer = maybe (VersionRoster 0) (\(VersionRoster n) -> VersionRoster (n + 1)) (rosterVersion gInfo)
   withStore' $ \db -> setGroupRosterVersion db gInfo rosterVer
   sendRosterBlob rosterVer `catchAllErrors` eToView
@@ -2437,18 +2574,18 @@ broadcastRoster user gInfo delta = do
       (relays, rosterMems) <- withStore' $ \db ->
         (,) <$> getGroupRelayMembers db cxt user gInfo <*> getGroupRosterMembers db cxt user gInfo
       forM_ (L.nonEmpty relays) $ \relays' ->
-        sendRoster user gInfo (L.toList relays') rosterVer (buildGroupRoster $ applyRosterDelta delta rosterMems)
+        sendRoster user g (L.toList relays') rosterVer (buildGroupRoster $ applyRosterDelta delta rosterMems)
 
 -- Send the current roster (no version bump) to a newly added relay so it can serve joiners.
-sendGroupRosterToRelay :: User -> GroupInfo -> GroupMember -> CM ()
-sendGroupRosterToRelay user gInfo relayMember =
+sendGroupRosterToRelay :: User -> GroupInfoKeys -> GroupMember -> CM ()
+sendGroupRosterToRelay user g@(GIK gInfo _) relayMember =
   forM_ (rosterVersion gInfo) $ \rosterVer -> do
     cxt <- chatStoreCxt
     rosterMems <- withStore' $ \db -> getGroupRosterMembers db cxt user gInfo
-    sendRoster user gInfo [relayMember] rosterVer (buildGroupRoster rosterMems)
+    sendRoster user g [relayMember] rosterVer (buildGroupRoster rosterMems)
 
 -- Row-less send (no files/snd_files rows, so no send-side cleanup); redelivery is the agent's.
-sendRoster :: User -> GroupInfo -> [GroupMember] -> VersionRoster -> [RosterMember] -> CM ()
+sendRoster :: User -> GroupInfoKeys -> [GroupMember] -> VersionRoster -> [RosterMember] -> CM ()
 sendRoster user gInfo members rosterVer roster = do
   let blob = encodeRosterBlob roster
       fileInv = InlineFileInvitation {fileSize = fromIntegral (B.length blob), fileDigest = FD.FileDigest $ LC.sha512Hash $ LB.fromStrict blob}
@@ -2456,7 +2593,7 @@ sendRoster user gInfo members rosterVer roster = do
   sendInlineBlobChunks user gInfo members sharedMsgId blob
 
 -- Send a binary blob as BFileChunks under a shared_msg_id to the given members (chunked by fileChunkSize).
-sendInlineBlobChunks :: User -> GroupInfo -> [GroupMember] -> SharedMsgId -> ByteString -> CM ()
+sendInlineBlobChunks :: User -> GroupInfoKeys -> [GroupMember] -> SharedMsgId -> ByteString -> CM ()
 sendInlineBlobChunks user gInfo members sharedMsgId blob = do
   chSize <- fromIntegral <$> asks (fileChunkSize . config)
   go chSize 1 blob
@@ -2469,8 +2606,8 @@ sendInlineBlobChunks user gInfo members sharedMsgId blob = do
 -- Relay advertises its current web preview capability to channel owners.
 -- Idempotent: sends only when the configured web domain differs from what was last sent, and only to
 -- owners whose recorded chat version supports relayWebCapVersion (older apps can't parse XGrpRelayCap).
-sendRelayCapIfNeeded :: User -> GroupInfo -> CM ()
-sendRelayCapIfNeeded user gInfo = do
+sendRelayCapIfNeeded :: User -> GroupInfoKeys -> CM ()
+sendRelayCapIfNeeded user g@(GIK gInfo _) = do
   ChatConfig {webPreviewConfig} <- asks config
   let currentWebDomain = (\WebPreviewConfig {webDomain} -> webDomain) <$> webPreviewConfig
   sentWebDomain <- withStore' (`getRelaySentWebDomain` gInfo)
@@ -2479,22 +2616,22 @@ sendRelayCapIfNeeded user gInfo = do
     owners <- withStore' $ \db -> getGroupOwners db cxt user gInfo
     let capableOwners = filter (\m -> memberCurrent m && m `supportsVersion` relayWebCapVersion) owners
     unless (null capableOwners) $ do
-      void $ sendGroupMessage' user gInfo capableOwners (XGrpRelayCap RelayCapabilities {webDomain = currentWebDomain})
+      void $ sendGroupMessage' user g capableOwners (XGrpRelayCap RelayCapabilities {webDomain = currentWebDomain})
       withStore' $ \db -> updateRelaySentWebDomain db gInfo currentWebDomain
 
-sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
+sendGroupMessages :: MsgEncodingI e => User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
 sendGroupMessages user gInfo scope asGroup members sign events = do
   sendGroupProfileUpdate user gInfo scope asGroup members
   sendGroupMessages_ user gInfo members sign events
 
 -- per-item signer variant of sendGroupMessages (used for per-item delete signing); preserves the profile-update prelude
-sendGroupSignedMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
-sendGroupSignedMessages user gInfo scope asGroup members signedEvents = do
+sendGroupSignedMessages :: MsgEncodingI e => User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
+sendGroupSignedMessages user gInfo@(GIK g _) scope asGroup members signedEvents = do
   sendGroupProfileUpdate user gInfo scope asGroup members
-  sendGroupSignedMessages_ gInfo members signedEvents
+  sendGroupSignedMessages_ g members signedEvents
 
-sendGroupProfileUpdate :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> CM ()
-sendGroupProfileUpdate user gInfo scope asGroup members =
+sendGroupProfileUpdate :: User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> CM ()
+sendGroupProfileUpdate user g@(GIK gInfo gks) scope asGroup members =
   -- TODO [knocking] send current profile to pending member after approval?
   when shouldSendProfileUpdate $
     sendProfileUpdate `catchAllErrors` eToView
@@ -2513,7 +2650,7 @@ sendGroupProfileUpdate user gInfo scope asGroup members =
     sendProfileUpdate = do
       -- shouldSendProfileUpdate excludes incognito membership, so the badge is presented
       profileUpdate <- presentUserBadge user Nothing $ redactedMemberProfile gInfo (membership gInfo) $ fromLocalProfile p
-      void $ sendGroupMessage' user gInfo members $ XInfo profileUpdate
+      void $ sendGroupMessage' user g members $ XInfo profileUpdate (Just $ groupMemberKey gks)
       currentTs <- liftIO getCurrentTime
       withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs
 
@@ -2523,9 +2660,9 @@ data GroupSndResult = GroupSndResult
     forwarded :: [GroupMember]
   }
 
-sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
-sendGroupMessages_ _user gInfo recipientMembers sign events =
-  sendGroupSignedMessages_ gInfo recipientMembers $ L.map (\evt -> (groupMsgSigning sign gInfo evt, evt)) events
+sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfoKeys -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
+sendGroupMessages_ _user gInfo@(GIK g _) recipientMembers sign events =
+  sendGroupSignedMessages_ g recipientMembers $ L.map (\evt -> (groupMsgSigning sign gInfo evt, evt)) events
 
 sendGroupSignedMessages_ :: MsgEncodingI e => GroupInfo -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
 sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents = do
@@ -2533,7 +2670,7 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
   recipientMembers' <- liftIO $ shuffleMembers recipientMembers
   let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events}
       (toSend, toPending, forwarded, _, dups) =
-        foldr' (addMember recipientMembers') ([], [], [], S.empty, 0 :: Int) recipientMembers'
+        foldr' (addMember recipientMembers') (([], []), [], [], S.empty, 0 :: Int) recipientMembers'
   when (dups /= 0) $ logError $ "sendGroupMessages_: " <> tshow dups <> " duplicate members"
   -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here
   -- Deliver to toSend members
@@ -2557,26 +2694,30 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
       liftM2 (<>) (shuffle adminMs) (shuffle otherMs)
       where
         isAdmin GroupMember {memberRole} = memberRole >= GRAdmin
-    addMember members m acc@(toSend, pending, forwarded, !mIds, !dups) =
+    addMember members m acc@(toSend@(toSendBin, toSendJson), pending, forwarded, !mIds, !dups) =
       case memberSendAction gInfo events members m of
         Just a
           | mId `S.member` mIds -> (toSend, pending, forwarded, mIds, dups + 1)
           | otherwise -> case a of
-              MSASend conn -> ((m, conn) : toSend, pending, forwarded, mIds', dups)
+              MSASend conn ->
+                let toSend' = case batchMode gInfo m of
+                      BMBinary -> ((m, conn) : toSendBin, toSendJson)
+                      BMJson -> (toSendBin, (m, conn) : toSendJson)
+                 in (toSend', pending, forwarded, mIds', dups)
               MSAPending -> (toSend, m : pending, forwarded, mIds', dups)
               MSAForwarded -> (toSend, pending, m : forwarded, mIds', dups)
         Nothing -> acc
       where
         mId = groupMemberId' m
         mIds' = S.insert mId mIds
-    prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
-    prepareMsgReqs msgFlags msgs toSend = do
-      let mode = if useRelays' gInfo then BMBinary else BMJson
-          batched_ = batchSndMessagesJSON mode msgs
-      case L.nonEmpty batched_ of
-        Just batched' -> foldMembers (length batched' + length msgs) msgBatchMBR batched' toSend
-        Nothing -> ([], [])
+    prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> ([(GroupMember, Connection)], [(GroupMember, Connection)]) -> ([GroupMemberId], [Either ChatError ChatMsgReq])
+    prepareMsgReqs msgFlags msgs (toSendBin, toSendJson) =
+      batchReqs 1 BMBinary toSendBin <> batchReqs 2 BMJson toSendJson
       where
+        batchReqs _ _ [] = ([], [])
+        batchReqs n mode toSend' = case L.nonEmpty (batchSndMessagesJSON mode msgs) of
+          Just batched -> foldMembers (n * (length batched + length msgs)) msgBatchMBR batched toSend'
+          Nothing -> ([], [])
         foldMembers :: forall a. Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
         foldMembers lastRef mkMb mbs mems = snd $ foldr' foldMsgBodies (lastMemIdx_, ([], [])) mems
           where
@@ -2609,6 +2750,11 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
     createPendingMsg db (groupMemberId, msgId) =
       createPendingGroupMessage db groupMemberId msgId $> Right ()
 
+batchMode :: GroupInfo -> GroupMember -> BatchMode
+batchMode gInfo m
+  | useRelays' gInfo || m `supportsVersion` relayWebCapVersion = BMBinary
+  | otherwise = BMJson
+
 data MemberSendAction = MSASend Connection | MSAPending | MSAForwarded
 
 memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction
@@ -2682,10 +2828,9 @@ sendFwdMemberMessage member fwd verifiedMsg =
 -- TODO ensure order - pending messages interleave with user input messages
 sendPendingGroupMessages :: User -> GroupInfo -> GroupMember -> Connection -> CM ()
 sendPendingGroupMessages user gInfo GroupMember {groupMemberId} conn = do
-  let mode = if useRelays' gInfo then BMBinary else BMJson
   msgs <- withStore' $ \db -> getPendingGroupMessages db groupMemberId
   forM_ (L.nonEmpty msgs) $ \msgs' -> do
-    void $ batchSendConnMessages mode user conn MsgFlags {notification = True} msgs'
+    void $ batchSendConnMessages gInfo user conn MsgFlags {notification = True} msgs'
     lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs'
 
 saveDirectRcvMSG :: forall e. MsgEncodingI e => Connection -> MsgMeta -> ChatMessage e -> CM (Connection, RcvMessage)
@@ -2890,10 +3035,19 @@ joinAgentConnectionAsync :: CommandId -> Bool -> ConnId -> Bool -> ConnectionReq
 joinAgentConnectionAsync cmdId updateConn connId enableNtfs cReqUri cInfo subMode =
   withAgent $ \a -> joinConnectionAsync a (aCorrId cmdId) updateConn connId enableNtfs cReqUri cInfo PQSupportOff subMode
 
-allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> CM ()
-allowAgentConnectionAsync user conn@Connection {connId, pqSupport} confId msg = do
+allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> Maybe GroupInfoKeys -> ChatMsgEvent e -> CM ()
+allowAgentConnectionAsync user conn@Connection {pqSupport} confId gInfo_ msg = do
+  let signing_ = case gInfo_ of
+        Just gInfo@(GIK g _) | useRelays' g || maxVersion (peerChatVRange conn) >= relayWebCapVersion -> groupMsgSigning False gInfo msg
+        _ -> Nothing
+  dm <- case signing_ of
+    Just signing -> encodeSignedConnInfo signing msg
+    Nothing -> encodeConnInfoPQ pqSupport msg
+  allowAgentConnectionInfo user conn confId dm
+
+allowAgentConnectionInfo :: User -> Connection -> ConfirmationId -> ByteString -> CM ()
+allowAgentConnectionInfo user conn@Connection {connId} confId dm = do
   cmdId <- withStore' $ \db -> createCommand db user (Just connId) CFAllowConn
-  dm <- encodeConnInfoPQ pqSupport msg
   withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm
   withStore' $ \db -> updateConnectionStatus db conn ConnAccepted
 
@@ -3127,7 +3281,7 @@ createChatItems ::
 createChatItems user itemTs_ dirsCIContents = do
   createdAt <- liftIO getCurrentTime
   let itemTs = fromMaybe createdAt itemTs_
-  cxt <- chatStoreCxt'
+  cxt <- asks storeCxt
   void . withStoreBatch' $ \db -> map (updateChat db cxt createdAt) dirsCIContents
   withStoreBatch' $ \db -> concatMap (createACIs db itemTs createdAt) dirsCIContents
   where
@@ -3225,13 +3379,9 @@ waitChatStartedAndActivated = do
     unless (isJust started && activated) retry
 
 chatStoreCxt :: CM StoreCxt
-chatStoreCxt = lift chatStoreCxt'
+chatStoreCxt = asks storeCxt
 {-# INLINE chatStoreCxt #-}
 
-chatStoreCxt' :: CM' StoreCxt
-chatStoreCxt' = mkStoreCxt <$> asks config
-{-# INLINE chatStoreCxt' #-}
-
 chatVersionRange :: CM VersionRangeChat
 chatVersionRange = lift chatVersionRange'
 {-# INLINE chatVersionRange #-}

src/Simplex/Chat/Messages.hs

@@ -688,7 +688,8 @@ data CIFile (d :: MsgDirection) = CIFile
     fileSource :: Maybe CryptoFile, -- local file path with optional key and nonce
     fileStatus :: CIFileStatus d,
     fileProtocol :: FileProtocol,
-    fileExpires :: Maybe UTCTime
+    fileExpires :: Maybe UTCTime,
+    fileProhibited :: Maybe FileProhibited
   }
   deriving (Show)
 

src/Simplex/Chat/Messages/Batch.hs

@@ -67,7 +67,7 @@ batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0)
       | msgLen <= maxLen = (addBatch acc, [body], [msg], msgLen, 1)
       | otherwise = (errLarge msg : addBatch acc, [], [], 0, 0)
       where
-        body = encodeBatchElement signedMsg_ msgBody
+        body = encodeBatchElement (if mode == BMBinary then signedMsg_ else Nothing) msgBody
         msgLen = B.length body
         len' = len + msgLen
         n' = n + 1

src/Simplex/Chat/Mobile.hs

@@ -12,6 +12,7 @@ module Simplex.Chat.Mobile where
 
 import Control.Concurrent.STM
 import Control.Exception (SomeException, catch)
+import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Aeson (ToJSON (..))
@@ -27,6 +28,7 @@ import Data.List (find)
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word8)
 import Foreign.C.String
 import Foreign.C.Types (CInt (..))
@@ -34,7 +36,9 @@ import Foreign.Ptr
 import Foreign.StablePtr
 import Foreign.Storable (poke)
 import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)
+import Numeric.Natural (Natural)
 import Simplex.Chat
+import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
 import Simplex.Chat.Controller
 import Simplex.Chat.Library.Commands
 import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList, parseUri, sanitizeUri)
@@ -71,6 +75,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
 data DBMigrationResult
   = DBMOk
   | DBMInvalidConfirmation
+  | DBMInvalidQueueSize
   | DBMErrorNotADatabase {dbFile :: String}
   | DBMErrorMigration {dbFile :: String, migrationError :: MigrationError}
   | DBMErrorSQL {dbFile :: String, migrationSQLError :: String}
@@ -111,6 +116,8 @@ foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString
 
 foreign export ccall "chat_migrate_init_key" cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
 
+foreign export ccall "chat_migrate_init_queue" cChatMigrateInitQueue :: CString -> CString -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
+
 foreign export ccall "chat_close_store" cChatCloseStore :: StablePtr ChatController -> IO CString
 
 foreign export ccall "chat_reopen_store" cChatReopenStore :: StablePtr ChatController -> IO CString
@@ -137,6 +144,8 @@ foreign export ccall "chat_password_hash" cChatPasswordHash :: CString -> CStrin
 
 foreign export ccall "chat_valid_name" cChatValidName :: CString -> IO CString
 
+foreign export ccall "chat_parse_badge_code" cChatParseBadgeCode :: CString -> IO CString
+
 foreign export ccall "chat_json_length" cChatJsonLength :: CString -> IO CInt
 
 foreign export ccall "chat_badge_keygen" cChatBadgeKeygen :: IO CJSONString
@@ -162,7 +171,14 @@ cChatMigrateInit fp key conf = cChatMigrateInitKey fp key 0 conf 0
 
 -- For postgres first param is schema prefix, second param is database connection string.
 cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
-cChatMigrateInitKey fp key keepKey conf background ctrl = do
+cChatMigrateInitKey fp key keepKey conf background = cChatMigrateInit_ fp key (keepKey /= 0) conf (background /= 0) mobileQueueSize
+
+-- | queueSize is the size of internal queues, same as terminal option --queue-size
+cChatMigrateInitQueue :: CString -> CString -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
+cChatMigrateInitQueue fp key conf queueSize = cChatMigrateInit_ fp key False conf False (fromIntegral queueSize)
+
+cChatMigrateInit_ :: CString -> CString -> Bool -> CString -> Bool -> Int -> Ptr (StablePtr ChatController) -> IO CJSONString
+cChatMigrateInit_ fp key keepKey conf background queueSize ctrl = do
   -- ensure we are set to UTF-8; iOS does not have locale, and will default to
   -- US-ASCII all the time.
   setLocaleEncoding utf8
@@ -172,7 +188,7 @@ cChatMigrateInitKey fp key keepKey conf background ctrl = do
   chatDbOpts <- mobileDbOpts fp key
   confirm <- peekCAString conf
   r <-
-    chatMigrateInitKey chatDbOpts (keepKey /= 0) confirm (background /= 0) >>= \case
+    chatMigrateInitKey chatDbOpts keepKey confirm background queueSize >>= \case
       Right cc -> (newStablePtr cc >>= poke ctrl) $> DBMOk
       Left e -> pure e
   newCStringFromLazyBS $ J.encode r
@@ -240,12 +256,21 @@ cChatPasswordHash cPwd cSalt = do
 cChatValidName :: CString -> IO CString
 cChatValidName cName = newCString . mkValidName =<< peekCString cName
 
+-- | canonical form of a code that passes its check character, empty string if it does not parse
+cChatParseBadgeCode :: CString -> IO CString
+cChatParseBadgeCode cCode = do
+  code <- safeDecodeUtf8 <$> B.packCString cCode
+  newCStringFromBS $ maybe "" (encodeUtf8 . badgeCodeText) $ parseBadgeCode code
+
 -- | returns length of JSON encoded string
 cChatJsonLength :: CString -> IO CInt
 cChatJsonLength s = fromIntegral . subtract 2 . LB.length . J.encode . safeDecodeUtf8 <$> B.packCString s
 
-mobileChatOpts :: ChatDbOpts -> ChatOpts
-mobileChatOpts dbOptions =
+mobileQueueSize :: Int
+mobileQueueSize = 4096
+
+mobileChatOpts :: ChatDbOpts -> Natural -> ChatOpts
+mobileChatOpts dbOptions tbqSize =
   ChatOpts
     { coreOptions =
         CoreChatOpts
@@ -258,7 +283,8 @@ mobileChatOpts dbOptions =
             logServerHosts = True,
             logAgent = Nothing,
             logFile = Nothing,
-            tbqSize = 4096,
+            tbqSize,
+            maxChats = 5000,
             deviceName = Nothing,
             chatRelay = False,
             webPreviewConfig = Nothing,
@@ -302,18 +328,19 @@ getActiveUser_ st = find activeUser <$> withTransaction st getUsers
 chatMigrateInit :: String -> ScrubbedBytes -> String -> IO (Either DBMigrationResult ChatController)
 chatMigrateInit dbFilePrefix dbKey confirm = do
   let chatDBOpts = ChatDbOpts {dbFilePrefix, dbKey, trackQueries = DB.TQSlow 5000, vacuumOnMigration = True}
-  chatMigrateInitKey chatDBOpts False confirm False
+  chatMigrateInitKey chatDBOpts False confirm False mobileQueueSize
 #endif
 
-chatMigrateInitKey :: ChatDbOpts -> Bool -> String -> Bool -> IO (Either DBMigrationResult ChatController)
-chatMigrateInitKey chatDbOpts keepKey confirm backgroundMode = runExceptT $ do
+chatMigrateInitKey :: ChatDbOpts -> Bool -> String -> Bool -> Int -> IO (Either DBMigrationResult ChatController)
+chatMigrateInitKey chatDbOpts keepKey confirm backgroundMode queueSize = runExceptT $ do
+  unless (queueSize > 0) $ throwError DBMInvalidQueueSize
   confirmMigrations <- liftEitherWith (const DBMInvalidConfirmation) $ strDecode $ B.pack confirm
   let migrationConfig = MigrationConfig confirmMigrations (Just "")
   chatStore <- migrate createChatStore (toDBOpts chatDbOpts chatSuffix keepKey chatDBFunctions) migrationConfig
   agentStore <- migrate createAgentStore (toDBOpts chatDbOpts agentSuffix keepKey []) migrationConfig
   ExceptT $ initialize chatStore ChatDatabase {chatStore, agentStore}
   where
-    opts = mobileChatOpts $ removeDbKey chatDbOpts
+    opts = mobileChatOpts (removeDbKey chatDbOpts) (fromIntegral queueSize)
     initialize st db = do
       user_ <- liftIO $ getActiveUser_ st
       first DBMAgentError <$> newChatController db user_ defaultMobileConfig opts backgroundMode

src/Simplex/Chat/Options.hs

@@ -67,6 +67,7 @@ data CoreChatOpts = CoreChatOpts
     logAgent :: Maybe LogLevel,
     logFile :: Maybe FilePath,
     tbqSize :: Natural,
+    maxChats :: Int,
     deviceName :: Maybe Text,
     chatRelay :: Bool,
     webPreviewConfig :: Maybe WebPreviewConfig,
@@ -234,6 +235,15 @@ coreChatOptsP appDir defaultDbName = do
           <> value 1024
           <> showDefault
       )
+  maxChats <-
+    option
+      auto
+      ( long "max-chats"
+          <> metavar "COUNT"
+          <> help "Max number of chats loaded by chat list API"
+          <> value 5000
+          <> showDefault
+      )
   deviceName <-
     optional $
       strOption
@@ -340,6 +350,7 @@ coreChatOptsP appDir defaultDbName = do
         logAgent = if logAgent || logLevel == CLLDebug then Just $ agentLogLevel logLevel else Nothing,
         logFile,
         tbqSize,
+        maxChats,
         deviceName,
         chatRelay,
         webPreviewConfig,

src/Simplex/Chat/PaymentService.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.PaymentService
+  ( ServiceInvoice (..),
+    ServicePayment (..),
+    module Simplex.Chat.PaymentService.Types,
+  ) where
+
+import qualified Data.Aeson.TH as JQ
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Simplex.Chat.PaymentService.Types
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
+
+data ServiceInvoice = ServiceInvoice
+  { invoiceId :: InvoiceId,
+    price :: CurrencyAmount,
+    discount :: Maybe CurrencyAmount, -- discount amount from the price
+    credit :: Maybe CurrencyAmount, -- credit for upgrade
+    amount :: CurrencyAmount, -- price - discount - credit
+    currency :: Text,
+    expiresAt :: UTCTime,
+    paymentTo :: ServicePaymentDestination
+  }
+  deriving (Show)
+
+data ServicePayment
+  = SPApple {jws :: Text}
+  | SPGoogle {token :: Text}
+  | SPInvoice {invoiceId :: InvoiceId}
+  | SPReceipt {receipt :: Text} -- transfer of unissued months
+  deriving (Show)
+
+$(JQ.deriveJSON defaultJSON ''ServiceInvoice)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SP") ''ServicePayment)

src/Simplex/Chat/PaymentService/Types.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.PaymentService.Types
+  ( CurrencyAmount (..),
+    InvoiceId (..),
+    PaymentId (..),
+    PaymentProvider (..),
+    CardProvider (..),
+    CryptoCurrency (..),
+    ServicePaymentMethod (..),
+    ServicePaymentDestination (..),
+    InvoiceStatus (..),
+    StoredInvoice (..),
+    StoredPayment (..),
+    PaymentFunding (..),
+    PaymentTerm (..),
+    PaymentStatus (..),
+  ) where
+
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson.TH as JQ
+import Data.ByteString.Char8 (ByteString)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Data.Word (Word32)
+import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON)
+
+-- USD etc. are in minor units, following Stripe etc. convention
+newtype CurrencyAmount = CurrencyAmount Word32
+  deriving (Eq, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+-- confirmed
+newtype InvoiceId = InvoiceId Text
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
+
+-- confirmed
+newtype PaymentId = PaymentId Text
+  deriving newtype (Eq, Show)
+
+-- confirmed
+data PaymentProvider = PPApple | PPGoogle | PPStripe | PPCrypto | PPCode | PPReceipt
+  deriving (Eq, Show)
+
+data CardProvider = CPStripe
+  deriving (Eq, Show)
+
+data CryptoCurrency = CCBtc | CCXmr
+  deriving (Eq, Show)
+
+data ServicePaymentMethod
+  = SPMCard {provider :: CardProvider}
+  | SPMCrypto {currency :: CryptoCurrency}
+  deriving (Eq, Show)
+
+data ServicePaymentDestination
+  = SPDCard
+      { provider :: CardProvider,
+        url :: Text
+      }
+  | SPDCrypto
+      { currency :: CryptoCurrency,
+        address :: Text,
+        cryptoAmount :: Text
+      }
+  deriving (Show)
+
+-- confirmed
+data InvoiceStatus = ISOpen | ISPaid | ISExpired
+  deriving (Eq, Show)
+
+-- confirmed
+data StoredInvoice = StoredInvoice
+  { invoiceId :: InvoiceId,
+    price :: CurrencyAmount,
+    discountAmount :: CurrencyAmount,
+    creditAmount :: CurrencyAmount,
+    amount :: CurrencyAmount, -- price - discount - credit
+    currency :: Text,
+    paymentTo :: ServicePaymentDestination,
+    expiresAt :: UTCTime,
+    status :: InvoiceStatus,
+    createdAt :: UTCTime,
+    updatedAt :: UTCTime
+  }
+  deriving (Show)
+
+-- to review
+data StoredPayment = StoredPayment
+  { paymentId :: PaymentId,
+    funding :: PaymentFunding,
+    term :: PaymentTerm,
+    status :: PaymentStatus,
+    createdAt :: UTCTime,
+    updatedAt :: UTCTime
+  }
+  deriving (Show)
+
+-- to review
+data PaymentFunding
+  = PFInvoice
+      { invoiceId :: InvoiceId,
+        providerRef :: Text,
+        amount :: CurrencyAmount,
+        currency :: Text,
+        receiptCode :: Maybe Text -- client; the service holds its hash
+      }
+  | PFApple
+      { providerRef :: Text,
+        amount :: CurrencyAmount,
+        currency :: Text,
+        evidence :: Maybe ByteString -- client only
+      }
+  | PFGoogle
+      { providerRef :: Text,
+        amount :: CurrencyAmount,
+        currency :: Text,
+        evidence :: Maybe ByteString -- client only
+      }
+  | PFCode
+  | PFReceipt
+  deriving (Show)
+
+-- to review
+data PaymentTerm
+  = PTOneOff
+  | PTSubscription
+      { renewsAt :: UTCTime,
+        graceUntil :: Maybe UTCTime,
+        cancelled :: Bool
+      }
+  deriving (Show)
+
+-- to review
+data PaymentStatus = PSPending | PSSettled | PSFailed {exception :: Text}
+  deriving (Show)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CP") ''CardProvider)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CC") ''CryptoCurrency)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SPM") ''ServicePaymentMethod)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SPD") ''ServicePaymentDestination)

src/Simplex/Chat/Protocol.hs

@@ -50,7 +50,7 @@ import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
 import Data.Type.Equality
 import Data.Typeable (Typeable)
 import Data.Word (Word16, Word32)
-import Simplex.Chat.Badges (LocalBadge)
+import Simplex.Chat.Badges (BadgeProof, LocalBadge)
 import Simplex.Chat.Call
 import Simplex.Chat.Options.DB (FromField (..), ToField (..))
 import Simplex.Chat.Types
@@ -86,12 +86,13 @@ import Simplex.Messaging.Version hiding (version)
 -- 17 - allow host voice messages during member approval regardless of group voice setting (2026-02-10)
 -- 18 - relay web capabilities (2026-05-31)
 -- 19 - group roster (2026-06-18)
+-- 20 - p2p group member keys for signing (2026-07-26)
 
 -- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig.
 -- This indirection is needed for backward/forward compatibility testing.
 -- Testing with real app versions is still needed, as tests use the current code with different version ranges, not the old code.
 currentChatVersion :: VersionChat
-currentChatVersion = VersionChat 19
+currentChatVersion = VersionChat 20
 
 -- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
 supportedChatVRange :: VersionRangeChat
@@ -135,6 +136,10 @@ relayWebCapVersion = VersionChat 18
 groupRosterVersion :: VersionChat
 groupRosterVersion = VersionChat 19
 
+-- members sign messages in p2p groups; member keys are distributed for verification
+groupMemberKeyVersion :: VersionChat
+groupMemberKeyVersion = VersionChat 20
+
 data ConnectionEntity
   = RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
   | RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
@@ -446,7 +451,7 @@ signChatMsgBody MsgSigning {bindingTag, bindingData, keyRef, privKey} msgBody =
 
 data ChatMsgEvent (e :: MsgEncoding) where
   XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
-  XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr, fileExpires :: Maybe UTCTime} -> ChatMsgEvent 'Json
+  XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr, fileExpires :: Maybe UTCTime, fileBadge :: Maybe BadgeProof} -> ChatMsgEvent 'Json
   XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MsgMention, ttl :: Maybe Int, live :: Maybe Bool, scope :: Maybe MsgScope, asGroup :: Maybe Bool} -> ChatMsgEvent 'Json
   XMsgDel :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope, onlyHistory :: Bool} -> ChatMsgEvent 'Json
   XMsgDeleted :: ChatMsgEvent 'Json
@@ -455,15 +460,15 @@ data ChatMsgEvent (e :: MsgEncoding) where
   XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol
   XFileAcptInv :: SharedMsgId -> Maybe ConnReqInvitation -> String -> ChatMsgEvent 'Json
   XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
-  XInfo :: Profile -> ChatMsgEvent 'Json
-  XContact :: {profile :: Profile, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json
+  XInfo :: {profile :: Profile, memberKey :: Maybe MemberKey} -> ChatMsgEvent 'Json
+  XContact :: {profile :: Profile, memberKey :: Maybe MemberKey, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json
   XMember :: {profile :: Profile, newMemberId :: MemberId, newMemberKey :: MemberKey, viaRelay :: Maybe MemberId} -> ChatMsgEvent 'Json
   XDirectDel :: ChatMsgEvent 'Json
   XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json
-  XGrpAcpt :: MemberId -> ChatMsgEvent 'Json
+  XGrpAcpt :: MemberId -> Maybe MemberKey -> ChatMsgEvent 'Json
   XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json
   XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json
-  XGrpLinkMem :: Profile -> ChatMsgEvent 'Json
+  XGrpLinkMem :: Profile -> Maybe MemberKey -> ChatMsgEvent 'Json
   XGrpLinkAcpt :: GroupAcceptance -> GroupMemberRole -> MemberId -> ChatMsgEvent 'Json
   XGrpRelayInv :: GroupRelayInvitation -> ChatMsgEvent 'Json
   XGrpRelayAcpt :: ShortLinkContact -> RelayCapabilities -> ChatMsgEvent 'Json
@@ -522,7 +527,7 @@ isForwardedGroupMsg ev = case ev of
   XMsgDel {} -> True
   XMsgReact {} -> True
   XFileCancel _ -> True
-  XInfo _ -> True
+  XInfo {} -> True
   XGrpRelayNew _ -> True
   XGrpMemNew {} -> True
   XGrpMemRole {} -> True
@@ -1248,15 +1253,15 @@ toCMEventTag msg = case msg of
   XFileAcpt _ -> XFileAcpt_
   XFileAcptInv {} -> XFileAcptInv_
   XFileCancel _ -> XFileCancel_
-  XInfo _ -> XInfo_
+  XInfo {} -> XInfo_
   XContact {} -> XContact_
   XMember {} -> XMember_
   XDirectDel -> XDirectDel_
   XGrpInv _ -> XGrpInv_
-  XGrpAcpt _ -> XGrpAcpt_
+  XGrpAcpt {} -> XGrpAcpt_
   XGrpLinkInv _ -> XGrpLinkInv_
   XGrpLinkReject _ -> XGrpLinkReject_
-  XGrpLinkMem _ -> XGrpLinkMem_
+  XGrpLinkMem {} -> XGrpLinkMem_
   XGrpLinkAcpt {} -> XGrpLinkAcpt_
   XGrpRelayInv _ -> XGrpRelayInv_
   XGrpRelayAcpt {} -> XGrpRelayAcpt_
@@ -1342,6 +1347,7 @@ requiresSignature = \case
   XGrpRelayNew_ -> True
   XGrpRoster_ -> True
   XInfo_ -> True
+  XGrpLinkMem_ -> True
   _ -> False
 
 -- | Content events a member may sign (XMsgNew opt-in; XMsgUpdate/XMsgDel when the target was signed).
@@ -1391,7 +1397,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
     msg :: CMEventTag 'Json -> Either String (ChatMsgEvent 'Json)
     msg = \case
       XMsgNew_ -> XMsgNew <$> JT.parseEither parseJSON (J.Object params)
-      XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr" <*> opt "fileExpires"
+      XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr" <*> opt "fileExpires" <*> opt "fileBadge"
       XMsgUpdate_ -> do
         msgId' <- p "msgId"
         content <- p "content"
@@ -1408,22 +1414,23 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
       XFileAcpt_ -> XFileAcpt <$> p "fileName"
       XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> opt "fileConnReq" <*> p "fileName"
       XFileCancel_ -> XFileCancel <$> p "msgId"
-      XInfo_ -> XInfo <$> p "profile"
+      XInfo_ -> XInfo <$> p "profile" <*> opt "memberKey"
       XContact_ -> do
         profile <- p "profile"
+        memberKey <- opt "memberKey"
         contactReqId <- opt "contactReqId"
         welcomeMsgId <- opt "welcomeMsgId"
         reqMsgId <- opt "msgId"
         reqContent <- opt "content"
         let requestMsg = (,) <$> reqMsgId <*> reqContent
-        pure XContact {profile, contactReqId, welcomeMsgId, requestMsg}
+        pure XContact {profile, memberKey, contactReqId, welcomeMsgId, requestMsg}
       XMember_ -> XMember <$> p "profile" <*> p "newMemberId" <*> p "newMemberKey" <*> opt "viaRelay"
       XDirectDel_ -> pure XDirectDel
       XGrpInv_ -> XGrpInv <$> p "groupInvitation"
-      XGrpAcpt_ -> XGrpAcpt <$> p "memberId"
+      XGrpAcpt_ -> XGrpAcpt <$> p "memberId" <*> opt "memberKey"
       XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation"
       XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection"
-      XGrpLinkMem_ -> XGrpLinkMem <$> p "profile"
+      XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" <*> opt "memberKey"
       XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "acceptance" <*> p "role" <*> p "memberId"
       XGrpRelayInv_ -> XGrpRelayInv <$> p "groupRelayInvitation"
       XGrpRelayAcpt_ -> XGrpRelayAcpt <$> p "relayLink" <*> (fromMaybe defaultRelayCapabilities <$> opt "relayCap")
@@ -1482,7 +1489,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
       XMsgNew mc -> case toJSON mc of
         J.Object obj -> obj
         _ -> JM.empty
-      XMsgFileDescr msgId' fileDescr fileExpires -> o $ ("fileExpires" .=? fileExpires) ["msgId" .= msgId', "fileDescr" .= fileDescr]
+      XMsgFileDescr msgId' fileDescr fileExpires fileBadge -> o $ ("fileExpires" .=? fileExpires) $ ("fileBadge" .=? fileBadge) ["msgId" .= msgId', "fileDescr" .= fileDescr]
       XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope, asGroup} -> o $ ("asGroup" .=? asGroup) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content]
       XMsgDel msgId' memberId scope onlyHistory -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) $ ("onlyHistory" .=? justTrue onlyHistory) ["msgId" .= msgId']
       XMsgDeleted -> JM.empty
@@ -1491,15 +1498,15 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
       XFileAcpt fileName -> o ["fileName" .= fileName]
       XFileAcptInv sharedMsgId fileConnReq fileName -> o $ ("fileConnReq" .=? fileConnReq) ["msgId" .= sharedMsgId, "fileName" .= fileName]
       XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId]
-      XInfo profile -> o ["profile" .= profile]
-      XContact {profile, contactReqId, welcomeMsgId, requestMsg} -> o $ ("contactReqId" .=? contactReqId) $ ("welcomeMsgId" .=? welcomeMsgId) $ ("msgId" .=? (fst <$> requestMsg)) $ ("content" .=? (snd <$> requestMsg)) $ ["profile" .= profile]
+      XInfo {profile, memberKey} -> o $ ("memberKey" .=? memberKey) ["profile" .= profile]
+      XContact {profile, memberKey, contactReqId, welcomeMsgId, requestMsg} -> o $ ("contactReqId" .=? contactReqId) $ ("welcomeMsgId" .=? welcomeMsgId) $ ("msgId" .=? (fst <$> requestMsg)) $ ("content" .=? (snd <$> requestMsg)) $ ("memberKey" .=? memberKey) $ ["profile" .= profile]
       XMember {profile, newMemberId, newMemberKey, viaRelay} -> o $ ("viaRelay" .=? viaRelay) ["profile" .= profile, "newMemberId" .= newMemberId, "newMemberKey" .= newMemberKey]
       XDirectDel -> JM.empty
       XGrpInv groupInv -> o ["groupInvitation" .= groupInv]
-      XGrpAcpt memId -> o ["memberId" .= memId]
+      XGrpAcpt memId memberKey -> o $ ("memberKey" .=? memberKey) ["memberId" .= memId]
       XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv]
       XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct]
-      XGrpLinkMem profile -> o ["profile" .= profile]
+      XGrpLinkMem profile memberKey -> o $ ("memberKey" .=? memberKey) ["profile" .= profile]
       XGrpLinkAcpt acceptance role memberId -> o ["acceptance" .= acceptance, "role" .= role, "memberId" .= memberId]
       XGrpRelayInv groupRelayInv -> o ["groupRelayInvitation" .= groupRelayInv]
       XGrpRelayAcpt relayLink relayCap -> o ["relayLink" .= relayLink, "relayCap" .= relayCap]

src/Simplex/Chat/Remote.hs

@@ -75,11 +75,11 @@ remoteFilesFolder = "simplex_v1_files"
 
 -- when acting as host
 minRemoteCtrlVersion :: AppVersion
-minRemoteCtrlVersion = AppVersion [7, 0, 0, 11]
+minRemoteCtrlVersion = AppVersion [7, 1, 0, 5]
 
 -- when acting as controller
 minRemoteHostVersion :: AppVersion
-minRemoteHostVersion = AppVersion [7, 0, 0, 11]
+minRemoteHostVersion = AppVersion [7, 1, 0, 5]
 
 currentAppVersion :: AppVersion
 currentAppVersion = AppVersion SC.version

src/Simplex/Chat/Store/Badges.hs

@@ -0,0 +1,356 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Simplex.Chat.Store.Badges
+  ( BadgeCodeRedemption (..),
+    UserBadgePurchase (..),
+    getUserBadgePurchase,
+    getBadgePurchase,
+    userHasBadge,
+    setBadgeAlertAcked,
+    clearShownBadge,
+    getBadgeCodeRedemption,
+    createBadgeCodeRedemption,
+    deleteBadgeCodeRedemption,
+    createCodeBadgePurchase,
+    getCodeBadgePurchase,
+    storeBadgeIssuance,
+    getLatestIssuedCredential,
+    storeBadgeStatement,
+    getBadgeLedgerLastEntry,
+    getBadgeLedger,
+    getBadgeLedgerEntryId,
+  )
+where
+
+import Control.Concurrent.STM (TVar, atomically)
+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, mapMaybe)
+import Data.Text (Text)
+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, BadgePurchaseStatus (..))
+import Simplex.Chat.Store.Shared (insertedRowId)
+import Simplex.Chat.Types
+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 (decodeJSON, maybeFirstRow, maybeFirstRow', safeDecodeUtf8)
+
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (Only (..), (:.) (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+#else
+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,
+    purchaseKey :: C.PublicKeyEd25519,
+    purchasePrivKey :: C.PrivateKeyEd25519,
+    masterKey :: BadgeMasterKey
+  }
+
+getBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO (Maybe BadgeCodeRedemption)
+getBadgeCodeRedemption db User {userId} code =
+  maybeFirstRow toRedemption $
+    DB.query
+      db
+      [sql|
+        SELECT badge_code_redemption_id, purchase_key, purchase_priv_key, master_key
+        FROM badge_code_redemptions
+        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 g User {userId} code now = do
+  (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g
+  masterKey@(BadgeMasterKey mk) <- generateMasterKey g
+  DB.execute
+    db
+    [sql|
+      INSERT INTO badge_code_redemptions (user_id, code, purchase_key, purchase_priv_key, master_key, created_at)
+      VALUES (?,?,?,?,?,?)
+    |]
+    (userId, code, purchaseKey, purchasePrivKey, Binary mk, now)
+  redemptionId <- insertedRowId db
+  pure BadgeCodeRedemption {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 =
+  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 = ?)
+    |]
+    (redemptionId, redemptionId)
+
+-- | '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 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 (?,?,?,?,?,?,?,?,?,?)
+        |]
+        (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)
+      DB.execute
+        db
+        [sql|
+          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, 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 -> User -> Int64 -> BadgeAlertKind -> Text -> Maybe UTCTime -> IO ()
+setBadgeAlertAcked db User {userId} badgePurchaseId kind episode snoozeUntil =
+  DB.execute
+    db
+    "UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?, alert_snooze_until = ? WHERE badge_purchase_id = ? AND user_id = ?"
+    (kind, episode, snoozeUntil, badgePurchaseId, userId)
+
+-- | 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 -> BadgeType -> Maybe StatementEntry -> [StatementEntry] -> UTCTime -> IO ()
+storeBadgeStatement db badgePurchaseId badgeType tip entries now =
+  mapM_ storeEntry $ balanceChecked now badgeType 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 toStatementEntry $
+    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)
+
+-- | Oldest first. A row whose type this version cannot rebuild is left out, as it is from the tip.
+getBadgeLedger :: DB.Connection -> User -> Int64 -> IO [StatementEntry]
+getBadgeLedger db User {userId} badgePurchaseId =
+  mapMaybe toStatementEntry
+    <$> DB.query
+      db
+      [sql|
+        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
+        FROM badge_ledger l
+        JOIN badge_purchases p ON p.badge_purchase_id = l.badge_purchase_id
+        WHERE l.badge_purchase_id = ? AND p.user_id = ?
+        ORDER BY l.entry_id
+      |]
+      (badgePurchaseId, userId)
+
+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_
+
+-- | 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/Connections.hs

@@ -12,6 +12,7 @@
 module Simplex.Chat.Store.Connections
   ( getChatLockEntity,
     getConnectionEntity,
+    getConnectionEntityKeys,
     getConnectionEntityByConnReq,
     getConnectionEntityViaShortLink,
     getContactConnEntityByConnReqHash,
@@ -76,18 +77,23 @@ getChatLockEntity db agentConnId = do
 -- - from receiving: getConnectionEntity, getContactConnEntityByConnReqHash
 -- - from subscribing: getContactConnsToSub, getUCLConnsToSub, getMemberConnsToSub, getPendingConnsToSub
 getConnectionEntity :: DB.Connection -> StoreCxt -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
-getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
+getConnectionEntity db cxt user agentConnId = fst <$> getConnectionEntityKeys db cxt user agentConnId
+
+getConnectionEntityKeys :: DB.Connection -> StoreCxt -> User -> AgentConnId -> ExceptT StoreError IO (ConnectionEntity, Maybe GroupKeysRow)
+getConnectionEntityKeys db cxt user@User {userId, userContactId} agentConnId = do
   c@Connection {connType, entityId} <- getConnection_
   case entityId of
     Nothing ->
       if connType == ConnContact
-        then pure $ RcvDirectMsgConnection c Nothing
+        then pure (RcvDirectMsgConnection c Nothing, Nothing)
         else throwError $ SEInternalError $ "connection " <> show connType <> " without entity"
     Just entId ->
       case connType of
-        ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ entId c
-        ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ entId c
-        ConnUserContact -> UserContactConnection c <$> getUserContact_ entId
+        ConnMember -> do
+          ((gInfo, keysData), m) <- getGroupAndMember_ entId c
+          pure (RcvGroupMsgConnection c gInfo m, Just keysData)
+        ConnContact -> (,Nothing) . RcvDirectMsgConnection c . Just <$> getContactRec_ entId c
+        ConnUserContact -> (,Nothing) . UserContactConnection c <$> getUserContact_ entId
   where
     getConnection_ :: ExceptT StoreError IO Connection
     getConnection_ = ExceptT $ do
@@ -134,7 +140,7 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
           contactRequest = UserContactRequestRef <$> contactRequestId <*> (unBI <$> rejectionSupported_)
           groupDirectInv = toGroupDirectInvitation groupDirectInvRow
        in Contact {contactId, localDisplayName, profile, activeConn, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, preparedContact, contactRequestId, contactRequest, contactGroupMemberId, contactGrpInvSent, groupDirectInv, chatTags, chatItemTTL, uiThemes, chatDeleted, customData}
-    getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
+    getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO ((GroupInfo, GroupKeysRow), GroupMember)
     getGroupAndMember_ groupMemberId c = do
       currentTs <- liftIO getCurrentTime
       gm <-
@@ -178,8 +184,8 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
                   AND mu.member_status NOT IN (?,?,?)
               |]
               (groupMemberId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
-      liftIO $ bitraverse (addGroupChatTags db) pure gm
-    toGroupAndMember :: UTCTime -> Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
+      liftIO $ bitraverse (\(g, keysData) -> (,keysData) <$> addGroupChatTags db g) pure gm
+    toGroupAndMember :: UTCTime -> Connection -> GroupInfoRow :. GroupMemberRow -> ((GroupInfo, GroupKeysRow), GroupMember)
     toGroupAndMember currentTs c (groupInfoRow :. memberRow) =
       let groupInfo = toGroupInfo currentTs cxt userContactId [] groupInfoRow
           member = toGroupMember currentTs userContactId memberRow

src/Simplex/Chat/Store/ContactRequest.hs

@@ -91,11 +91,12 @@ createOrUpdateContactRequest
             pure $ RSAcceptedRequest cr (REContact ct)
           Nothing ->
             liftIO (getAcceptedBusinessChat xContactId) >>= \case
-              Just gInfo@GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
+              Just (gInfo@GroupInfo {businessChat = Just BusinessChatInfo {customerId}}, keysData) -> do
                 clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
                 cr <- liftIO $ getContactRequestByXContactId xContactId
-                pure $ RSAcceptedRequest cr (REBusinessChat gInfo clientMember)
-              Just GroupInfo {businessChat = Nothing} -> throwError SEInvalidBusinessChatContactRequest
+                gks <- mkGroupKeys db cxt gInfo keysData
+                pure $ RSAcceptedRequest cr (REBusinessChat (GIK gInfo gks) clientMember)
+              Just (GroupInfo {businessChat = Nothing}, _) -> throwError SEInvalidBusinessChatContactRequest
               -- 2) if no legacy accepted contact or business chat was found, next we try to find an existing request
               Nothing ->
                 liftIO (getContactRequestByXContactId xContactId) >>= \case
@@ -131,7 +132,7 @@ createOrUpdateContactRequest
               |]
               (userId, xContactId)
         mapM (addDirectChatTags db) ct_
-      getAcceptedBusinessChat :: XContactId -> IO (Maybe GroupInfo)
+      getAcceptedBusinessChat :: XContactId -> IO (Maybe (GroupInfo, GroupKeysRow))
       getAcceptedBusinessChat xContactId = do
         currentTs <- getCurrentTime
         g_ <-
@@ -140,7 +141,7 @@ createOrUpdateContactRequest
               db
               (groupInfoQuery <> " WHERE g.business_xcontact_id = ? AND g.user_id = ? AND mu.contact_id = ?")
               (xContactId, userId, userContactId)
-        mapM (addGroupChatTags db) g_
+        forM g_ $ \(g, keysData) -> (,keysData) <$> addGroupChatTags db g
       getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest)
       getContactRequestByXContactId xContactId = do
         currentTs <- getCurrentTime
@@ -214,7 +215,7 @@ createOrUpdateContactRequest
                 pure $ RSCurrentRequest Nothing ucr (Just $ REContact ct)
               createBusinessChat = do
                 let groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs $ preferences' user
-                (gInfo@GroupInfo {groupId}, clientMember) <-
+                (gInfo@(GIK GroupInfo {groupId} _), clientMember) <-
                   createBusinessRequestGroup db cxt gVar user cReqChatVRange profile profileId ldn groupPreferences
                 liftIO $
                   DB.execute
@@ -302,11 +303,12 @@ createOrUpdateContactRequest
             ct <- getContact db cxt user contactId
             pure $ Just (REContact ct)
           (Nothing, Just businessGroupId) -> do
-            gInfo <- getGroupInfo db cxt user businessGroupId
+            (gInfo, keysData) <- getGroupInfoRow db cxt user businessGroupId
             case gInfo of
               GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
                 clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
-                pure $ Just (REBusinessChat gInfo clientMember)
+                gks <- mkGroupKeys db cxt gInfo keysData
+                pure $ Just (REBusinessChat (GIK gInfo gks) clientMember)
               _ -> throwError SEInvalidBusinessChatContactRequest
           (Nothing, Nothing) -> pure Nothing
           _ -> throwError $ SEInvalidContactRequestEntity contactRequestId

src/Simplex/Chat/Store/Direct.hs

@@ -188,7 +188,7 @@ createConnReqConnection db userId acId preparedEntity_ cReq cReqHash sLnk xConta
   connId <- insertedRowId db
   case preparedEntity_ of
     -- For relay groups, setPreparedGroupLinkInfo_ is called via updatePreparedRelayedGroup before the relay loop
-    Just (PCEGroup gInfo _) | not (useRelays' gInfo) ->
+    Just (PCEGroup (GIK gInfo _) _) | not (useRelays' gInfo) ->
       setPreparedGroupLinkInfo_ db gInfo cReq cReqHash customUserProfileId Nothing currentTs
     _ -> pure ()
   pure

src/Simplex/Chat/Store/Files.hs

@@ -45,6 +45,9 @@ module Simplex.Chat.Store.Files
     updateSndFileStatus,
     createRcvFileTransfer,
     createRcvGroupFileTransfer,
+    createFileBadgeProof,
+    getFileBadgeProofs,
+    setFileProhibited,
     createRosterRcvFile,
     createRcvStandaloneFileTransfer,
     appendRcvFD,
@@ -86,6 +89,7 @@ import Control.Monad.IO.Class
 import Data.Either (rights)
 import Data.Functor ((<&>))
 import Data.Int (Int64)
+import Data.List (foldl')
 import Data.Maybe (fromMaybe, isJust, listToMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -93,6 +97,7 @@ import Data.Time (addUTCTime)
 import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
 import Data.Type.Equality
 import Data.Word (Word32)
+import Simplex.Chat.Badges (BadgeProof, BadgeProofKind (..), BadgeProofRow, BadgeStatus (..), badgeProofToRow, rowToBadgeProof)
 import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Store.Messages
@@ -180,7 +185,7 @@ getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMs
         <$> (contactName_ <|> memberName_)
 
 createSndFileTransferXFTP :: DB.Connection -> User -> Maybe ContactOrGroup -> CryptoFile -> FileInvitation -> AgentSndFileId -> Maybe FileTransferId -> Integer -> IO FileTransferMeta
-createSndFileTransferXFTP db User {userId} contactOrGroup_ (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize} agentSndFileId xftpRedirectFor chunkSize = do
+createSndFileTransferXFTP db User {userId} contactOrGroup_ (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize, fileBadge} agentSndFileId xftpRedirectFor chunkSize = do
   currentTs <- getCurrentTime
   let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False, cryptoArgs}
   DB.execute
@@ -188,6 +193,7 @@ createSndFileTransferXFTP db User {userId} contactOrGroup_ (CryptoFile filePath
     "INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, redirect_file_id, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
     (maybe (Nothing, Nothing) contactAndGroupIds contactOrGroup_ :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize) :. (xftpRedirectFor, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
   fileId <- insertedRowId db
+  forM_ fileBadge $ createFileBadgeProof db fileId BPKInvitation
   pure FileTransferMeta {fileId, xftpSndFile, xftpRedirectFor, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
 
 createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO ()
@@ -445,8 +451,8 @@ updateSndFileStatus db SndFileTransfer {fileId, connId} status = do
   currentTs <- getCurrentTime
   DB.execute db "UPDATE snd_files SET file_status = ?, updated_at = ? WHERE file_id = ? AND connection_id = ?" (status, currentTs, fileId, connId)
 
-createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
-createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
+createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe FileProhibited -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
+createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr, fileBadge} prohibited_ rcvFileInline chunkSize = do
   currentTs <- liftIO getCurrentTime
   rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
   let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
@@ -456,18 +462,57 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
   fileId <- liftIO $ do
     DB.execute
       db
-      "INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
-      (userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs)
+      "INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_max_size, file_badge_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
+      ((userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol) :. prohibitedRow prohibited_ :. (currentTs, currentTs))
     insertedRowId db
-  liftIO $
+  liftIO $ do
     DB.execute
       db
       "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
       (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs)
-  pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, fileType = FTNormal, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing}
+    forM_ (storedBadge prohibited_ fileBadge) $ createFileBadgeProof db fileId BPKInvitation
+  pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileProhibited = prohibited_, fileStatus = RFSNew, fileType = FTNormal, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing}
 
-createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> Maybe GroupMember -> FileType -> Maybe SharedMsgId -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
-createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ fileType sharedMsgId_ f@FileInvitation {fileName, fileSize, fileDigest, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
+setFileProhibited :: DB.Connection -> User -> Int64 -> FileProhibited -> IO ()
+setFileProhibited db User {userId} fileId FileProhibited {maxSize, badgeStatus} = do
+  currentTs <- getCurrentTime
+  DB.execute
+    db
+    "UPDATE files SET file_max_size = ?, file_badge_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?"
+    (maxSize, badgeStatus, currentTs, userId, fileId)
+
+prohibitedRow :: Maybe FileProhibited -> (Maybe Integer, Maybe BadgeStatus)
+prohibitedRow = \case
+  Just FileProhibited {maxSize, badgeStatus} -> (Just maxSize, badgeStatus)
+  Nothing -> (Nothing, Nothing)
+
+-- a proof that did not verify is not stored - files.file_badge_status records that it failed
+storedBadge :: Maybe FileProhibited -> Maybe BadgeProof -> Maybe BadgeProof
+storedBadge prohibited_ badge_ = case prohibited_ of
+  Just FileProhibited {badgeStatus = Just st} | st /= BSActive -> Nothing
+  _ -> badge_
+
+createFileBadgeProof :: DB.Connection -> Int64 -> BadgeProofKind -> BadgeProof -> IO ()
+createFileBadgeProof db fileId kind badge = do
+  currentTs <- getCurrentTime
+  DB.execute
+    db
+    [sql|
+      INSERT INTO file_badge_proofs (file_id, proof_kind, badge_proof, badge_pres_header, badge_key_idx, badge_type, badge_expiry, badge_extra, created_at, updated_at)
+      VALUES (?,?,?,?,?,?,?,?,?,?)
+      ON CONFLICT (file_id, proof_kind) DO UPDATE SET
+        badge_proof = excluded.badge_proof,
+        badge_pres_header = excluded.badge_pres_header,
+        badge_key_idx = excluded.badge_key_idx,
+        badge_type = excluded.badge_type,
+        badge_expiry = excluded.badge_expiry,
+        badge_extra = excluded.badge_extra,
+        updated_at = excluded.updated_at
+    |]
+    ((fileId, kind) :. badgeProofToRow badge :. (currentTs, currentTs))
+
+createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> Maybe GroupMember -> FileType -> Maybe SharedMsgId -> FileInvitation -> Maybe FileProhibited -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
+createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ fileType sharedMsgId_ f@FileInvitation {fileName, fileSize, fileDigest, fileConnReq, fileInline, fileDescr, fileBadge} prohibited_ rcvFileInline chunkSize = do
   currentTs <- liftIO getCurrentTime
   rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
   let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
@@ -479,15 +524,16 @@ createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gNam
   fileId <- liftIO $ do
     DB.execute
       db
-      "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
-      ((userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, fileType, sharedMsgId_, currentTs, currentTs) :. Only fileDigest)
+      "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest, file_max_size, file_badge_status) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
+      ((userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, fileType, sharedMsgId_, currentTs, currentTs) :. Only fileDigest :. prohibitedRow prohibited_)
     insertedRowId db
-  liftIO $
+  liftIO $ do
     DB.execute
       db
       "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
       (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, grpMemberId_, rfdId, currentTs, currentTs)
-  pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, fileType, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = grpMemberId_, cryptoArgs = Nothing}
+    forM_ (storedBadge prohibited_ fileBadge) $ createFileBadgeProof db fileId BPKInvitation
+  pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileProhibited = prohibited_, fileStatus = RFSNew, fileType, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = grpMemberId_, cryptoArgs = Nothing}
 
 -- Roster scratch file owned by a per-source transfer: group_member_id is the delivering relay (so chunk
 -- streams from different relays are distinct files), roster_transfer_id links to the metadata record.
@@ -506,7 +552,7 @@ createRosterRcvFile db userId GroupInfo {groupId} src@GroupMember {localDisplayN
       db
       "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
       (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, grpMemberId_, currentTs, currentTs)
-  pure RcvFileTransfer {fileId, xftpRcvFile = Nothing, fileInvitation = f, fileStatus = RFSNew, fileType = FTRoster, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = Just grpMemberId_, cryptoArgs = Nothing}
+  pure RcvFileTransfer {fileId, xftpRcvFile = Nothing, fileInvitation = f, fileProhibited = Nothing, fileStatus = RFSNew, fileType = FTRoster, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = Just grpMemberId_, cryptoArgs = Nothing}
 
 createRcvStandaloneFileTransfer :: DB.Connection -> UserId -> CryptoFile -> Int64 -> Word32 -> ExceptT StoreError IO Int64
 createRcvStandaloneFileTransfer db userId (CryptoFile filePath cfArgs_) fileSize chunkSize = do
@@ -586,7 +632,7 @@ rcvFileDescrWithinLimits partNo descrText =
     && T.length descrText <= maxRcvFileDescrTextLength
 
 getRcvFileDescrByRcvFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
-getRcvFileDescrByRcvFileId db fileId = do
+getRcvFileDescrByRcvFileId db fileId =
   liftIO (getRcvFileDescrByRcvFileId_ db fileId) >>= \case
     Nothing -> throwError $ SERcvFileDescrNotFound fileId
     Just rfd -> pure rfd
@@ -625,6 +671,19 @@ getRcvFileDescrBySndFileId_ db fileId =
       |]
       (Only fileId)
 
+getFileBadgeProofs :: DB.Connection -> Int64 -> IO (Maybe BadgeProof, Maybe BadgeProof)
+getFileBadgeProofs db fileId = foldl' addProof (Nothing, Nothing) <$> DB.query db q (Only fileId)
+  where
+    q =
+      [sql|
+        SELECT proof_kind, badge_proof, badge_pres_header, badge_key_idx, badge_type, badge_expiry, badge_extra
+        FROM file_badge_proofs
+        WHERE file_id = ?
+      |]
+    addProof (inv_, descr_) (Only kind :. row) = case kind of
+      BPKInvitation -> (rowToBadgeProof row, descr_)
+      BPKDescription -> (inv_, rowToBadgeProof row)
+
 toRcvFileDescr :: (Int64, Text, Int, BoolInt) -> RcvFileDescr
 toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, BI fileDescrComplete) =
   RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete}
@@ -652,7 +711,8 @@ getRcvFileTransfer_ db userId fileId = do
           SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
             f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
             f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline,
-            r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest
+            r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest,
+            f.file_max_size, f.file_badge_status
           FROM rcv_files r
           JOIN files f USING (file_id)
           LEFT JOIN contacts cs ON cs.contact_id = f.contact_id
@@ -666,9 +726,9 @@ getRcvFileTransfer_ db userId fileId = do
   where
     rcvFileTransfer ::
       Maybe RcvFileDescr ->
-      (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. (Maybe ContactName, FileType, Maybe FileDigest) ->
+      (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. (Maybe ContactName, FileType, Maybe FileDigest, Maybe Integer, Maybe BadgeStatus) ->
       ExceptT StoreError IO RcvFileTransfer
-    rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. (groupName_, fileType, fileDigest_)) =
+    rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. (groupName_, fileType, fileDigest_, fileMaxSize_, fileBadgeStatus_)) =
       case contactName_ <|> memberName_ <|> groupName_ <|> standaloneName_ of
         Nothing -> throwError $ SERcvFileInvalid fileId
         Just name ->
@@ -683,10 +743,11 @@ getRcvFileTransfer_ db userId fileId = do
           (Just _, Just _) -> Just "" -- filePath marks files that are accepted from contact or, in this case, set by createRcvDirectFileTransfer
           _ -> Nothing
         ft senderDisplayName fileStatus =
-          let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = fileDigest_, fileConnReq, fileInline, fileDescr = Nothing}
+          let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = fileDigest_, fileConnReq, fileInline, fileDescr = Nothing, fileBadge = Nothing}
+              fileProhibited = (\maxSize -> FileProhibited {maxSize, badgeStatus = fileBadgeStatus_}) <$> fileMaxSize_
               cryptoArgs = CFArgs <$> fileKey <*> fileNonce
               xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted, userApprovedRelays}) <$> rfd_
-           in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, fileType, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs}
+           in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileProhibited, fileStatus, fileType, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs}
         filePath = case filePath_ of
           Nothing -> throwError $ SERcvFileInvalid fileId
           Just fp -> pure fp

src/Simplex/Chat/Store/Groups.hs

@@ -40,6 +40,7 @@ module Simplex.Chat.Store.Groups
     createGroupRejectedViaLink,
     setGroupInvitationChatItemId,
     getGroup,
+    getGroupKeys_,
     getGroupInfoByUserContactLinkConnReq,
     getGroupInfoViaUserTarget,
     getGroupViaShortLinkToConnect,
@@ -107,6 +108,8 @@ module Simplex.Chat.Store.Groups
     deleteRosterTransfer,
     deleteGroupRosterTransfers,
     setGroupMemberKeyRole,
+    setUserMemberKey,
+    setMemberPubKey,
     setGroupMemberVerified,
     createRelayForOwner,
     getCreateRelayForMember,
@@ -142,7 +145,7 @@ module Simplex.Chat.Store.Groups
     updatePreparedRelayedGroup,
     updatePublicMemberCount,
     setPublicMemberCount,
-    updateGroupMemberKeys,
+    setGroupRootKey,
     updateRelayGroupKeys,
     updateGroupMemberStatus,
     updateGroupMemberStatusById,
@@ -374,24 +377,24 @@ setGroupLinkShortLink db gLnk@GroupLink {userContactLinkId, connLinkContact = CC
   pure gLnk {connLinkContact = CCLink connFullLink (Just shortLink), shortLinkDataSet = True, shortLinkLargeDataSet = BoolDef True}
 
 -- | creates completely new group with a single member - the current user
-createNewGroup :: DB.Connection -> StoreCxt -> User -> GroupProfile -> Maybe Profile -> Bool -> MemberId -> Maybe GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
-createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays memberId groupKeys publicMemberCount_ = ExceptT $ do
+createNewGroup :: DB.Connection -> StoreCxt -> User -> GroupProfile -> Maybe Profile -> MemberId -> GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
+createNewGroup db cxt user@User {userId} groupProfile incognitoProfile memberId groupKeys publicMemberCount_ = ExceptT $ do
   let GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission} = groupProfile
       (groupType_, groupLink_, publicGroupId_) = case publicGroup of
         Just PublicGroupProfile {groupType, groupLink, publicGroupId} -> (Just groupType, Just groupLink, Just publicGroupId)
         Nothing -> (Nothing, Nothing, Nothing)
       fullGroupPreferences = mergeGroupPreferences groupPreferences
+      useRelays = isPublicGroup groupKeys
       rosterVersion0 = if useRelays then Just (VersionRoster 0) else Nothing
   currentTs <- getCurrentTime
   customUserProfileId <- mapM (createIncognitoProfile_ db userId currentTs) incognitoProfile
   withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
-    let (rootPrivKey_, rootPubKey_, memberPrivKey_) = case groupKeys of
-          Nothing -> (Nothing, Nothing, Nothing)
-          Just GroupKeys {groupRootKey, memberPrivKey} ->
-            let (rpk, rpub) = case groupRootKey of
-                  GRKPrivate pk -> (Just pk, Nothing)
-                  GRKPublic k -> (Nothing, Just k)
-             in (rpk, rpub, Just memberPrivKey)
+    let (rootPrivKey_, rootPubKey_) = case groupKeys of
+          GKPublicGroup {groupRootKey} -> case groupRootKey of
+            GRKPrivate pk -> (Just pk, Nothing)
+            GRKPublic k -> (Nothing, Just k)
+          _ -> (Nothing, Nothing)
+        memberPrivKey_ = Just $ memberPrivKey groupKeys
     groupId <- liftIO $ do
       DB.execute
         db
@@ -419,7 +422,7 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
             :. (rootPrivKey_, rootPubKey_, memberPrivKey_, publicMemberCount_, rosterVersion0)
         )
       insertedRowId db
-    let memberPubKey = C.publicKey . memberPrivKey <$> groupKeys
+    let memberPubKey = Just $ C.publicKey $ memberPrivKey groupKeys
     membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole memberId GROwner) GCUserMember GSMemCreator IBUser customUserProfileId memberPubKey currentTs (vr cxt)
     let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
     pure
@@ -447,18 +450,17 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
           customData = Nothing,
           membersRequireAttention = 0,
           viaGroupLinkUri = Nothing,
-          groupKeys,
           groupDomainVerified = Nothing
         }
 
 -- | creates a new group record for the group the current user was invited to, or returns an existing one
-createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
-createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
-createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile, business} incognitoProfileId = do
+createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> C.KeyPairEd25519 -> ExceptT StoreError IO (GroupInfoKeys, GroupMemberId)
+createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ _ = throwError $ SEContactNotReady localDisplayName
+createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, fromMemberKey, invitedMember, connRequest, groupProfile, business} incognitoProfileId memberKeys = do
   liftIO getInvitationGroupId_ >>= \case
     Nothing -> createGroupInvitation_
     Just gId -> do
-      gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db cxt user gId
+      GIK gInfo@GroupInfo {membership, groupProfile = p'} gks <- getGroupInfoKeys db cxt user gId
       hostId <- getHostMemberId_ db user gId
       let GroupMember {groupMemberId, memberId, memberRole} = membership
           MemberIdRole {memberId = invMemberId, memberRole = invMemberRole} = invitedMember
@@ -468,13 +470,13 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
         if p' == groupProfile
           then pure gInfo
           else updateGroupProfile db user gInfo groupProfile
-      pure (gInfo', hostId)
+      pure (GIK gInfo' gks, hostId)
   where
     getInvitationGroupId_ :: IO (Maybe Int64)
     getInvitationGroupId_ =
       maybeFirstRow fromOnly $
         DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId)
-    createGroupInvitation_ :: ExceptT StoreError IO (GroupInfo, GroupMemberId)
+    createGroupInvitation_ :: ExceptT StoreError IO (GroupInfoKeys, GroupMemberId)
     createGroupInvitation_ = do
       let GroupProfile {displayName, fullName, shortDescr, description, image, groupPreferences, memberAdmission} = groupProfile
           fullGroupPreferences = mergeGroupPreferences groupPreferences
@@ -492,14 +494,14 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
               [sql|
                 INSERT INTO groups
                   (group_profile_id, local_display_name, inv_queue_info, user_id, enable_ntfs,
-                   created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, business_member_id, customer_member_id)
-                VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
+                   created_at, updated_at, chat_ts, user_member_profile_sent_at, member_priv_key, business_chat, business_member_id, customer_member_id)
+                VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
               |]
-              ((profileId, localDisplayName, connRequest, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. businessChatInfoRow business)
+              ((profileId, localDisplayName, connRequest, userId, BI True, currentTs, currentTs, currentTs, currentTs, snd memberKeys) :. businessChatInfoRow business)
             insertedRowId db
           let hostVRange = adjustedMemberVRange (vr cxt) peerChatVRange
-          GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing Nothing currentTs hostVRange
-          membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId Nothing currentTs (vr cxt)
+          GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing ((\(MemberKey k) -> k) <$> fromMemberKey) currentTs hostVRange
+          membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId (Just $ fst memberKeys) currentTs (vr cxt)
           let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
           pure
             ( GroupInfo
@@ -526,9 +528,9 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
                   customData = Nothing,
                   membersRequireAttention = 0,
                   viaGroupLinkUri = Nothing,
-                  groupKeys = Nothing,
                   groupDomainVerified = Nothing
-                },
+                }
+                `GIK` GKGroup {memberPrivKey = snd memberKeys},
               groupMemberId
             )
 
@@ -647,8 +649,9 @@ deleteContactCardKeepConn db connId Contact {contactId, profile = LocalProfile {
 createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> StoreCxt -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> GroupMemberRole -> Maybe Int64 -> Maybe SimplexDomain -> ExceptT StoreError IO (GroupInfo, Maybe GroupMember)
 createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId useRelays userMemberRole publicMemberCount_ verifiedDomain = do
   currentTs <- liftIO getCurrentTime
+  (memberPubKey, memberPrivKey) <- atomically $ C.generateKeyPair gVar
   let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
-  (groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing publicMemberCount_ currentTs
+  (groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing publicMemberCount_ (Just memberPrivKey) currentTs
   hostMemberId_ <-
     if useRelays
       then pure Nothing
@@ -658,8 +661,7 @@ createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile b
       then liftIO $ MemberId <$> encodedRandomBytes gVar 12
       else pure $ MemberId $ encodeUtf8 groupLDN <> "_user_unknown_id"
   let userMember = MemberIdRole userMemberId userMemberRole
-  -- TODO [member keys] user key must be included here. Should key be added when group is prepared?
-  membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs (vr cxt)
+  membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing (Just memberPubKey) currentTs (vr cxt)
   hostMember_ <- forM hostMemberId_ $ getGroupMember db cxt user groupId
   forM_ hostMember_ $ \hostMember ->
     when business $ liftIO $ setGroupBusinessChatInfo groupId membership hostMember
@@ -781,10 +783,12 @@ updatePreparedGroupUser db cxt user gInfo@GroupInfo {groupId, membership} hostMe
             safeDeleteLDN db user oldHostLDN
 
 updatePreparedUserAndHostMembersInvited :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
-updatePreparedUserAndHostMembersInvited db cxt user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
+updatePreparedUserAndHostMembersInvited db cxt user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberKey, fromMemberName, invitedMember, groupProfile, accepted, business} = do
   let fromMemberProfile = profileFromName fromMemberName
       initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
-  updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
+  r@(_, hostMember') <- updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
+  forM_ fromMemberKey $ \(MemberKey k) -> liftIO $ setMemberPubKey db (groupMemberId' hostMember') k
+  pure r
 
 updatePreparedUserAndHostMembersRejected :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
 updatePreparedUserAndHostMembersRejected db cxt user gInfo hostMember GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
@@ -846,36 +850,37 @@ updatePreparedUserAndHostMembers'
             (memberId, memberRole, currentTs, gmId)
         getGroupMemberById db cxt user gmId
 
-createGroupInvitedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
-createGroupInvitedViaLink db cxt user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
+createGroupInvitedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> C.KeyPairEd25519 -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
+createGroupInvitedViaLink db cxt user conn memberKeys GroupLinkInvitation {fromMember, fromMemberKey, fromMemberName, invitedMember, groupProfile, accepted, business} = do
   let fromMemberProfile = profileFromName fromMemberName
       initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
-  createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile business initialStatus
+  createGroupViaLink' db cxt user conn memberKeys fromMember fromMemberProfile ((\(MemberKey k) -> k) <$> fromMemberKey) invitedMember groupProfile business initialStatus
 
-createGroupRejectedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
-createGroupRejectedViaLink db cxt user conn GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
+createGroupRejectedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> C.KeyPairEd25519 -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
+createGroupRejectedViaLink db cxt user conn memberKeys GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
   let fromMemberProfile = profileFromName $ nameFromMemberId memberId
-  createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
+  createGroupViaLink' db cxt user conn memberKeys fromMember fromMemberProfile Nothing invitedMember groupProfile Nothing GSMemRejected
 
-createGroupViaLink' :: DB.Connection -> StoreCxt -> User -> Connection -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
+createGroupViaLink' :: DB.Connection -> StoreCxt -> User -> Connection -> C.KeyPairEd25519 -> MemberIdRole -> Profile -> Maybe C.PublicKeyEd25519 -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
 createGroupViaLink'
   db
   cxt
   user@User {userId, userContactId}
   Connection {connId, customUserProfileId}
+  memberKeys
   fromMember
   fromMemberProfile
+  fromMemberPubKey_
   invitedMember
   groupProfile
   business
   membershipStatus = do
     currentTs <- liftIO getCurrentTime
-    (groupId, _groupLDN) <- createGroup_ db userId groupProfile Nothing business False Nothing Nothing currentTs
+    (groupId, _groupLDN) <- createGroup_ db userId groupProfile Nothing business False Nothing Nothing (Just (snd memberKeys)) currentTs
     hostMemberId <- insertHost_ currentTs groupId
     liftIO $ DB.execute db "UPDATE connections SET conn_type = ?, group_member_id = ?, updated_at = ? WHERE connection_id = ?" (ConnMember, hostMemberId, currentTs, connId)
     -- using IBUnknown since host is created without contact
-    -- TODO [member keys] this is currently not used with public groups. If it needs to be used, member keys need to be added
-    void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId Nothing currentTs (vr cxt)
+    _membership <- createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId (Just (fst memberKeys)) currentTs (vr cxt)
     liftIO $ setViaGroupLinkUri db groupId connId
     (,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user hostMemberId
     where
@@ -889,16 +894,16 @@ createGroupViaLink'
             [sql|
               INSERT INTO group_members
                 ( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by,
-                  user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
-              VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+                  user_id, local_display_name, contact_id, contact_profile_id, member_pub_key, created_at, updated_at)
+              VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
             |]
             ( (groupId, indexInGroup, memberId, memberRole, GCHostMember, GSMemAccepted, Binary B.empty, fromInvitedBy userContactId IBUnknown)
-                :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
+                :. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, fromMemberPubKey_, currentTs, currentTs)
             )
           insertedRowId db
 
-createGroup_ :: DB.Connection -> UserId -> GroupProfile -> Maybe (CreatedLinkContact, Maybe SharedMsgId) -> Maybe BusinessChatInfo -> Bool -> Maybe RelayStatus -> Maybe Int64 -> UTCTime -> ExceptT StoreError IO (GroupId, Text)
-createGroup_ db userId groupProfile prepared business useRelays relayOwnStatus publicMemberCount_ currentTs = ExceptT $ do
+createGroup_ :: DB.Connection -> UserId -> GroupProfile -> Maybe (CreatedLinkContact, Maybe SharedMsgId) -> Maybe BusinessChatInfo -> Bool -> Maybe RelayStatus -> Maybe Int64 -> Maybe C.PrivateKeyEd25519 -> UTCTime -> ExceptT StoreError IO (GroupId, Text)
+createGroup_ db userId groupProfile prepared business useRelays relayOwnStatus publicMemberCount_ memberPrivKey_ currentTs = ExceptT $ do
   let GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission} = groupProfile
       (groupType_, groupLink_, publicGroupId_) = case publicGroup of
         Just PublicGroupProfile {groupType, groupLink, publicGroupId} -> (Just groupType, Just groupLink, Just publicGroupId)
@@ -924,10 +929,10 @@ createGroup_ db userId groupProfile prepared business useRelays relayOwnStatus p
           INSERT INTO groups
             (group_profile_id, local_display_name, user_id, enable_ntfs,
               created_at, updated_at, chat_ts, user_member_profile_sent_at, conn_full_link_to_connect, conn_short_link_to_connect, welcome_shared_msg_id,
-              business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count)
-          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+              business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count, member_priv_key)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
         |]
-        ((profileId, localDisplayName, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. toPreparedGroupRow prepared :. businessChatInfoRow business :. (BI useRelays, relayOwnStatus, publicMemberCount_))
+        ((profileId, localDisplayName, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. toPreparedGroupRow prepared :. businessChatInfoRow business :. (BI useRelays, relayOwnStatus, publicMemberCount_, memberPrivKey_))
       groupId <- insertedRowId db
       pure (groupId, localDisplayName)
 
@@ -939,10 +944,13 @@ setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
 -- TODO return the last connection that is ready, not any last connection
 -- requires updating connection status
 getGroup :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO Group
-getGroup db cxt user groupId = do
-  gInfo <- getGroupInfo db cxt user groupId
+getGroup db cxt user groupId = fst <$> getGroupKeys_ db cxt user groupId
+
+getGroupKeys_ :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO (Group, GroupKeys)
+getGroupKeys_ db cxt user groupId = do
+  GIK gInfo gks <- getGroupInfoKeys db cxt user groupId
   members <- liftIO $ getGroupMembers db cxt user gInfo
-  pure $ Group gInfo members
+  pure (Group gInfo members, gks)
 
 deleteGroupChatItems :: DB.Connection -> User -> GroupInfo -> IO ()
 deleteGroupChatItems db User {userId} GroupInfo {groupId} =
@@ -1047,7 +1055,7 @@ getInProgressGroups db cxt user@User {userId} createdAtCutoff = do
 getBaseGroupDetails :: DB.Connection -> StoreCxt -> User -> Maybe ContactId -> Maybe Text -> IO [GroupInfo]
 getBaseGroupDetails db cxt User {userId, userContactId} _contactId_ search_ = do
   currentTs <- getCurrentTime
-  map (toGroupInfo currentTs cxt userContactId [])
+  map (toGroupInfo_ currentTs cxt userContactId [])
     <$> DB.query db (groupInfoQuery <> " " <> condition) (userId, userContactId, search, search, search, search)
   where
     condition =
@@ -1354,11 +1362,11 @@ getGroupInvitation :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT St
 getGroupInvitation db cxt user groupId =
   getConnRec_ user >>= \case
     Just connRequest -> do
-      groupInfo@GroupInfo {membership} <- getGroupInfo db cxt user groupId
+      GIK groupInfo@GroupInfo {membership} groupKeys <- getGroupInfoKeys db cxt user groupId
       when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
       hostId <- getHostMemberId_ db user groupId
       fromMember <- getGroupMember db cxt user groupId hostId
-      pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo}
+      pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo, groupKeys}
     _ -> throwError SEGroupInvitationNotFound
   where
     getConnRec_ :: User -> ExceptT StoreError IO (Maybe ConnReqInvitation)
@@ -1688,6 +1696,11 @@ setGroupMemberKeyRole db GroupMember {groupMemberId} pubKey role = do
   currentTs <- getCurrentTime
   DB.execute db "UPDATE group_members SET member_pub_key = ?, member_role = ?, updated_at = ? WHERE group_member_id = ?" (pubKey, role, currentTs, groupMemberId)
 
+setMemberPubKey :: DB.Connection -> GroupMemberId -> C.PublicKeyEd25519 -> IO ()
+setMemberPubKey db groupMemberId pubKey = do
+  currentTs <- getCurrentTime
+  DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (pubKey, currentTs, groupMemberId)
+
 setGroupMemberVerified :: DB.Connection -> User -> GroupMemberId -> Maybe Text -> IO ()
 setGroupMemberVerified db User {userId} groupMemberId code = do
   updatedAt <- getCurrentTime
@@ -1896,13 +1909,13 @@ createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMemb
           groupPreferences = Nothing,
           memberAdmission = Nothing
         }
-  (groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing currentTs
+  (_, memberPrivKey) <- atomically $ C.generateKeyPair (drg cxt)
+  (groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing (Just memberPrivKey) currentTs
   -- Store relay request data for recovery
   liftIO $ setRelayRequestData_ groupId currentTs
   ownerMemberId <- insertOwner_ currentTs groupId
   let relayMember = MemberIdRole relayMemberId GRRelay
-  -- TODO [member keys] should relays use member keys?
-  _membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing Nothing currentTs (vr cxt)
+  _membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing (Just $ C.publicKey memberPrivKey) currentTs (vr cxt)
   ownerMember <- getGroupMember db cxt user groupId ownerMemberId
   g <- getGroupInfo db cxt user groupId
   pure (g, ownerMember)
@@ -1997,16 +2010,17 @@ isRelayGroupRejected db User {userId} groupLink =
       (userId, groupLink, RSRejected)
   )
 
-getRelayServedGroups :: DB.Connection -> StoreCxt -> User -> IO [GroupInfo]
+getRelayServedGroups :: DB.Connection -> StoreCxt -> User -> ExceptT StoreError IO [GroupInfoKeys]
 getRelayServedGroups db cxt User {userId, userContactId} = do
-  currentTs <- getCurrentTime
-  map (toGroupInfo currentTs cxt userContactId [])
+  currentTs <- liftIO getCurrentTime
+  rows <- liftIO $ map (toGroupInfo currentTs cxt userContactId [])
     <$> DB.query
       db
       ( groupInfoQuery
           <> " WHERE g.user_id = ? AND mu.contact_id = ? AND g.relay_own_status IN (?, ?, ?)"
       )
       (userId, userContactId, RSAccepted, RSAcknowledgedRoster, RSActive)
+  forM rows $ \(g, keysData) -> GIK g <$> mkGroupKeys db cxt g keysData
 
 getRelayPublishableGroups :: DB.Connection -> User -> IO [(Int64, B64UrlByteString, Maybe PublicGroupAccess)]
 getRelayPublishableGroups db User {userId, userContactId} =
@@ -2044,7 +2058,7 @@ getRelayInactiveGroups :: DB.Connection -> StoreCxt -> User -> NominalDiffTime -
 getRelayInactiveGroups db cxt User {userId, userContactId} ttl = do
   currentTs <- getCurrentTime
   let cutoffTs = addUTCTime (- ttl) currentTs
-  map (toGroupInfo currentTs cxt userContactId [])
+  map (toGroupInfo_ currentTs cxt userContactId [])
     <$> DB.query
       db
       ( groupInfoQuery
@@ -2131,7 +2145,7 @@ createJoiningMemberConnection
     Connection {connId} <- createConnection_ db userId ConnMember (Just groupMemberId) agentConnId ConnNew chatV cReqChatVRange Nothing (Just uclId) Nothing 0 createdAt subMode PQSupportOff
     setCommandConnId db user cmdId connId
 
-createBusinessRequestGroup :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfo, GroupMember)
+createBusinessRequestGroup :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfoKeys, GroupMember)
 createBusinessRequestGroup
   db
   cxt
@@ -2146,11 +2160,12 @@ createBusinessRequestGroup
     (groupId, membership@GroupMember {memberId = userMemberId}) <- insertGroup_ currentTs
     (groupMemberId, memberId) <- insertClientMember_ currentTs groupId membership
     liftIO $ DB.execute db "UPDATE groups SET business_member_id = ?, customer_member_id = ? WHERE group_id = ?" (userMemberId, memberId, groupId)
-    groupInfo <- getGroupInfo db cxt user groupId
+    groupInfo <- getGroupInfoKeys db cxt user groupId
     clientMember <- getGroupMemberById db cxt user groupMemberId
     pure (groupInfo, clientMember)
     where
       insertGroup_ currentTs = do
+        (memberPubKey, memberPrivKey) <- atomically $ C.generateKeyPair gVar
         liftIO $
           DB.execute
             db
@@ -2163,14 +2178,13 @@ createBusinessRequestGroup
             [sql|
               INSERT INTO groups
                 (group_profile_id, local_display_name, user_id, enable_ntfs,
-                  created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat)
-              VALUES (?,?,?,?,?,?,?,?,?)
+                  created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, member_priv_key)
+              VALUES (?,?,?,?,?,?,?,?,?,?)
             |]
-            (groupProfileId, ldn, userId, BI True, currentTs, currentTs, currentTs, currentTs, BCCustomer)
+            (groupProfileId, ldn, userId, BI True, currentTs, currentTs, currentTs, currentTs, BCCustomer, memberPrivKey)
         groupId <- liftIO $ insertedRowId db
         memberId <- liftIO $ encodedRandomBytes gVar 12
-        -- TODO [member keys] we could support member keys in business groups to allow binding agreements (though identity keys would be better for it.
-        membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing Nothing currentTs (vr cxt)
+        membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing (Just memberPubKey) currentTs (vr cxt)
         pure (groupId, membership)
       VersionRange minV maxV = cReqChatVRange
       insertClientMember_ currentTs groupId membership =
@@ -2232,14 +2246,14 @@ createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentCon
 -- which is used in single-connection flows.
 updatePreparedRelayedGroup ::
   DB.Connection -> StoreCxt -> User -> GroupInfo -> ConnReqContact -> ConnReqUriHash -> Maybe Profile ->
-  C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> Maybe Int64 ->
-  ExceptT StoreError IO GroupInfo
-updatePreparedRelayedGroup db cxt user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey memberPrivKey publicMemberCount_ = do
+  C.PublicKeyEd25519 -> Maybe Int64 ->
+  ExceptT StoreError IO GroupInfoKeys
+updatePreparedRelayedGroup db cxt user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey publicMemberCount_ = do
   currentTs <- liftIO getCurrentTime
   customUserProfileId <- liftIO $ mapM (createIncognitoProfile_ db userId currentTs) incognitoProfile
   liftIO $ setPreparedGroupLinkInfo_ db gInfo cReq cReqHash customUserProfileId publicMemberCount_ currentTs
-  liftIO $ updateGroupMemberKeys db (groupId' gInfo) rootPubKey memberPrivKey (groupMemberId' $ membership gInfo)
-  getGroupInfo db cxt user (groupId' gInfo)
+  liftIO $ setGroupRootKey db (groupId' gInfo) rootPubKey
+  getGroupInfoKeys db cxt user (groupId' gInfo)
 
 updatePublicMemberCount :: DB.Connection -> StoreCxt -> User -> GroupInfo -> ExceptT StoreError IO GroupInfo
 updatePublicMemberCount db cxt user GroupInfo {groupId} = do
@@ -2266,23 +2280,15 @@ setPublicMemberCount db cxt user GroupInfo {groupId} publicCount = do
   liftIO $ DB.execute db "UPDATE groups SET public_member_count = ?, updated_at = ? WHERE group_id = ?" (publicCount, currentTs, groupId)
   getGroupInfo db cxt user groupId
 
-updateGroupMemberKeys :: DB.Connection -> GroupId -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> GroupMemberId -> IO ()
-updateGroupMemberKeys db groupId rootPubKey memberPrivKey membershipGMId = do
+setGroupRootKey :: DB.Connection -> GroupId -> C.PublicKeyEd25519 -> IO ()
+setGroupRootKey db groupId rootPubKey = do
   currentTs <- getCurrentTime
-  DB.execute
-    db
-    "UPDATE groups SET root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?"
-    (rootPubKey, memberPrivKey, currentTs, groupId)
-  DB.execute
-    db
-    "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?"
-    (C.publicKey memberPrivKey, currentTs, membershipGMId)
+  DB.execute db "UPDATE groups SET root_pub_key = ?, updated_at = ? WHERE group_id = ?" (rootPubKey, currentTs, groupId)
 
-updateRelayGroupKeys :: DB.Connection -> User -> GroupInfo -> PublicGroupProfile -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> [OwnerAuth] -> ExceptT StoreError IO ()
-updateRelayGroupKeys db user@User {userId} gInfo PublicGroupProfile {groupType, groupLink, publicGroupId} rootPubKey memberPrivKey owners = do
+updateRelayGroupKeys :: DB.Connection -> User -> GroupInfo -> PublicGroupProfile -> C.PublicKeyEd25519 -> [OwnerAuth] -> ExceptT StoreError IO ()
+updateRelayGroupKeys db user@User {userId} gInfo PublicGroupProfile {groupType, groupLink, publicGroupId} rootPubKey owners = do
   currentTs <- liftIO getCurrentTime
-  let membershipGMId = groupMemberId' $ membership gInfo
-      groupId = groupId' gInfo
+  let groupId = groupId' gInfo
   liftIO $ do
     DB.execute
       db
@@ -2291,14 +2297,7 @@ updateRelayGroupKeys db user@User {userId} gInfo PublicGroupProfile {groupType,
         WHERE group_profile_id IN (SELECT group_profile_id FROM groups WHERE user_id = ? AND group_id = ?)
       |]
       (groupType, groupLink, publicGroupId, currentTs, userId, groupId)
-    DB.execute
-      db
-      "UPDATE groups SET root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?"
-      (rootPubKey, memberPrivKey, currentTs, groupId)
-    DB.execute
-      db
-      "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?"
-      (C.publicKey memberPrivKey, currentTs, membershipGMId)
+    setGroupRootKey db groupId rootPubKey
   -- TODO [relays] relay: if not found, create owner record (multi-owner)
   forM_ owners $ \OwnerAuth {ownerId, ownerKey} -> do
     ownerGMId <- getGroupMemberIdViaMemberId db user gInfo (MemberId ownerId)

src/Simplex/Chat/Store/Messages.hs

@@ -164,6 +164,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time (addUTCTime)
 import Data.Time.Clock (UTCTime (..), getCurrentTime)
+import Simplex.Chat.Badges (BadgeStatus)
 import Simplex.Chat.Controller (ChatListQuery (..), ChatPagination (..), PaginationByTime (..))
 import Simplex.Chat.Markdown
 import Simplex.Chat.Messages
@@ -1093,7 +1094,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do
 
 -- this function can be changed so it never fails, not only avoid failure on invalid json
 toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal)
-toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)) =
+toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires) :. (fileMaxSize_, fileBadgeStatus_)) =
   chatItem $ fromRight invalid $ dbParseACIContent itemContentText
   where
     invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -1113,7 +1114,8 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
         (Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
           let cfArgs = CFArgs <$> fileKey <*> fileNonce
               fileSource = (`CryptoFile` cfArgs) <$> filePath
-           in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires}
+              fileProhibited = (\maxSize -> FileProhibited {maxSize, badgeStatus = fileBadgeStatus_}) <$> fileMaxSize_
+           in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires, fileProhibited}
         _ -> Nothing
     cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTLocal d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTLocal
     cItem d chatDir ciStatus content file =
@@ -2276,7 +2278,7 @@ updateLocalChatItemsRead db User {userId} noteFolderId = do
     |]
     (CISRcvRead, currentTs, userId, noteFolderId, CISRcvNew)
 
-type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol, Maybe UTCTime)
+type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol, Maybe UTCTime) :. (Maybe Integer, Maybe BadgeStatus)
 
 type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt, Maybe MsgVerified)
 
@@ -2304,7 +2306,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
 
 -- this function can be changed so it never fails, not only avoid failure on invalid json
 toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
-toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)) :. quoteRow) =
+toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires) :. (fileMaxSize_, fileBadgeStatus_)) :. quoteRow) =
   chatItem $ fromRight invalid $ dbParseACIContent itemContentText
   where
     invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -2324,7 +2326,8 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
         (Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
           let cfArgs = CFArgs <$> fileKey <*> fileNonce
               fileSource = (`CryptoFile` cfArgs) <$> filePath
-           in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires}
+              fileProhibited = (\maxSize -> FileProhibited {maxSize, badgeStatus = fileBadgeStatus_}) <$> fileMaxSize_
+           in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires, fileProhibited}
         _ -> Nothing
     cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
     cItem d chatDir ciStatus content file =
@@ -2380,6 +2383,7 @@ toGroupChatItem
         :. forwardedFromRow
         :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned)
         :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)
+        :. (fileMaxSize_, fileBadgeStatus_)
       )
       :. (forwardedByMember, BI showGroupAsSender)
       :. memberRow_
@@ -2414,7 +2418,8 @@ toGroupChatItem
           (Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
             let cfArgs = CFArgs <$> fileKey <*> fileNonce
                 fileSource = (`CryptoFile` cfArgs) <$> filePath
-             in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires}
+                fileProhibited = (\maxSize -> FileProhibited {maxSize, badgeStatus = fileBadgeStatus_}) <$> fileMaxSize_
+             in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires, fileProhibited}
           _ -> Nothing
       cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup
       cItem d chatDir ciStatus content file =
@@ -2705,7 +2710,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
             i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
             i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
             -- CIFile
-            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
+            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status,
             -- DirectQuote
             ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
           FROM chat_items i
@@ -3099,7 +3104,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
             i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
             i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
             -- CIFile
-            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
+            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status,
             -- CIMeta forwardedByMember, showGroupAsSender
             i.forwarded_by_group_member_id, i.show_group_as_sender,
             -- GroupMember
@@ -3212,7 +3217,7 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
             i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
             i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
             -- CIFile
-            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at
+            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status
           FROM chat_items i
           LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
           WHERE i.user_id = ? AND i.note_folder_id = ? AND i.chat_item_id = ?

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

@@ -49,7 +49,9 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260723_contact_request_rejectio
 import Simplex.Chat.Store.Postgres.Migrations.M20260813_auto_accept_group_invitations
 import Simplex.Chat.Store.Postgres.Migrations.M20260822_forward_link
 import Simplex.Chat.Store.Postgres.Migrations.M20260828_file_expiry
-import Simplex.Chat.Store.Postgres.Migrations.M20260908_wallet_seeds
+import Simplex.Chat.Store.Postgres.Migrations.M20260904_file_badges
+import Simplex.Chat.Store.Postgres.Migrations.M20260915_user_badges
+import Simplex.Chat.Store.Postgres.Migrations.M20260921_wallet_seeds
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Text, Maybe Text)]
@@ -99,7 +101,9 @@ schemaMigrations =
     ("20260813_auto_accept_group_invitations", m20260813_auto_accept_group_invitations, Just down_m20260813_auto_accept_group_invitations),
     ("20260822_forward_link", m20260822_forward_link, Just down_m20260822_forward_link),
     ("20260828_file_expiry", m20260828_file_expiry, Just down_m20260828_file_expiry),
-    ("20260908_wallet_seeds", m20260908_wallet_seeds, Nothing)
+    ("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges),
+    ("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges),
+    ("20260921_wallet_seeds", m20260921_wallet_seeds, Nothing)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.Postgres.Migrations.M20260904_file_badges where
+
+import Data.Text (Text)
+import Text.RawString.QQ (r)
+
+m20260904_file_badges :: Text
+m20260904_file_badges =
+  [r|
+ALTER TABLE files ADD COLUMN file_max_size BIGINT;
+ALTER TABLE files ADD COLUMN file_badge_status TEXT;
+
+CREATE TABLE file_badge_proofs(
+  badge_proof_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY,
+  file_id BIGINT NOT NULL REFERENCES files ON DELETE CASCADE,
+  proof_kind TEXT NOT NULL,
+  badge_proof BYTEA NOT NULL,
+  badge_pres_header BYTEA NOT NULL,
+  badge_key_idx BIGINT NOT NULL,
+  badge_type TEXT NOT NULL,
+  badge_expiry TIMESTAMPTZ NOT NULL,
+  badge_extra TEXT NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL,
+  updated_at TIMESTAMPTZ NOT NULL
+);
+
+CREATE UNIQUE INDEX idx_file_badge_proofs_file_id_kind ON file_badge_proofs(file_id, proof_kind);
+|]
+
+down_m20260904_file_badges :: Text
+down_m20260904_file_badges =
+  [r|
+DROP INDEX idx_file_badge_proofs_file_id_kind;
+DROP TABLE file_badge_proofs;
+
+ALTER TABLE files DROP COLUMN file_badge_status;
+ALTER TABLE files DROP COLUMN file_max_size;
+|]

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

@@ -0,0 +1,306 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.Postgres.Migrations.M20260915_user_badges where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.RawString.QQ (r)
+
+-- the same tables in the client and in the badge service; '@' is replaced with the table name prefix
+badgeSchema :: Text -> Text
+badgeSchema pfx = withPrefix pfx badgeSchemaTables
+
+badgeSchemaDown :: Text -> Text
+badgeSchemaDown pfx = withPrefix pfx badgeSchemaTablesDown
+
+withPrefix :: Text -> Text -> Text
+withPrefix = T.replace "@"
+
+badgeSchemaTables :: Text
+badgeSchemaTables =
+  [r|
+CREATE TABLE @invoices(
+  invoice_id TEXT NOT NULL PRIMARY KEY,
+  provider TEXT NOT NULL,
+  price BIGINT NOT NULL,
+  discount_amount BIGINT,
+  credit_amount BIGINT,
+  amount BIGINT NOT NULL,
+  currency TEXT NOT NULL,
+  payment_url TEXT,
+  payment_address TEXT,
+  payment_crypto_currency TEXT,
+  payment_crypto_amount TEXT,
+  expires_at TIMESTAMPTZ NOT NULL,
+  status TEXT NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL,
+  updated_at TIMESTAMPTZ NOT NULL
+);
+
+CREATE TABLE @payments(
+  payment_id TEXT NOT NULL PRIMARY KEY,
+  invoice_id TEXT REFERENCES @invoices,
+  provider TEXT NOT NULL,
+  provider_ref TEXT,
+  amount BIGINT,
+  currency TEXT,
+  status TEXT NOT NULL,
+  exception TEXT,
+  subscription_renews_at TIMESTAMPTZ,
+  grace_until TIMESTAMPTZ,
+  cancelled SMALLINT NOT NULL DEFAULT 0,
+  created_at TIMESTAMPTZ NOT NULL,
+  updated_at TIMESTAMPTZ NOT NULL
+);
+
+CREATE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref);
+
+CREATE INDEX @idx_payments_invoice ON @payments(invoice_id);
+
+CREATE TABLE @badge_prices(
+  price_id TEXT NOT NULL PRIMARY KEY,
+  badge_type TEXT NOT NULL,
+  month_price BIGINT NOT NULL,
+  currency TEXT NOT NULL,
+  status TEXT NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL
+);
+
+CREATE TABLE @badge_offers(
+  offer_id TEXT NOT NULL PRIMARY KEY,
+  price_id TEXT REFERENCES @badge_prices,
+  months SMALLINT NOT NULL,
+  free_months SMALLINT,
+  discount SMALLINT,
+  status TEXT NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL
+);
+
+CREATE INDEX @idx_badge_offers_price ON @badge_offers(price_id);
+
+CREATE TABLE @badge_purchases(
+  badge_purchase_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY,
+  purchase_key BYTEA NOT NULL,
+  master_key BYTEA NOT NULL,
+  initial_badge_type TEXT NOT NULL,
+  current_badge_type TEXT NOT NULL,
+  status TEXT NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL,
+  updated_at TIMESTAMPTZ NOT NULL,
+  UNIQUE(purchase_key)
+);
+
+CREATE TABLE @badge_ledger(
+  entry_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY,
+  entry_uuid TEXT NOT NULL,
+  badge_purchase_id BIGINT NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE,
+  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,
+  created_at TIMESTAMPTZ NOT NULL,
+  entry_type TEXT NOT NULL,
+  entry_credit_type TEXT,
+  entry_debit_type TEXT
+);
+
+CREATE UNIQUE INDEX @idx_badge_ledger_uuid ON @badge_ledger(entry_uuid);
+
+CREATE INDEX @idx_badge_ledger_purchase ON @badge_ledger(badge_purchase_id, entry_id);
+
+CREATE TABLE @badge_issuances(
+  issuance_id TEXT NOT NULL PRIMARY KEY,
+  badge_purchase_id BIGINT NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE,
+  entry_id BIGINT REFERENCES @badge_ledger,
+  badge_type TEXT NOT NULL,
+  period_start TIMESTAMPTZ NOT NULL,
+  period_end TIMESTAMPTZ NOT NULL,
+  expiry TIMESTAMPTZ NOT NULL,
+  credential BYTEA NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL
+);
+
+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
+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;
+DROP TABLE @badge_ledger;
+DROP TABLE @badge_purchases;
+DROP INDEX @idx_payments_provider_ref;
+DROP INDEX @idx_payments_invoice;
+DROP TABLE @payments;
+DROP TABLE @invoices;
+DROP INDEX @idx_badge_offers_price;
+DROP TABLE @badge_offers;
+DROP TABLE @badge_prices;
+|]
+
+{- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
+
+CREATE TABLE @subscription_charges(
+  charge_id TEXT NOT NULL PRIMARY KEY,
+  payment_id TEXT NOT NULL REFERENCES @payments ON DELETE CASCADE,
+  provider_charge_ref TEXT NOT NULL,
+  period_start TIMESTAMPTZ NOT NULL,
+  period_end TIMESTAMPTZ NOT NULL,
+  amount BIGINT NOT NULL,
+  currency TEXT NOT NULL,
+  charged_at TIMESTAMPTZ NOT NULL,
+  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,
+  price_id TEXT NOT NULL REFERENCES @badge_prices,
+  offer_id TEXT REFERENCES @badge_offers,
+  months SMALLINT NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL
+);
+
+CREATE INDEX @idx_badge_invoices_purchase ON @badge_invoices(badge_purchase_id);
+
+CREATE INDEX @idx_badge_invoices_offer ON @badge_invoices(offer_id);
+
+CREATE INDEX @idx_badge_invoices_price ON @badge_invoices(price_id);
+
+CREATE TABLE @badge_subscription_changes(
+  change_id TEXT NOT NULL PRIMARY KEY,
+  badge_purchase_id BIGINT NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE,
+  from_badge_type TEXT NOT NULL,
+  to_badge_type TEXT NOT NULL,
+  from_provider_ref TEXT,
+  to_provider_ref TEXT,
+  effective TEXT NOT NULL,
+  status TEXT NOT NULL,
+  effective_at TIMESTAMPTZ,
+  created_at TIMESTAMPTZ NOT NULL,
+  updated_at TIMESTAMPTZ NOT NULL
+);
+
+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);
+
+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;
+DROP INDEX @idx_badge_subscription_changes_purchase;
+DROP TABLE @badge_subscription_changes;
+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;
+-}
+
+m20260915_user_badges :: Text
+m20260915_user_badges =
+  badgeSchema ""
+    <> [r|
+ALTER TABLE badge_purchases ADD COLUMN user_id BIGINT REFERENCES users ON DELETE CASCADE;
+
+ALTER TABLE badge_purchases ADD COLUMN purchase_priv_key BYTEA;
+
+ALTER TABLE badge_purchases ADD COLUMN alert_acked_kind TEXT;
+
+ALTER TABLE badge_purchases ADD COLUMN alert_acked_episode TEXT;
+
+ALTER TABLE badge_purchases ADD COLUMN alert_snooze_until TIMESTAMPTZ;
+
+ALTER TABLE badge_ledger ADD COLUMN entry_type_unknown SMALLINT NOT NULL DEFAULT 0;
+
+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;
+
+CREATE INDEX idx_users_shown_badge ON users(shown_badge_id);
+
+CREATE TABLE badge_code_redemptions(
+  badge_code_redemption_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY,
+  user_id BIGINT NOT NULL REFERENCES users ON DELETE CASCADE,
+  code TEXT NOT NULL,
+  purchase_key BYTEA NOT NULL,
+  purchase_priv_key BYTEA NOT NULL,
+  master_key BYTEA NOT NULL,
+  created_at TIMESTAMPTZ NOT NULL,
+  UNIQUE(user_id, code)
+);
+
+CREATE INDEX idx_badge_code_redemptions_user ON badge_code_redemptions(user_id);
+
+ALTER TABLE badge_purchases ADD COLUMN badge_code_redemption_id BIGINT REFERENCES badge_code_redemptions;
+
+CREATE UNIQUE INDEX idx_badge_purchases_code_redemption ON badge_purchases(badge_code_redemption_id);
+|]
+
+down_m20260915_user_badges :: Text
+down_m20260915_user_badges =
+  [r|
+DROP INDEX idx_badge_purchases_code_redemption;
+DROP INDEX idx_badge_purchases_user;
+DROP INDEX idx_users_shown_badge;
+ALTER TABLE users DROP COLUMN shown_badge_id;
+|]
+    <> badgeSchemaDown ""
+    <> [r|
+DROP INDEX idx_badge_code_redemptions_user;
+DROP TABLE badge_code_redemptions;
+|]
+
+{- TODO [badges] deferred with the draft above, client only.
+
+ALTER TABLE payments ADD COLUMN evidence BYTEA;
+
+ALTER TABLE payments ADD COLUMN receipt_code TEXT;
+
+-- down
+ALTER TABLE payments DROP COLUMN evidence;
+ALTER TABLE payments DROP COLUMN receipt_code;
+-}

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

@@ -1,13 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
-module Simplex.Chat.Store.Postgres.Migrations.M20260908_wallet_seeds where
+module Simplex.Chat.Store.Postgres.Migrations.M20260921_wallet_seeds where
 
 import Data.Text (Text)
 import Text.RawString.QQ (r)
 
-m20260908_wallet_seeds :: Text
-m20260908_wallet_seeds =
+m20260921_wallet_seeds :: Text
+m20260921_wallet_seeds =
   [r|
 -- the columns are commented in the SQLite migration
 CREATE TABLE wallet_seeds (

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

@@ -168,6 +168,129 @@ CREATE TABLE test_chat_schema.app_settings (
 
 
 
+CREATE TABLE test_chat_schema.badge_code_redemptions (
+    badge_code_redemption_id bigint NOT NULL,
+    user_id bigint NOT NULL,
+    code text NOT NULL,
+    purchase_key bytea NOT NULL,
+    purchase_priv_key bytea NOT NULL,
+    master_key bytea NOT NULL,
+    created_at timestamp with time zone NOT NULL
+);
+
+
+
+ALTER TABLE test_chat_schema.badge_code_redemptions ALTER COLUMN badge_code_redemption_id ADD GENERATED ALWAYS AS IDENTITY (
+    SEQUENCE NAME test_chat_schema.badge_code_redemptions_badge_code_redemption_id_seq
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1
+);
+
+
+
+CREATE TABLE test_chat_schema.badge_issuances (
+    issuance_id text NOT NULL,
+    badge_purchase_id bigint NOT NULL,
+    entry_id bigint,
+    badge_type text NOT NULL,
+    period_start timestamp with time zone NOT NULL,
+    period_end timestamp with time zone NOT NULL,
+    expiry timestamp with time zone NOT NULL,
+    credential bytea NOT NULL,
+    created_at timestamp with time zone NOT NULL
+);
+
+
+
+CREATE TABLE test_chat_schema.badge_ledger (
+    entry_id bigint NOT NULL,
+    entry_uuid text NOT NULL,
+    badge_purchase_id bigint NOT NULL,
+    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,
+    created_at timestamp with time zone NOT NULL,
+    entry_type text NOT NULL,
+    entry_credit_type text,
+    entry_debit_type text,
+    entry_type_unknown smallint DEFAULT 0 NOT NULL,
+    entry_type_value text,
+    balance_checked smallint
+);
+
+
+
+ALTER TABLE test_chat_schema.badge_ledger ALTER COLUMN entry_id ADD GENERATED ALWAYS AS IDENTITY (
+    SEQUENCE NAME test_chat_schema.badge_ledger_entry_id_seq
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1
+);
+
+
+
+CREATE TABLE test_chat_schema.badge_offers (
+    offer_id text NOT NULL,
+    price_id text,
+    months smallint NOT NULL,
+    free_months smallint,
+    discount smallint,
+    status text NOT NULL,
+    created_at timestamp with time zone NOT NULL
+);
+
+
+
+CREATE TABLE test_chat_schema.badge_prices (
+    price_id text NOT NULL,
+    badge_type text NOT NULL,
+    month_price bigint NOT NULL,
+    currency text NOT NULL,
+    status text NOT NULL,
+    created_at timestamp with time zone NOT NULL
+);
+
+
+
+CREATE TABLE test_chat_schema.badge_purchases (
+    badge_purchase_id bigint NOT NULL,
+    purchase_key bytea NOT NULL,
+    master_key bytea NOT NULL,
+    initial_badge_type text NOT NULL,
+    current_badge_type text NOT NULL,
+    status text NOT NULL,
+    created_at timestamp with time zone NOT NULL,
+    updated_at timestamp with time zone NOT NULL,
+    user_id bigint,
+    purchase_priv_key bytea,
+    alert_acked_kind text,
+    alert_acked_episode text,
+    alert_snooze_until timestamp with time zone,
+    badge_code_redemption_id bigint
+);
+
+
+
+ALTER TABLE test_chat_schema.badge_purchases ALTER COLUMN badge_purchase_id ADD GENERATED ALWAYS AS IDENTITY (
+    SEQUENCE NAME test_chat_schema.badge_purchases_badge_purchase_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,
@@ -744,6 +867,33 @@ ALTER TABLE test_chat_schema.extra_xftp_file_descriptions ALTER COLUMN extra_fil
 
 
 
+CREATE TABLE test_chat_schema.file_badge_proofs (
+    badge_proof_id bigint NOT NULL,
+    file_id bigint NOT NULL,
+    proof_kind text NOT NULL,
+    badge_proof bytea NOT NULL,
+    badge_pres_header bytea NOT NULL,
+    badge_key_idx bigint NOT NULL,
+    badge_type text NOT NULL,
+    badge_expiry timestamp with time zone NOT NULL,
+    badge_extra text NOT NULL,
+    created_at timestamp with time zone NOT NULL,
+    updated_at timestamp with time zone NOT NULL
+);
+
+
+
+ALTER TABLE test_chat_schema.file_badge_proofs ALTER COLUMN badge_proof_id ADD GENERATED ALWAYS AS IDENTITY (
+    SEQUENCE NAME test_chat_schema.file_badge_proofs_badge_proof_id_seq
+    START WITH 1
+    INCREMENT BY 1
+    NO MINVALUE
+    NO MAXVALUE
+    CACHE 1
+);
+
+
+
 CREATE TABLE test_chat_schema.files (
     file_id bigint NOT NULL,
     contact_id bigint,
@@ -771,7 +921,9 @@ CREATE TABLE test_chat_schema.files (
     file_type text DEFAULT 'normal'::text NOT NULL,
     roster_transfer_id bigint,
     file_digest bytea,
-    file_expires_at timestamp with time zone
+    file_expires_at timestamp with time zone,
+    file_max_size bigint,
+    file_badge_status text
 );
 
 
@@ -1000,7 +1152,7 @@ CREATE TABLE test_chat_schema.groups (
     public_member_count bigint,
     relay_request_retries bigint DEFAULT 0 NOT NULL,
     relay_request_delay bigint DEFAULT 0 NOT NULL,
-    relay_request_execute_at timestamp with time zone DEFAULT '1970-01-01 01:00:00+01'::timestamp with time zone NOT NULL,
+    relay_request_execute_at timestamp with time zone DEFAULT '1970-01-01 04:00:00+04'::timestamp with time zone NOT NULL,
     relay_inactive_at timestamp with time zone,
     relay_sent_web_domain text,
     roster_version bigint,
@@ -1028,6 +1180,26 @@ ALTER TABLE test_chat_schema.groups ALTER COLUMN group_id ADD GENERATED ALWAYS A
 
 
 
+CREATE TABLE test_chat_schema.invoices (
+    invoice_id text NOT NULL,
+    provider text NOT NULL,
+    price bigint NOT NULL,
+    discount_amount bigint,
+    credit_amount bigint,
+    amount bigint NOT NULL,
+    currency text NOT NULL,
+    payment_url text,
+    payment_address text,
+    payment_crypto_currency text,
+    payment_crypto_amount text,
+    expires_at timestamp with time zone NOT NULL,
+    status text NOT NULL,
+    created_at timestamp with time zone NOT NULL,
+    updated_at timestamp with time zone NOT NULL
+);
+
+
+
 CREATE TABLE test_chat_schema.known_servers (
     server_id bigint NOT NULL,
     host text NOT NULL,
@@ -1161,6 +1333,24 @@ ALTER TABLE test_chat_schema.operator_usage_conditions ALTER COLUMN operator_usa
 
 
 
+CREATE TABLE test_chat_schema.payments (
+    payment_id text NOT NULL,
+    invoice_id text,
+    provider text NOT NULL,
+    provider_ref text,
+    amount bigint,
+    currency text,
+    status text NOT NULL,
+    exception text,
+    subscription_renews_at timestamp with time zone,
+    grace_until timestamp with time zone,
+    cancelled smallint DEFAULT 0 NOT NULL,
+    created_at timestamp with time zone NOT NULL,
+    updated_at timestamp with time zone NOT NULL
+);
+
+
+
 CREATE TABLE test_chat_schema.pending_group_messages (
     pending_group_message_id bigint NOT NULL,
     group_member_id bigint NOT NULL,
@@ -1517,7 +1707,8 @@ CREATE TABLE test_chat_schema.users (
     auto_accept_member_contacts smallint DEFAULT 0 NOT NULL,
     is_user_chat_relay smallint DEFAULT 0 NOT NULL,
     client_service smallint DEFAULT 0 NOT NULL,
-    auto_accept_group_invitations smallint DEFAULT 0 NOT NULL
+    auto_accept_group_invitations smallint DEFAULT 0 NOT NULL,
+    shown_badge_id bigint
 );
 
 
@@ -1533,49 +1724,6 @@ ALTER TABLE test_chat_schema.users ALTER COLUMN user_id ADD GENERATED ALWAYS AS
 
 
 
-CREATE TABLE test_chat_schema.wallet_accounts (
-    wallet_account_id bigint NOT NULL,
-    wallet_seed_id bigint NOT NULL,
-    account_index bigint,
-    user_id bigint,
-    CONSTRAINT wallet_accounts_account_index_check CHECK (((account_index >= 0) AND (account_index <= 2147483647)))
-);
-
-
-
-ALTER TABLE test_chat_schema.wallet_accounts ALTER COLUMN wallet_account_id ADD GENERATED ALWAYS AS IDENTITY (
-    SEQUENCE NAME test_chat_schema.wallet_accounts_wallet_account_id_seq
-    START WITH 1
-    INCREMENT BY 1
-    NO MINVALUE
-    NO MAXVALUE
-    CACHE 1
-);
-
-
-
-CREATE TABLE test_chat_schema.wallet_seeds (
-    wallet_seed_id bigint NOT NULL,
-    entropy bytea NOT NULL,
-    next_account_index bigint,
-    single_seed smallint DEFAULT 1 NOT NULL,
-    CONSTRAINT wallet_seeds_entropy_check CHECK ((length(entropy) = 32)),
-    CONSTRAINT wallet_seeds_next_account_index_check CHECK (((next_account_index >= 0) AND (next_account_index <= '2147483648'::bigint)))
-);
-
-
-
-ALTER TABLE test_chat_schema.wallet_seeds ALTER COLUMN wallet_seed_id ADD GENERATED ALWAYS AS IDENTITY (
-    SEQUENCE NAME test_chat_schema.wallet_seeds_wallet_seed_id_seq
-    START WITH 1
-    INCREMENT BY 1
-    NO MINVALUE
-    NO MAXVALUE
-    CACHE 1
-);
-
-
-
 CREATE TABLE test_chat_schema.xftp_file_descriptions (
     file_descr_id bigint NOT NULL,
     user_id bigint NOT NULL,
@@ -1599,6 +1747,46 @@ ALTER TABLE test_chat_schema.xftp_file_descriptions ALTER COLUMN file_descr_id A
 
 
 
+ALTER TABLE ONLY test_chat_schema.badge_code_redemptions
+    ADD CONSTRAINT badge_code_redemptions_pkey PRIMARY KEY (badge_code_redemption_id);
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_code_redemptions
+    ADD CONSTRAINT badge_code_redemptions_user_id_code_key UNIQUE (user_id, code);
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_issuances
+    ADD CONSTRAINT badge_issuances_pkey PRIMARY KEY (issuance_id);
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_ledger
+    ADD CONSTRAINT badge_ledger_pkey PRIMARY KEY (entry_id);
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_offers
+    ADD CONSTRAINT badge_offers_pkey PRIMARY KEY (offer_id);
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_prices
+    ADD CONSTRAINT badge_prices_pkey PRIMARY KEY (price_id);
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_purchases
+    ADD CONSTRAINT badge_purchases_pkey PRIMARY KEY (badge_purchase_id);
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_purchases
+    ADD CONSTRAINT badge_purchases_purchase_key_key UNIQUE (purchase_key);
+
+
+
 ALTER TABLE ONLY test_chat_schema.calls
     ADD CONSTRAINT calls_pkey PRIMARY KEY (call_id);
 
@@ -1734,6 +1922,11 @@ ALTER TABLE ONLY test_chat_schema.extra_xftp_file_descriptions
 
 
 
+ALTER TABLE ONLY test_chat_schema.file_badge_proofs
+    ADD CONSTRAINT file_badge_proofs_pkey PRIMARY KEY (badge_proof_id);
+
+
+
 ALTER TABLE ONLY test_chat_schema.files
     ADD CONSTRAINT files_pkey PRIMARY KEY (file_id);
 
@@ -1789,6 +1982,11 @@ ALTER TABLE ONLY test_chat_schema.groups
 
 
 
+ALTER TABLE ONLY test_chat_schema.invoices
+    ADD CONSTRAINT invoices_pkey PRIMARY KEY (invoice_id);
+
+
+
 ALTER TABLE ONLY test_chat_schema.known_servers
     ADD CONSTRAINT known_servers_pkey PRIMARY KEY (server_id);
 
@@ -1824,6 +2022,11 @@ ALTER TABLE ONLY test_chat_schema.operator_usage_conditions
 
 
 
+ALTER TABLE ONLY test_chat_schema.payments
+    ADD CONSTRAINT payments_pkey PRIMARY KEY (payment_id);
+
+
+
 ALTER TABLE ONLY test_chat_schema.pending_group_messages
     ADD CONSTRAINT pending_group_messages_pkey PRIMARY KEY (pending_group_message_id);
 
@@ -1934,16 +2137,6 @@ ALTER TABLE ONLY test_chat_schema.users
 
 
 
-ALTER TABLE ONLY test_chat_schema.wallet_accounts
-    ADD CONSTRAINT wallet_accounts_pkey PRIMARY KEY (wallet_account_id);
-
-
-
-ALTER TABLE ONLY test_chat_schema.wallet_seeds
-    ADD CONSTRAINT wallet_seeds_pkey PRIMARY KEY (wallet_seed_id);
-
-
-
 ALTER TABLE ONLY test_chat_schema.xftp_file_descriptions
     ADD CONSTRAINT xftp_file_descriptions_pkey PRIMARY KEY (file_descr_id);
 
@@ -1961,6 +2154,42 @@ CREATE INDEX files_note_folder_id ON test_chat_schema.files USING btree (note_fo
 
 
 
+CREATE INDEX idx_badge_code_redemptions_user ON test_chat_schema.badge_code_redemptions USING btree (user_id);
+
+
+
+CREATE INDEX idx_badge_issuances_entry ON test_chat_schema.badge_issuances USING btree (entry_id);
+
+
+
+CREATE INDEX idx_badge_issuances_purchase ON test_chat_schema.badge_issuances USING btree (badge_purchase_id, issuance_id);
+
+
+
+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_purchase ON test_chat_schema.badge_ledger USING btree (badge_purchase_id, entry_id);
+
+
+
+CREATE UNIQUE INDEX idx_badge_ledger_uuid ON test_chat_schema.badge_ledger USING btree (entry_uuid);
+
+
+
+CREATE INDEX idx_badge_offers_price ON test_chat_schema.badge_offers USING btree (price_id);
+
+
+
+CREATE UNIQUE INDEX idx_badge_purchases_code_redemption ON test_chat_schema.badge_purchases USING btree (badge_code_redemption_id);
+
+
+
+CREATE INDEX idx_badge_purchases_user ON test_chat_schema.badge_purchases USING btree (user_id);
+
+
+
 CREATE INDEX idx_calls_chat_item_id ON test_chat_schema.calls USING btree (chat_item_id);
 
 
@@ -2389,6 +2618,10 @@ CREATE INDEX idx_extra_xftp_file_descriptions_user_id ON test_chat_schema.extra_
 
 
 
+CREATE UNIQUE INDEX idx_file_badge_proofs_file_id_kind ON test_chat_schema.file_badge_proofs USING btree (file_id, proof_kind);
+
+
+
 CREATE INDEX idx_files_chat_item_id ON test_chat_schema.files USING btree (chat_item_id);
 
 
@@ -2565,6 +2798,14 @@ CREATE INDEX idx_operator_usage_conditions_server_operator_id ON test_chat_schem
 
 
 
+CREATE INDEX idx_payments_invoice ON test_chat_schema.payments USING btree (invoice_id);
+
+
+
+CREATE INDEX idx_payments_provider_ref ON test_chat_schema.payments USING btree (provider, provider_ref);
+
+
+
 CREATE INDEX idx_pending_group_messages_group_member_id ON test_chat_schema.pending_group_messages USING btree (group_member_id);
 
 
@@ -2693,15 +2934,7 @@ CREATE UNIQUE INDEX idx_user_contact_links_group_id ON test_chat_schema.user_con
 
 
 
-CREATE INDEX idx_wallet_accounts_user_id ON test_chat_schema.wallet_accounts USING btree (user_id);
-
-
-
-CREATE UNIQUE INDEX idx_wallet_accounts_wallet_seed_id_account_index ON test_chat_schema.wallet_accounts USING btree (wallet_seed_id, account_index);
-
-
-
-CREATE UNIQUE INDEX idx_wallet_seeds_single_seed ON test_chat_schema.wallet_seeds USING btree (single_seed);
+CREATE INDEX idx_users_shown_badge ON test_chat_schema.users USING btree (shown_badge_id);
 
 
 
@@ -2725,6 +2958,41 @@ CREATE TRIGGER tr_group_members_update_update_summary AFTER UPDATE ON test_chat_
 
 
 
+ALTER TABLE ONLY test_chat_schema.badge_code_redemptions
+    ADD CONSTRAINT badge_code_redemptions_user_id_fkey FOREIGN KEY (user_id) REFERENCES test_chat_schema.users(user_id) ON DELETE CASCADE;
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_issuances
+    ADD CONSTRAINT badge_issuances_badge_purchase_id_fkey FOREIGN KEY (badge_purchase_id) REFERENCES test_chat_schema.badge_purchases(badge_purchase_id) ON DELETE CASCADE;
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_issuances
+    ADD CONSTRAINT badge_issuances_entry_id_fkey FOREIGN KEY (entry_id) REFERENCES test_chat_schema.badge_ledger(entry_id);
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_ledger
+    ADD CONSTRAINT badge_ledger_badge_purchase_id_fkey FOREIGN KEY (badge_purchase_id) REFERENCES test_chat_schema.badge_purchases(badge_purchase_id) ON DELETE CASCADE;
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_offers
+    ADD CONSTRAINT badge_offers_price_id_fkey FOREIGN KEY (price_id) REFERENCES test_chat_schema.badge_prices(price_id);
+
+
+
+ALTER TABLE ONLY test_chat_schema.badge_purchases
+    ADD CONSTRAINT badge_purchases_badge_code_redemption_id_fkey FOREIGN KEY (badge_code_redemption_id) REFERENCES test_chat_schema.badge_code_redemptions(badge_code_redemption_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.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;
 
@@ -3045,6 +3313,11 @@ ALTER TABLE ONLY test_chat_schema.extra_xftp_file_descriptions
 
 
 
+ALTER TABLE ONLY test_chat_schema.file_badge_proofs
+    ADD CONSTRAINT file_badge_proofs_file_id_fkey FOREIGN KEY (file_id) REFERENCES test_chat_schema.files(file_id) ON DELETE CASCADE;
+
+
+
 ALTER TABLE ONLY test_chat_schema.files
     ADD CONSTRAINT files_contact_id_fkey FOREIGN KEY (contact_id) REFERENCES test_chat_schema.contacts(contact_id) ON DELETE CASCADE;
 
@@ -3265,6 +3538,11 @@ ALTER TABLE ONLY test_chat_schema.operator_usage_conditions
 
 
 
+ALTER TABLE ONLY test_chat_schema.payments
+    ADD CONSTRAINT payments_invoice_id_fkey FOREIGN KEY (invoice_id) REFERENCES test_chat_schema.invoices(invoice_id);
+
+
+
 ALTER TABLE ONLY test_chat_schema.pending_group_messages
     ADD CONSTRAINT pending_group_messages_group_member_id_fkey FOREIGN KEY (group_member_id) REFERENCES test_chat_schema.group_members(group_member_id) ON DELETE CASCADE;
 
@@ -3380,13 +3658,8 @@ ALTER TABLE ONLY test_chat_schema.user_contact_links
 
 
 
-ALTER TABLE ONLY test_chat_schema.wallet_accounts
-    ADD CONSTRAINT wallet_accounts_user_id_fkey FOREIGN KEY (user_id) REFERENCES test_chat_schema.users(user_id) ON DELETE SET NULL;
-
-
-
-ALTER TABLE ONLY test_chat_schema.wallet_accounts
-    ADD CONSTRAINT wallet_accounts_wallet_seed_id_fkey FOREIGN KEY (wallet_seed_id) REFERENCES test_chat_schema.wallet_seeds(wallet_seed_id) ON DELETE CASCADE;
+ALTER TABLE ONLY test_chat_schema.users
+    ADD CONSTRAINT users_shown_badge_id_fkey FOREIGN KEY (shown_badge_id) REFERENCES test_chat_schema.badge_purchases(badge_purchase_id) ON DELETE SET NULL;
 
 
 

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.hs

@@ -172,7 +172,9 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260723_contact_request_rejection
 import Simplex.Chat.Store.SQLite.Migrations.M20260813_auto_accept_group_invitations
 import Simplex.Chat.Store.SQLite.Migrations.M20260822_forward_link
 import Simplex.Chat.Store.SQLite.Migrations.M20260828_file_expiry
-import Simplex.Chat.Store.SQLite.Migrations.M20260908_wallet_seeds
+import Simplex.Chat.Store.SQLite.Migrations.M20260904_file_badges
+import Simplex.Chat.Store.SQLite.Migrations.M20260915_user_badges
+import Simplex.Chat.Store.SQLite.Migrations.M20260921_wallet_seeds
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -345,7 +347,9 @@ schemaMigrations =
     ("20260813_auto_accept_group_invitations", m20260813_auto_accept_group_invitations, Just down_m20260813_auto_accept_group_invitations),
     ("20260822_forward_link", m20260822_forward_link, Just down_m20260822_forward_link),
     ("20260828_file_expiry", m20260828_file_expiry, Just down_m20260828_file_expiry),
-    ("20260908_wallet_seeds", m20260908_wallet_seeds, Nothing)
+    ("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges),
+    ("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges),
+    ("20260921_wallet_seeds", m20260921_wallet_seeds, Nothing)
   ]
 
 -- | The list of migrations in ascending order by date

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

@@ -0,0 +1,39 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.SQLite.Migrations.M20260904_file_badges where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20260904_file_badges :: Query
+m20260904_file_badges =
+  [sql|
+ALTER TABLE files ADD COLUMN file_max_size INTEGER;
+ALTER TABLE files ADD COLUMN file_badge_status TEXT;
+
+CREATE TABLE file_badge_proofs(
+  badge_proof_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
+  proof_kind TEXT NOT NULL,
+  badge_proof BLOB NOT NULL,
+  badge_pres_header BLOB NOT NULL,
+  badge_key_idx INTEGER NOT NULL,
+  badge_type TEXT NOT NULL,
+  badge_expiry TEXT NOT NULL,
+  badge_extra TEXT NOT NULL,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL
+) STRICT;
+
+CREATE UNIQUE INDEX idx_file_badge_proofs_file_id_kind ON file_badge_proofs(file_id, proof_kind);
+|]
+
+down_m20260904_file_badges :: Query
+down_m20260904_file_badges =
+  [sql|
+DROP INDEX idx_file_badge_proofs_file_id_kind;
+DROP TABLE file_badge_proofs;
+
+ALTER TABLE files DROP COLUMN file_badge_status;
+ALTER TABLE files DROP COLUMN file_max_size;
+|]

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

@@ -0,0 +1,307 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.SQLite.Migrations.M20260915_user_badges where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Database.SQLite.Simple (Query (..))
+import Database.SQLite.Simple.QQ (sql)
+
+-- the same tables in the client and in the badge service; '@' is replaced with the table name prefix
+badgeSchema :: Text -> Query
+badgeSchema pfx = withPrefix pfx badgeSchemaTables
+
+badgeSchemaDown :: Text -> Query
+badgeSchemaDown pfx = withPrefix pfx badgeSchemaTablesDown
+
+withPrefix :: Text -> Query -> Query
+withPrefix pfx = Query . T.replace "@" pfx . fromQuery
+
+badgeSchemaTables :: Query
+badgeSchemaTables =
+  [sql|
+CREATE TABLE @invoices(
+  invoice_id TEXT NOT NULL PRIMARY KEY,
+  provider TEXT NOT NULL,
+  price INTEGER NOT NULL,
+  discount_amount INTEGER,
+  credit_amount INTEGER,
+  amount INTEGER NOT NULL,
+  currency TEXT NOT NULL,
+  payment_url TEXT,
+  payment_address TEXT,
+  payment_crypto_currency TEXT,
+  payment_crypto_amount TEXT,
+  expires_at TEXT NOT NULL,
+  status TEXT NOT NULL,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL
+) STRICT;
+
+CREATE TABLE @payments(
+  payment_id TEXT NOT NULL PRIMARY KEY,
+  invoice_id TEXT REFERENCES @invoices,
+  provider TEXT NOT NULL,
+  provider_ref TEXT,
+  amount INTEGER,
+  currency TEXT,
+  status TEXT NOT NULL,
+  exception TEXT,
+  subscription_renews_at TEXT,
+  grace_until TEXT,
+  cancelled INTEGER NOT NULL DEFAULT 0,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL
+) STRICT;
+
+CREATE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref);
+
+CREATE INDEX @idx_payments_invoice ON @payments(invoice_id);
+
+CREATE TABLE @badge_prices(
+  price_id TEXT NOT NULL PRIMARY KEY,
+  badge_type TEXT NOT NULL,
+  month_price INTEGER NOT NULL,
+  currency TEXT NOT NULL,
+  status TEXT NOT NULL,
+  created_at TEXT NOT NULL
+) STRICT;
+
+CREATE TABLE @badge_offers(
+  offer_id TEXT NOT NULL PRIMARY KEY,
+  price_id TEXT REFERENCES @badge_prices,
+  months INTEGER NOT NULL,
+  free_months INTEGER,
+  discount INTEGER,
+  status TEXT NOT NULL,
+  created_at TEXT NOT NULL
+) STRICT;
+
+CREATE INDEX @idx_badge_offers_price ON @badge_offers(price_id);
+
+CREATE TABLE @badge_purchases(
+  badge_purchase_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  purchase_key BLOB NOT NULL,
+  master_key BLOB NOT NULL,
+  initial_badge_type TEXT NOT NULL,
+  current_badge_type TEXT NOT NULL,
+  status TEXT NOT NULL,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL,
+  UNIQUE(purchase_key)
+) STRICT;
+
+CREATE TABLE @badge_ledger(
+  entry_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  entry_uuid TEXT NOT NULL,
+  badge_purchase_id INTEGER NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE,
+  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,
+  created_at TEXT NOT NULL,
+  entry_type TEXT NOT NULL,
+  entry_credit_type TEXT,
+  entry_debit_type TEXT
+) STRICT;
+
+CREATE UNIQUE INDEX @idx_badge_ledger_uuid ON @badge_ledger(entry_uuid);
+
+CREATE INDEX @idx_badge_ledger_purchase ON @badge_ledger(badge_purchase_id, entry_id);
+
+CREATE TABLE @badge_issuances(
+  issuance_id TEXT NOT NULL PRIMARY KEY,
+  badge_purchase_id INTEGER NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE,
+  entry_id INTEGER REFERENCES @badge_ledger,
+  badge_type TEXT NOT NULL,
+  period_start TEXT NOT NULL,
+  period_end TEXT NOT NULL,
+  expiry TEXT NOT NULL,
+  credential BLOB NOT NULL,
+  created_at TEXT NOT NULL
+) STRICT;
+
+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
+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;
+DROP TABLE @badge_ledger;
+DROP TABLE @badge_purchases;
+DROP INDEX @idx_payments_provider_ref;
+DROP INDEX @idx_payments_invoice;
+DROP TABLE @payments;
+DROP TABLE @invoices;
+DROP INDEX @idx_badge_offers_price;
+DROP TABLE @badge_offers;
+DROP TABLE @badge_prices;
+|]
+
+{- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
+
+CREATE TABLE @subscription_charges(
+  charge_id TEXT NOT NULL PRIMARY KEY,
+  payment_id TEXT NOT NULL REFERENCES @payments ON DELETE CASCADE,
+  provider_charge_ref TEXT NOT NULL,
+  period_start TEXT NOT NULL,
+  period_end TEXT NOT NULL,
+  amount INTEGER NOT NULL,
+  currency TEXT NOT NULL,
+  charged_at TEXT NOT NULL,
+  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,
+  price_id TEXT NOT NULL REFERENCES @badge_prices,
+  offer_id TEXT REFERENCES @badge_offers,
+  months INTEGER NOT NULL,
+  created_at TEXT NOT NULL
+) STRICT;
+
+CREATE INDEX @idx_badge_invoices_purchase ON @badge_invoices(badge_purchase_id);
+
+CREATE INDEX @idx_badge_invoices_offer ON @badge_invoices(offer_id);
+
+CREATE INDEX @idx_badge_invoices_price ON @badge_invoices(price_id);
+
+CREATE TABLE @badge_subscription_changes(
+  change_id TEXT NOT NULL PRIMARY KEY,
+  badge_purchase_id INTEGER NOT NULL REFERENCES @badge_purchases ON DELETE CASCADE,
+  from_badge_type TEXT NOT NULL,
+  to_badge_type TEXT NOT NULL,
+  from_provider_ref TEXT,
+  to_provider_ref TEXT,
+  effective TEXT NOT NULL,
+  status TEXT NOT NULL,
+  effective_at TEXT,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL
+) STRICT;
+
+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);
+
+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;
+DROP INDEX @idx_badge_subscription_changes_purchase;
+DROP TABLE @badge_subscription_changes;
+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;
+-}
+
+m20260915_user_badges :: Query
+m20260915_user_badges =
+  badgeSchema ""
+    <> [sql|
+ALTER TABLE badge_purchases ADD COLUMN user_id INTEGER REFERENCES users ON DELETE CASCADE;
+
+ALTER TABLE badge_purchases ADD COLUMN purchase_priv_key BLOB;
+
+ALTER TABLE badge_purchases ADD COLUMN alert_acked_kind TEXT;
+
+ALTER TABLE badge_purchases ADD COLUMN alert_acked_episode TEXT;
+
+ALTER TABLE badge_purchases ADD COLUMN alert_snooze_until TEXT;
+
+ALTER TABLE badge_ledger ADD COLUMN entry_type_unknown INTEGER NOT NULL DEFAULT 0;
+
+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;
+
+CREATE INDEX idx_users_shown_badge ON users(shown_badge_id);
+
+CREATE TABLE badge_code_redemptions(
+  badge_code_redemption_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
+  code TEXT NOT NULL,
+  purchase_key BLOB NOT NULL,
+  purchase_priv_key BLOB NOT NULL,
+  master_key BLOB NOT NULL,
+  created_at TEXT NOT NULL,
+  UNIQUE(user_id, code)
+) STRICT;
+
+CREATE INDEX idx_badge_code_redemptions_user ON badge_code_redemptions(user_id);
+
+ALTER TABLE badge_purchases ADD COLUMN badge_code_redemption_id INTEGER REFERENCES badge_code_redemptions;
+
+CREATE UNIQUE INDEX idx_badge_purchases_code_redemption ON badge_purchases(badge_code_redemption_id);
+|]
+
+down_m20260915_user_badges :: Query
+down_m20260915_user_badges =
+  [sql|
+DROP INDEX idx_badge_purchases_code_redemption;
+DROP INDEX idx_badge_purchases_user;
+DROP INDEX idx_users_shown_badge;
+ALTER TABLE users DROP COLUMN shown_badge_id;
+|]
+    <> badgeSchemaDown ""
+    <> [sql|
+DROP INDEX idx_badge_code_redemptions_user;
+DROP TABLE badge_code_redemptions;
+|]
+
+{- TODO [badges] deferred with the draft above, client only.
+
+ALTER TABLE payments ADD COLUMN evidence BLOB;
+
+ALTER TABLE payments ADD COLUMN receipt_code TEXT;
+
+-- down
+ALTER TABLE payments DROP COLUMN evidence;
+ALTER TABLE payments DROP COLUMN receipt_code;
+-}

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

@@ -1,12 +1,12 @@
 {-# LANGUAGE QuasiQuotes #-}
 
-module Simplex.Chat.Store.SQLite.Migrations.M20260908_wallet_seeds where
+module Simplex.Chat.Store.SQLite.Migrations.M20260921_wallet_seeds where
 
 import Database.SQLite.Simple (Query)
 import Database.SQLite.Simple.QQ (sql)
 
-m20260908_wallet_seeds :: Query
-m20260908_wallet_seeds =
+m20260921_wallet_seeds :: Query
+m20260921_wallet_seeds =
   [sql|
 CREATE TABLE wallet_seeds (
   wallet_seed_id INTEGER PRIMARY KEY AUTOINCREMENT,

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

@@ -115,8 +115,8 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta
 Query: 
                 INSERT INTO groups
                   (group_profile_id, local_display_name, inv_queue_info, user_id, enable_ntfs,
-                   created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, business_member_id, customer_member_id)
-                VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
+                   created_at, updated_at, chat_ts, user_member_profile_sent_at, member_priv_key, business_chat, business_member_id, customer_member_id)
+                VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
               
 Plan:
 
@@ -288,8 +288,8 @@ SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
 Query: 
               INSERT INTO group_members
                 ( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by,
-                  user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
-              VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+                  user_id, local_display_name, contact_id, contact_profile_id, member_pub_key, created_at, updated_at)
+              VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
             
 Plan:
 SEARCH rcv_roster_transfers USING COVERING INDEX idx_rcv_roster_transfers_from_member_id (from_member_id=?)
@@ -395,8 +395,8 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta
 Query: 
               INSERT INTO groups
                 (group_profile_id, local_display_name, user_id, enable_ntfs,
-                  created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat)
-              VALUES (?,?,?,?,?,?,?,?,?)
+                  created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, member_priv_key)
+              VALUES (?,?,?,?,?,?,?,?,?,?)
             
 Plan:
 
@@ -1203,6 +1203,30 @@ Query:
 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, 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:
+
+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)
+          VALUES (?,?,?,?,?,?,?,?,?,?)
+        
+Plan:
+
 Query: 
           INSERT INTO chat_item_reactions
             (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
@@ -1312,8 +1336,8 @@ Query:
           INSERT INTO groups
             (group_profile_id, local_display_name, user_id, enable_ntfs,
               created_at, updated_at, chat_ts, user_member_profile_sent_at, conn_full_link_to_connect, conn_short_link_to_connect, welcome_shared_msg_id,
-              business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count)
-          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+              business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count, member_priv_key)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
         
 Plan:
 
@@ -1357,7 +1381,7 @@ Query:
             i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
             i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
             -- CIFile
-            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at
+            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status
           FROM chat_items i
           LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
           WHERE i.user_id = ? AND i.note_folder_id = ? AND i.chat_item_id = ?
@@ -1375,7 +1399,7 @@ Query:
             i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
             i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
             -- CIFile
-            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
+            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status,
             -- CIMeta forwardedByMember, showGroupAsSender
             i.forwarded_by_group_member_id, i.show_group_as_sender,
             -- GroupMember
@@ -1432,7 +1456,7 @@ Query:
             i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
             i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
             -- CIFile
-            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
+            f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status,
             -- DirectQuote
             ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
           FROM chat_items i
@@ -1505,6 +1529,15 @@ Plan:
 SEARCH connections USING INDEX idx_connections_via_contact_uri_hash (user_id=? AND via_contact_uri_hash=?)
 USE TEMP B-TREE FOR ORDER BY
 
+Query: 
+          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
+        
+Plan:
+SEARCH badge_purchases USING INDEX idx_badge_purchases_user (user_id=?)
+
 Query: 
           SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.xcontact_id, c.custom_user_profile_id,
             c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.user_contact_link_id,
@@ -1721,7 +1754,8 @@ Query:
           SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
             f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
             f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline,
-            r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest
+            r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest,
+            f.file_max_size, f.file_badge_status
           FROM rcv_files r
           JOIN files f USING (file_id)
           LEFT JOIN contacts cs ON cs.contact_id = f.contact_id
@@ -1836,6 +1870,15 @@ Query:
 Plan:
 SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: 
+          UPDATE groups
+          SET member_priv_key = COALESCE(member_priv_key, ?), updated_at = ?
+          WHERE group_id = ?
+          RETURNING member_priv_key
+        
+Plan:
+SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: 
           UPDATE groups
           SET relay_request_inv_id = ?,
@@ -2004,6 +2047,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
@@ -3463,6 +3520,14 @@ Query:
 Plan:
 SEARCH connections USING INDEX idx_connections_to_subscribe (user_id=?)
 
+Query: 
+        SELECT badge_code_redemption_id, purchase_key, purchase_priv_key, master_key
+        FROM badge_code_redemptions
+        WHERE user_id = ? AND code = ?
+      
+Plan:
+SEARCH badge_code_redemptions USING INDEX sqlite_autoindex_badge_code_redemptions_1 (user_id=? AND code=?)
+
 Query: 
         SELECT c.agent_conn_id
         FROM connections c
@@ -3708,6 +3773,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
@@ -3760,6 +3835,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
@@ -3947,6 +4033,18 @@ Query:
 Plan:
 SCAN group_members
 
+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
+        FROM badge_ledger l
+        JOIN badge_purchases p ON p.badge_purchase_id = l.badge_purchase_id
+        WHERE l.badge_purchase_id = ? AND p.user_id = ?
+        ORDER BY l.entry_id
+      
+Plan:
+SEARCH p USING COVERING INDEX idx_badge_purchases_user (user_id=? AND rowid=?)
+SEARCH l USING INDEX idx_badge_ledger_purchase (badge_purchase_id=?)
+
 Query: 
         SELECT m.group_member_id
         FROM group_members m
@@ -3960,6 +4058,18 @@ 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.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL
+      
+Plan:
+SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
+SEARCH u USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: 
         SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.msg_chat_binding, m.msg_signatures
         FROM pending_group_messages pgm
@@ -3972,6 +4082,14 @@ SEARCH pgm USING INDEX idx_pending_group_messages_group_member_id (group_member_
 SEARCH m USING INTEGER PRIMARY KEY (rowid=?)
 USE TEMP B-TREE FOR ORDER BY
 
+Query: 
+        SELECT proof_kind, badge_proof, badge_pres_header, badge_key_idx, badge_type, badge_expiry, badge_extra
+        FROM file_badge_proofs
+        WHERE file_id = ?
+      
+Plan:
+SEARCH file_badge_proofs USING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
+
 Query: 
         SELECT r.contact_id, g.group_id, r.group_member_id
         FROM received_probes r
@@ -4186,6 +4304,14 @@ SEARCH connections USING INDEX idx_connections_group_member_id (group_member_id=
 LIST SUBQUERY 1
 SCAN group_members USING COVERING INDEX idx_group_members_user_id_local_display_name
 
+Query: 
+        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 = ?
+      
+Plan:
+SEARCH contact_profiles USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: 
         UPDATE group_members
         SET contact_id = ?, local_display_name = ?, contact_profile_id = ?, updated_at = ?
@@ -4297,6 +4423,17 @@ SEARCH c USING INDEX idx_connections_to_subscribe (user_id=?)
 SEARCH m USING INTEGER PRIMARY KEY (rowid=?)
 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 = ?)
+    
+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_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
+
 Query: 
       DELETE FROM chat_items
       WHERE group_scope_group_member_id = ?
@@ -4763,6 +4900,7 @@ Plan:
 SEARCH files USING INDEX idx_files_user_id (user_id=?)
 LIST SUBQUERY 1
 SEARCH chat_items USING COVERING INDEX idx_chat_items_note_folder_has_link_created_at (user_id=? AND note_folder_id=?)
+SEARCH file_badge_proofs USING COVERING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
 SEARCH extra_xftp_file_descriptions USING COVERING INDEX idx_extra_xftp_file_descriptions_file_id (file_id=?)
 SEARCH rcv_files USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH snd_files USING COVERING INDEX idx_snd_files_file_id (file_id=?)
@@ -4782,6 +4920,12 @@ LIST SUBQUERY 1
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH groups USING COVERING INDEX idx_groups_group_profile_id (group_profile_id=?)
 
+Query: 
+      INSERT INTO badge_code_redemptions (user_id, code, 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)
@@ -4893,6 +5037,20 @@ Query:
     
 Plan:
 
+Query: 
+      INSERT INTO file_badge_proofs (file_id, proof_kind, badge_proof, badge_pres_header, badge_key_idx, badge_type, badge_expiry, badge_extra, created_at, updated_at)
+      VALUES (?,?,?,?,?,?,?,?,?,?)
+      ON CONFLICT (file_id, proof_kind) DO UPDATE SET
+        badge_proof = excluded.badge_proof,
+        badge_pres_header = excluded.badge_pres_header,
+        badge_key_idx = excluded.badge_key_idx,
+        badge_type = excluded.badge_type,
+        badge_expiry = excluded.badge_expiry,
+        badge_extra = excluded.badge_extra,
+        updated_at = excluded.updated_at
+    
+Plan:
+
 Query: 
       INSERT INTO files
         ( user_id, note_folder_id,
@@ -5170,14 +5328,6 @@ Query:
 Plan:
 SEARCH connections_sync USING INTEGER PRIMARY KEY (rowid=?)
 
-Query: 
-      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 = ?
-    
-Plan:
-SEARCH contact_profiles USING INTEGER PRIMARY KEY (rowid=?)
-
 Query: 
       UPDATE contact_profiles
       SET contact_link = ?, updated_at = ?
@@ -6704,6 +6854,7 @@ SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
 Query: DELETE FROM files WHERE roster_transfer_id = ?
 Plan:
 SEARCH files USING COVERING INDEX idx_files_roster_transfer_id (roster_transfer_id=?)
+SEARCH file_badge_proofs USING COVERING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
 SEARCH extra_xftp_file_descriptions USING COVERING INDEX idx_extra_xftp_file_descriptions_file_id (file_id=?)
 SEARCH rcv_files USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH snd_files USING COVERING INDEX idx_snd_files_file_id (file_id=?)
@@ -6712,6 +6863,7 @@ SEARCH files USING COVERING INDEX idx_files_redirect_file_id (redirect_file_id=?
 Query: DELETE FROM files WHERE user_id = ? AND contact_id = ?
 Plan:
 SEARCH files USING INDEX idx_files_contact_id (contact_id=?)
+SEARCH file_badge_proofs USING COVERING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
 SEARCH extra_xftp_file_descriptions USING COVERING INDEX idx_extra_xftp_file_descriptions_file_id (file_id=?)
 SEARCH rcv_files USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH snd_files USING COVERING INDEX idx_snd_files_file_id (file_id=?)
@@ -6720,6 +6872,7 @@ SEARCH files USING COVERING INDEX idx_files_redirect_file_id (redirect_file_id=?
 Query: DELETE FROM files WHERE user_id = ? AND group_id = ? AND file_type = ?
 Plan:
 SEARCH files USING INDEX idx_files_group_id (group_id=?)
+SEARCH file_badge_proofs USING COVERING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
 SEARCH extra_xftp_file_descriptions USING COVERING INDEX idx_extra_xftp_file_descriptions_file_id (file_id=?)
 SEARCH rcv_files USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH snd_files USING COVERING INDEX idx_snd_files_file_id (file_id=?)
@@ -6944,6 +7097,8 @@ 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_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=?)
 SEARCH chat_tags USING COVERING INDEX idx_chat_tags_user_id (user_id=?)
 SEARCH note_folders USING COVERING INDEX note_folders_user_id (user_id=?)
@@ -6978,6 +7133,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:
 
@@ -7023,13 +7183,13 @@ Plan:
 Query: INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, redirect_file_id, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
 Plan:
 
-Query: INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)
+Query: INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_max_size, file_badge_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
 Plan:
 
 Query: INSERT INTO files (user_id, file_name, file_path, file_size, chunk_size, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)
 Plan:
 
-Query: INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
+Query: INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest, file_max_size, file_badge_status) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
 Plan:
 
 Query: INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, roster_transfer_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
@@ -7165,6 +7325,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
@@ -7177,6 +7341,22 @@ 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=?)
+
+Query: SELECT balance_checked FROM badge_ledger ORDER BY entry_id
+Plan:
+SCAN badge_ledger
+
 Query: SELECT c.agent_conn_id FROM connections c JOIN group_members m ON m.group_member_id = c.group_member_id WHERE m.local_display_name = ?
 Plan:
 SCAN m USING COVERING INDEX idx_group_members_user_id_local_display_name
@@ -7310,6 +7490,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=?)
@@ -7398,10 +7596,22 @@ Query: SELECT member_id FROM group_members WHERE member_role = ? LIMIT 1
 Plan:
 SCAN group_members
 
+Query: SELECT member_priv_key FROM groups
+Plan:
+SCAN groups
+
 Query: SELECT member_pub_key FROM group_members WHERE local_display_name = ?
 Plan:
 SCAN group_members
 
+Query: SELECT member_pub_key FROM group_members WHERE member_category = 'host'
+Plan:
+SCAN group_members
+
+Query: SELECT member_pub_key FROM group_members WHERE member_category = 'user'
+Plan:
+SCAN group_members
+
 Query: SELECT member_pub_key FROM group_members WHERE member_role = 'moderator'
 Plan:
 SCAN group_members
@@ -7502,6 +7712,10 @@ Query: SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? A
 Plan:
 SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: SELECT service_created_at, balance_start_ts FROM badge_ledger ORDER BY entry_id
+Plan:
+SCAN badge_ledger
+
 Query: SELECT shared_msg_id FROM chat_items WHERE shared_msg_id IS NOT NULL ORDER BY chat_item_id DESC LIMIT 1
 Plan:
 SCAN chat_items
@@ -7510,6 +7724,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=?)
@@ -7538,6 +7760,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 = ? AND user_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=?)
@@ -7602,6 +7828,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=?)
@@ -7754,6 +7988,14 @@ Query: UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_m
 Plan:
 SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE group_members SET member_pub_key = NULL WHERE member_category = 'host'
+Plan:
+SCAN group_members
+
+Query: UPDATE group_members SET member_pub_key = NULL WHERE member_category = 'user'
+Plan:
+SCAN group_members
+
 Query: UPDATE group_members SET member_relations_vector = set_member_vector_new_relation(member_relations_vector, ?, ?, ?), updated_at = ? WHERE group_member_id = ?
 Plan:
 SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
@@ -7846,6 +8088,10 @@ Query: UPDATE groups SET local_display_name = ?, updated_at = ? WHERE user_id =
 Plan:
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE groups SET member_priv_key = NULL
+Plan:
+SCAN groups
+
 Query: UPDATE groups SET members_require_attention=1 WHERE group_id=?
 Plan:
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
@@ -7866,7 +8112,7 @@ Query: UPDATE groups SET request_shared_msg_id = ? WHERE group_id = ?
 Plan:
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
 
-Query: UPDATE groups SET root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?
+Query: UPDATE groups SET root_pub_key = ?, updated_at = ? WHERE group_id = ?
 Plan:
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
 
@@ -7986,6 +8232,14 @@ Query: UPDATE users SET send_rcpts_small_groups = ? WHERE user_id = ?
 Plan:
 SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
 
+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

@@ -54,7 +54,8 @@ CREATE TABLE users(
   auto_accept_member_contacts INTEGER NOT NULL DEFAULT 0,
   is_user_chat_relay INTEGER NOT NULL DEFAULT 0,
   client_service INTEGER NOT NULL DEFAULT 0,
-  auto_accept_group_invitations INTEGER NOT NULL DEFAULT 0, -- 1 for active user
+  auto_accept_group_invitations INTEGER NOT NULL DEFAULT 0,
+  shown_badge_id INTEGER REFERENCES badge_purchases ON DELETE SET NULL, -- 1 for active user
   FOREIGN KEY(user_id, local_display_name)
   REFERENCES display_names(user_id, local_display_name)
   ON DELETE RESTRICT
@@ -302,7 +303,9 @@ CREATE TABLE files(
   file_type TEXT NOT NULL DEFAULT 'normal',
   roster_transfer_id INTEGER,
   file_digest BLOB,
-  file_expires_at TEXT
+  file_expires_at TEXT,
+  file_max_size INTEGER,
+  file_badge_status TEXT
 ) STRICT;
 CREATE TABLE snd_files(
   file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
@@ -852,17 +855,125 @@ CREATE TABLE rcv_roster_transfers(
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
 ) STRICT;
-CREATE TABLE wallet_seeds(
-  wallet_seed_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  entropy BLOB NOT NULL CHECK(length(entropy) = 32), -- BIP-39 entropy, 24 words
-  next_account_index INTEGER CHECK(next_account_index BETWEEN 0 AND 2147483648),
-  single_seed INTEGER NOT NULL DEFAULT 1
+CREATE TABLE file_badge_proofs(
+  badge_proof_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
+  proof_kind TEXT NOT NULL,
+  badge_proof BLOB NOT NULL,
+  badge_pres_header BLOB NOT NULL,
+  badge_key_idx INTEGER NOT NULL,
+  badge_type TEXT NOT NULL,
+  badge_expiry TEXT NOT NULL,
+  badge_extra TEXT NOT NULL,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL
 ) STRICT;
-CREATE TABLE wallet_accounts(
-  wallet_account_id INTEGER PRIMARY KEY AUTOINCREMENT,
-  wallet_seed_id INTEGER NOT NULL REFERENCES wallet_seeds ON DELETE CASCADE,
-  account_index INTEGER CHECK(account_index BETWEEN 0 AND 2147483647),
-  user_id INTEGER REFERENCES users ON DELETE SET NULL
+CREATE TABLE invoices(
+  invoice_id TEXT NOT NULL PRIMARY KEY,
+  provider TEXT NOT NULL,
+  price INTEGER NOT NULL,
+  discount_amount INTEGER,
+  credit_amount INTEGER,
+  amount INTEGER NOT NULL,
+  currency TEXT NOT NULL,
+  payment_url TEXT,
+  payment_address TEXT,
+  payment_crypto_currency TEXT,
+  payment_crypto_amount TEXT,
+  expires_at TEXT NOT NULL,
+  status TEXT NOT NULL,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL
+) STRICT;
+CREATE TABLE payments(
+  payment_id TEXT NOT NULL PRIMARY KEY,
+  invoice_id TEXT REFERENCES invoices,
+  provider TEXT NOT NULL,
+  provider_ref TEXT,
+  amount INTEGER,
+  currency TEXT,
+  status TEXT NOT NULL,
+  exception TEXT,
+  subscription_renews_at TEXT,
+  grace_until TEXT,
+  cancelled INTEGER NOT NULL DEFAULT 0,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL
+) STRICT;
+CREATE TABLE badge_prices(
+  price_id TEXT NOT NULL PRIMARY KEY,
+  badge_type TEXT NOT NULL,
+  month_price INTEGER NOT NULL,
+  currency TEXT NOT NULL,
+  status TEXT NOT NULL,
+  created_at TEXT NOT NULL
+) STRICT;
+CREATE TABLE badge_offers(
+  offer_id TEXT NOT NULL PRIMARY KEY,
+  price_id TEXT REFERENCES badge_prices,
+  months INTEGER NOT NULL,
+  free_months INTEGER,
+  discount INTEGER,
+  status TEXT NOT NULL,
+  created_at TEXT NOT NULL
+) STRICT;
+CREATE TABLE badge_purchases(
+  badge_purchase_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  purchase_key BLOB NOT NULL,
+  master_key BLOB NOT NULL,
+  initial_badge_type TEXT NOT NULL,
+  current_badge_type TEXT NOT NULL,
+  status TEXT NOT NULL,
+  created_at TEXT NOT NULL,
+  updated_at TEXT NOT NULL,
+  user_id INTEGER REFERENCES users ON DELETE CASCADE,
+  purchase_priv_key BLOB,
+  alert_acked_kind TEXT,
+  alert_acked_episode TEXT,
+  alert_snooze_until TEXT,
+  badge_code_redemption_id INTEGER REFERENCES badge_code_redemptions,
+  UNIQUE(purchase_key)
+) STRICT;
+CREATE TABLE badge_ledger(
+  entry_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  entry_uuid TEXT NOT NULL,
+  badge_purchase_id INTEGER NOT NULL REFERENCES badge_purchases ON DELETE CASCADE,
+  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,
+  created_at TEXT NOT NULL,
+  entry_type TEXT NOT NULL,
+  entry_credit_type TEXT,
+  entry_debit_type TEXT
+  ,
+  entry_type_unknown INTEGER NOT NULL DEFAULT 0,
+  entry_type_value TEXT,
+  balance_checked INTEGER
+) STRICT;
+CREATE TABLE badge_issuances(
+  issuance_id TEXT NOT NULL PRIMARY KEY,
+  badge_purchase_id INTEGER NOT NULL REFERENCES badge_purchases ON DELETE CASCADE,
+  entry_id INTEGER REFERENCES badge_ledger,
+  badge_type TEXT NOT NULL,
+  period_start TEXT NOT NULL,
+  period_end TEXT NOT NULL,
+  expiry TEXT NOT NULL,
+  credential BLOB NOT NULL,
+  created_at TEXT NOT NULL
+) STRICT;
+CREATE TABLE badge_code_redemptions(
+  badge_code_redemption_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
+  code TEXT NOT NULL,
+  purchase_key BLOB NOT NULL,
+  purchase_priv_key BLOB NOT NULL,
+  master_key BLOB NOT NULL,
+  created_at TEXT NOT NULL,
+  UNIQUE(user_id, code)
 ) STRICT;
 CREATE INDEX contact_profiles_index ON contact_profiles(
   display_name,
@@ -1398,12 +1509,35 @@ CREATE INDEX idx_files_roster_transfer_id ON files(roster_transfer_id);
 CREATE INDEX idx_chat_items_item_signed_by_group_member_id ON chat_items(
   item_signed_by_group_member_id
 );
-CREATE UNIQUE INDEX idx_wallet_seeds_single_seed ON wallet_seeds(single_seed);
-CREATE UNIQUE INDEX idx_wallet_accounts_wallet_seed_id_account_index ON wallet_accounts(
-  wallet_seed_id,
-  account_index
+CREATE UNIQUE INDEX idx_file_badge_proofs_file_id_kind ON file_badge_proofs(
+  file_id,
+  proof_kind
+);
+CREATE INDEX idx_payments_provider_ref ON payments(provider, provider_ref);
+CREATE INDEX idx_payments_invoice ON payments(invoice_id);
+CREATE INDEX idx_badge_offers_price ON badge_offers(price_id);
+CREATE UNIQUE INDEX idx_badge_ledger_uuid ON badge_ledger(entry_uuid);
+CREATE INDEX idx_badge_ledger_purchase ON badge_ledger(
+  badge_purchase_id,
+  entry_id
+);
+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
+);
+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(
+  user_id
+);
+CREATE UNIQUE INDEX idx_badge_purchases_code_redemption ON badge_purchases(
+  badge_code_redemption_id
 );
-CREATE INDEX idx_wallet_accounts_user_id ON wallet_accounts(user_id);
 CREATE TRIGGER on_group_members_insert_update_summary
 AFTER INSERT ON group_members
 FOR EACH ROW

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
@@ -693,18 +694,21 @@ type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, Ver
 
 type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Preferences) :. BadgeRow :. ContactDomainRow
 
-toGroupInfo :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
+toGroupInfo :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> (GroupInfo, GroupKeysRow)
 toGroupInfo now cxt userContactId chatTags ((groupId, localDisplayName, displayName, fullName, shortDescr, localAlias, description, image, groupType_, groupLink_, publicGroupId_) :. accessRow :. (enableNtfs_, sendRcpts, BI favorite, groupPreferences, memberAdmission) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. preparedGroupRow :. businessRow :. (BI useRelays, relayOwnStatus, uiThemes, currentMembers, publicMemberCount, rosterVersion, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri, groupDomainVerified) :. groupKeysRow :. userMemberRow) =
   let membership = (toGroupMember now userContactId userMemberRow) {memberChatVRange = vr cxt}
       chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
       fullGroupPreferences = mergeGroupPreferences groupPreferences
       publicGroup = toPublicGroupProfile groupType_ groupLink_ publicGroupId_ (toPublicGroupAccess accessRow)
-      groupKeys = toGroupKeys publicGroupId_ groupKeysRow
       groupProfile = GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission}
       businessChat = toBusinessChatInfo (toPublicGroupAccess accessRow >>= groupDomainClaim) businessRow
       preparedGroup = toPreparedGroup preparedGroupRow
       groupSummary = GroupSummary {currentMembers, publicMemberCount}
-   in GroupInfo {groupId, useRelays = BoolDef useRelays, relayOwnStatus, localDisplayName, groupProfile, localAlias, businessChat, fullGroupPreferences, membership, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, preparedGroup, chatTags, chatItemTTL, uiThemes, groupSummary, rosterVersion, customData, membersRequireAttention, viaGroupLinkUri, groupKeys, groupDomainVerified = unBI <$> groupDomainVerified}
+      gInfo = GroupInfo {groupId, useRelays = BoolDef useRelays, relayOwnStatus, localDisplayName, groupProfile, localAlias, businessChat, fullGroupPreferences, membership, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, preparedGroup, chatTags, chatItemTTL, uiThemes, groupSummary, rosterVersion, customData, membersRequireAttention, viaGroupLinkUri, groupDomainVerified = unBI <$> groupDomainVerified}
+   in (gInfo, groupKeysRow)
+
+toGroupInfo_ :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
+toGroupInfo_ now cxt userContactId chatTags row = fst $ toGroupInfo now cxt userContactId chatTags row
 
 toPreparedGroup :: PreparedGroupRow -> Maybe PreparedGroup
 toPreparedGroup = \case
@@ -732,11 +736,35 @@ toPublicGroupAccess (groupWebPage, groupDomain_, domainWebPage_, allowEmbedding_
     domainWebPage = maybe False unBI domainWebPage_
     allowEmbedding = maybe False unBI allowEmbedding_
 
-toGroupKeys :: Maybe B64UrlByteString -> GroupKeysRow -> Maybe GroupKeys
-toGroupKeys (Just publicGroupId) (rootPrivKey_, rootPubKey_, Just memberPrivKey) =
-  (\grk -> GroupKeys {publicGroupId, groupRootKey = grk, memberPrivKey})
-    <$> (GRKPrivate <$> rootPrivKey_ <|> GRKPublic <$> rootPubKey_)
-toGroupKeys _ _ = Nothing
+mkGroupKeys :: DB.Connection -> StoreCxt -> GroupInfo -> GroupKeysRow -> ExceptT StoreError IO GroupKeys
+mkGroupKeys db cxt g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup}, membership} (rootPrivKey, rootPubKey, memberPrivKey_) = do
+  memberPrivKey <- case memberPrivKey_ of
+    Just k -> pure k
+    Nothing -> do
+      (_, k) <- atomically $ C.generateKeyPair (drg cxt)
+      setUserMemberKey db groupId (groupMemberId' membership) k
+  pure $ case (useRelays' g, isJust publicGroup, GRKPrivate <$> rootPrivKey <|> GRKPublic <$> rootPubKey) of
+    (False, _, _) -> GKGroup {memberPrivKey}
+    (True, True, Just groupRootKey) -> GKPublicGroup {groupRootKey, memberPrivKey}
+    (True, True, Nothing) -> GKPreparedPublicGroup {memberPrivKey}
+    (True, False, _) -> GKRelayRequest {memberPrivKey}
+
+setUserMemberKey :: DB.Connection -> GroupId -> GroupMemberId -> C.PrivateKeyEd25519 -> ExceptT StoreError IO C.PrivateKeyEd25519
+setUserMemberKey db groupId membershipId newKey = do
+  currentTs <- liftIO getCurrentTime
+  memberPrivKey <-
+    ExceptT . firstRow fromOnly (SEGroupNotFound groupId) $
+      DB.query
+        db
+        [sql|
+          UPDATE groups
+          SET member_priv_key = COALESCE(member_priv_key, ?), updated_at = ?
+          WHERE group_id = ?
+          RETURNING member_priv_key
+        |]
+        (newKey, currentTs, groupId)
+  liftIO $ DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (C.publicKey memberPrivKey, currentTs, membershipId)
+  pure memberPrivKey
 
 toGroupMember :: UTCTime -> Int64 -> GroupMemberRow -> GroupMember
 toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, BI showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. profileRow :. (createdAt, updatedAt) :. (supportChatTs_, supportChatUnread, supportChatMemberAttention, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) =
@@ -898,8 +926,18 @@ addGroupChatTags db g@GroupInfo {groupId} = do
   chatTags <- getGroupChatTags db groupId
   pure (g :: GroupInfo) {chatTags}
 
+getGroupInfoKeys :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO GroupInfoKeys
+getGroupInfoKeys db cxt user groupId = do
+  (g@GroupInfo {membership}, keysData) <- getGroupInfoRow db cxt user groupId
+  gks <- mkGroupKeys db cxt g keysData
+  let membership' = membership {memberPubKey = Just $ C.publicKey $ memberPrivKey gks} :: GroupMember
+  pure $ GIK (g :: GroupInfo) {membership = membership'} gks
+
 getGroupInfo :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO GroupInfo
-getGroupInfo db cxt User {userId, userContactId} groupId = ExceptT $ do
+getGroupInfo db cxt user groupId = fst <$> getGroupInfoRow db cxt user groupId
+
+getGroupInfoRow :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupKeysRow)
+getGroupInfoRow db cxt User {userId, userContactId} groupId = ExceptT $ do
   currentTs <- getCurrentTime
   chatTags <- getGroupChatTags db groupId
   firstRow (toGroupInfo currentTs cxt userContactId chatTags) (SEGroupNotFound groupId) $

src/Simplex/Chat/Terminal/Input.hs

@@ -80,7 +80,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
       CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
       CRChatItemsDeleted u ((ChatItemDeletion (AChatItem _ _ cInfo _) _) : _) _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
       CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
-      CRGroupDeletedUser u g _ -> whenCurrUser cc u $ unsetActiveGroup ct g
+      CRGroupDeletedUser u g _ _ -> whenCurrUser cc u $ unsetActiveGroup ct g
       CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
       CRCmdOk _ -> case cmd of
         Right APIDeleteUser {} -> setActive ct ""

src/Simplex/Chat/Types.hs

@@ -30,7 +30,9 @@
 module Simplex.Chat.Types where
 
 import Control.Applicative ((<|>))
+import Control.Concurrent.STM (TVar)
 import Crypto.Number.Serialize (os2ip)
+import Crypto.Random (ChaChaDRG)
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.Encoding as JE
@@ -437,7 +439,7 @@ instance ToJSON ConnReqUriHash where
 
 data RequestEntity
   = REContact Contact
-  | REBusinessChat GroupInfo GroupMember
+  | REBusinessChat GroupInfoKeys GroupMember
 
 type RepeatRequest = Bool
 
@@ -479,13 +481,31 @@ groupRootPubKey :: GroupRootKey -> C.PublicKeyEd25519
 groupRootPubKey (GRKPrivate pk) = C.publicKey pk
 groupRootPubKey (GRKPublic pk) = pk
 
-data GroupKeys = GroupKeys
-  { publicGroupId :: B64UrlByteString,
-    groupRootKey :: GroupRootKey,
-    memberPrivKey :: C.PrivateKeyEd25519
-  }
+data GroupKeys
+  = GKGroup
+      { memberPrivKey :: C.PrivateKeyEd25519
+      }
+  | GKPublicGroup
+      { groupRootKey :: GroupRootKey,
+        memberPrivKey :: C.PrivateKeyEd25519
+      }
+  | GKRelayRequest
+      { memberPrivKey :: C.PrivateKeyEd25519
+      }
+  | GKPreparedPublicGroup
+      { memberPrivKey :: C.PrivateKeyEd25519
+      }
   deriving (Eq, Show)
 
+isPublicGroup :: GroupKeys -> Bool
+isPublicGroup = \case
+  GKGroup {} -> False
+  GKPublicGroup {} -> True
+  GKRelayRequest {} -> True
+  GKPreparedPublicGroup {} -> True
+
+data GroupInfoKeys = GIK GroupInfo GroupKeys
+
 data GroupInfo = GroupInfo
   { groupId :: GroupId,
     useRelays :: BoolDef,
@@ -510,7 +530,6 @@ data GroupInfo = GroupInfo
     rosterVersion :: Maybe VersionRoster,
     membersRequireAttention :: Int,
     viaGroupLinkUri :: Maybe ConnReqContact,
-    groupKeys :: Maybe GroupKeys,
     groupDomainVerified :: Maybe Bool
   }
   deriving (Eq, Show)
@@ -518,6 +537,9 @@ data GroupInfo = GroupInfo
 useRelays' :: GroupInfo -> Bool
 useRelays' GroupInfo {useRelays} = isTrue useRelays
 
+publicGroup' :: GroupInfo -> Maybe PublicGroupProfile
+publicGroup' g@GroupInfo {groupProfile = GroupProfile {publicGroup}} = if useRelays' g then publicGroup else Nothing
+
 relayServesGroup :: GroupInfo -> Bool
 relayServesGroup GroupInfo {relayOwnStatus} = case relayOwnStatus of
   Just RSInactive -> False
@@ -590,7 +612,7 @@ data GroupLink = GroupLink
 
 data ContactOrGroup = CGContact Contact | CGGroup GroupInfo [GroupMember]
 
-data PreparedChatEntity = PCEContact Contact | PCEGroup {groupInfo :: GroupInfo, hostMember :: GroupMember}
+data PreparedChatEntity = PCEContact Contact | PCEGroup {groupInfo :: GroupInfoKeys, hostMember :: GroupMember}
 
 contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId)
 contactAndGroupIds = \case
@@ -943,6 +965,7 @@ instance ToJSON GroupLinkId where
 
 data GroupInvitation = GroupInvitation
   { fromMember :: MemberIdRole,
+    fromMemberKey :: Maybe MemberKey,
     invitedMember :: MemberIdRole,
     connRequest :: ConnReqInvitation,
     groupProfile :: GroupProfile,
@@ -955,6 +978,7 @@ data GroupInvitation = GroupInvitation
 data GroupLinkInvitation = GroupLinkInvitation
   { fromMember :: MemberIdRole,
     fromMemberName :: ContactName,
+    fromMemberKey :: Maybe MemberKey,
     invitedMember :: MemberIdRole,
     groupProfile :: GroupProfile,
     accepted :: Maybe GroupAcceptance,
@@ -1138,7 +1162,8 @@ memberRestrictions m
 data ReceivedGroupInvitation = ReceivedGroupInvitation
   { fromMember :: GroupMember,
     connRequest :: ConnReqInvitation,
-    groupInfo :: GroupInfo
+    groupInfo :: GroupInfo,
+    groupKeys :: GroupKeys
   }
   deriving (Eq, Show)
 
@@ -1551,7 +1576,8 @@ data FileInvitation = FileInvitation
     fileDigest :: Maybe FileDigest,
     fileConnReq :: Maybe ConnReqInvitation,
     fileInline :: Maybe InlineFileMode,
-    fileDescr :: Maybe FileDescr
+    fileDescr :: Maybe FileDescr,
+    fileBadge :: Maybe BadgeProof
   }
   deriving (Eq, Show)
 
@@ -1566,7 +1592,8 @@ xftpFileInvitation fileName fileSize fileDescr =
       fileDigest = Nothing,
       fileConnReq = Nothing,
       fileInline = Nothing,
-      fileDescr = Just fileDescr
+      fileDescr = Just fileDescr,
+      fileBadge = Nothing
     }
 
 data InlineFileMode
@@ -1620,10 +1647,14 @@ instance ToJSON FileType where
   toJSON = J.String . textEncode
   toEncoding = JE.text . textEncode
 
+data FileProhibited = FileProhibited {maxSize :: Integer, badgeStatus :: Maybe BadgeStatus}
+  deriving (Eq, Show)
+
 data RcvFileTransfer = RcvFileTransfer
   { fileId :: FileTransferId,
     xftpRcvFile :: Maybe XFTPRcvFile,
     fileInvitation :: FileInvitation,
+    fileProhibited :: Maybe FileProhibited,
     fileStatus :: RcvFileStatus,
     fileType :: FileType,
     rcvFileInline :: Maybe InlineFileMode,
@@ -2227,8 +2258,8 @@ type VersionChat = Version ChatVersion
 type VersionRangeChat = VersionRange ChatVersion
 
 -- | Store-wide context passed to store functions in place of the bare `vr`
--- parameter. Built from config by mkStoreCxt; more fields are added here over time.
-data StoreCxt = StoreCxt {vr :: VersionRangeChat, badgeKeys :: Map Int BBSPublicKey}
+-- parameter. Built from config by storeCxt; more fields are added here over time.
+data StoreCxt = StoreCxt {vr :: VersionRangeChat, badgeKeys :: Map Int BBSPublicKey, drg :: TVar ChaChaDRG}
 
 pattern VersionChat :: Word16 -> VersionChat
 pattern VersionChat v = Version v
@@ -2334,10 +2365,6 @@ instance FromJSON GroupSummary where
   parseJSON = $(JQ.mkParseJSON defaultJSON ''GroupSummary)
   omittedField = Just GroupSummary {currentMembers = 0, publicMemberCount = Nothing}
 
-$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GRK") ''GroupRootKey)
-
-$(JQ.deriveJSON defaultJSON ''GroupKeys)
-
 $(JQ.deriveJSON defaultJSON ''GroupInfo)
 
 $(JQ.deriveJSON defaultJSON ''Group)
@@ -2370,6 +2397,8 @@ $(JQ.deriveJSON defaultJSON ''GroupMemberRef)
 
 $(JQ.deriveJSON defaultJSON ''FileDescr)
 
+$(JQ.deriveJSON defaultJSON ''FileProhibited)
+
 $(JQ.deriveJSON defaultJSON ''FileInvitation)
 
 $(JQ.deriveJSON defaultJSON ''SndFileTransfer)

src/Simplex/Chat/View.hs

@@ -41,9 +41,12 @@ import Numeric (showFFloat)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
 import Simplex.Chat.Help
-import Simplex.Chat.Library.Commands (maxImageSize)
+import Simplex.Chat.Library.Commands (badgeServiceErrorText, maxImageSize)
 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 (..), BadgeState (..))
 import Simplex.Chat.Messages hiding (NewChatItem (..))
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Operators
@@ -189,6 +192,10 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
   CRContactRequestRejected u UserContactRequest {localDisplayName = c} _ct_ -> ttyUser u [ttyContact c <> ": contact request rejected"]
   CRServiceResponse u resp -> ttyUser u ["service response: " <> viewJSON resp]
   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
+  CRBadgeLedger u entries -> ttyUser u $ viewBadgeLedger entries
   CRWallet u accounts_ -> ttyUser u $ case accounts_ of
     Nothing -> ["no wallet on this device"]
     Just [] -> ["wallet, no accounts for this profile"]
@@ -249,7 +256,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
             "use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group (also clears the rejection)"
           ]
     | otherwise -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g
-  CRGroupDeletedUser u g signed -> ttyUser u [ttyGroup' g <> ": you deleted the group" <> signedStr signed]
+  CRGroupDeletedUser u g signed local -> ttyUser u [ttyGroup' g <> (if local then ": you deleted your local copy of the group" else ": you deleted the group" <> signedStr signed)]
   CRForwardPlan u count itemIds fc -> ttyUser u $ viewForwardPlan count itemIds fc
   CRChatMsgContent u mc -> ttyUser u $ ttyMsgContent mc <> viewMsgTestInfo testView mc
   CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
@@ -482,6 +489,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
@@ -1850,9 +1859,41 @@ 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]
+
+viewBadgeLedger :: [StatementEntry] -> [StyledString]
+viewBadgeLedger [] = ["no ledger entries"]
+viewBadgeLedger entries = map viewEntry entries
+  where
+    viewEntry StatementEntry {createdAt, entryType, changeMonths, balanceMonths, balanceStartTs} =
+      plain $ day createdAt <> " " <> entryKind entryType <> " " <> withSign changeMonths <> " -> " <> tshow balanceMonths <> ", from " <> day balanceStartTs
+    entryKind = \case
+      SECredit c -> creditTypeTag c
+      SEDebit d -> debitTypeTag d
+    withSign n = (if n >= 0 then "+" else "") <> tshow n
+
+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]
@@ -2476,11 +2517,25 @@ viewReceivedFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZon
 viewReceivedFileInvitation from file ts tz meta = receivedWithTime_ ts tz from [] meta (receivedFileInvitation_ file) False
 
 receivedFileInvitation_ :: CIFile d -> [StyledString]
-receivedFileInvitation_ CIFile {fileId, fileName, fileSize, fileStatus} =
+receivedFileInvitation_ CIFile {fileId, fileName, fileSize, fileStatus, fileProhibited} =
   ["sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)"]
-    <> case fileStatus of
-      CIFSRcvAccepted -> []
-      _ -> ["use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"]
+    <> case fileProhibited of
+      Just fp -> [prohibitedFileReason fp]
+      Nothing -> case fileStatus of
+        CIFSRcvAccepted -> []
+        _ -> ["use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"]
+
+prohibitedFileReason :: FileProhibited -> StyledString
+prohibitedFileReason FileProhibited {maxSize, badgeStatus} =
+  "file is above the limit of " <> sShow maxSize <> " bytes: " <> reason
+  where
+    reason = case badgeStatus of
+      Nothing -> "sender has no badge"
+      Just BSActive -> "above the limit of the sender badge"
+      Just BSExpired -> "sender badge expired"
+      Just BSExpiredOld -> "sender badge expired"
+      Just BSFailed -> "sender badge did not verify"
+      Just BSUnknownKey -> "sender badge key is not known"
 
 humanReadableSize :: Integer -> StyledString
 humanReadableSize size
@@ -2824,6 +2879,16 @@ viewChatError isCmd logLevel testView = \case
     CEAgentNoSubResult connId -> ["no subscription result for connection: " <> sShow connId]
     CEServerProtocol p -> [plain $ "Servers for protocol " <> strEncode p <> " cannot be configured by the users"]
     CECommandError e -> ["bad chat command: " <> plain e]
+    CEBadgeRedeemError e ->
+      let reason = case e of
+            BREInvalidCode -> "invalid code"
+            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]
     CEAgentCommandError e -> ["agent command error: " <> plain e]
     CEInvalidFileDescription e -> ["invalid file description: " <> plain e]
     CEConnectionIncognitoChangeProhibited -> ["incognito mode change prohibited"]

src/Simplex/Chat/Web.hs

@@ -24,7 +24,7 @@ module Simplex.Chat.Web
 where
 
 import Control.Concurrent.STM (check, flushTQueue)
-import Control.Exception (SomeException, catch)
+import Control.Exception (SomeException)
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except (runExceptT)
@@ -42,7 +42,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
 import Data.Time.Clock (UTCTime, getCurrentTime)
-import Simplex.Chat.Controller (ChatController (..), CorsOrigin (..), PublishableGroup (..), WebPreviewConfig (..), WebPreviewState (..), mkStoreCxt)
+import Simplex.Chat.Controller (ChatController (..), CorsOrigin (..), PublishableGroup (..), WebPreviewConfig (..), WebPreviewState (..), storeCxt)
 import Simplex.Chat.Markdown (FormattedText (..), MarkdownList, parseMaybeMarkdownList)
 import Simplex.Chat.Messages
   ( CChatItem (..),
@@ -75,7 +75,7 @@ import Simplex.Chat.Types
   )
 import Simplex.Messaging.Agent.Store.Common (withTransaction)
 import Simplex.Messaging.Encoding.String (strEncode)
-import Simplex.Messaging.Util (catchOwn, eitherToMaybe, safeDecodeUtf8, tshow)
+import Simplex.Messaging.Util (catchOwn, catchOwn', eitherToMaybe, safeDecodeUtf8, tshow)
 import Simplex.Messaging.Parsers (defaultJSON)
 import System.Directory (createDirectoryIfMissing, listDirectory, removeFile, renameFile)
 import System.FilePath (dropExtension, takeExtension, (</>))
@@ -137,7 +137,7 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva
     seedRoutinePending wps
     forever $ workerLoop wps `catchOwn` \e -> logError ("web preview worker error: " <> tshow e)
   where
-    cxt = mkStoreCxt (config cc)
+    cxt = storeCxt cc
 
     workerLoop wps@WebPreviewState {priorityRender, filesToRemove, corsNeeded, routinePending, wakeSignal} = do
       drainRemovals
@@ -150,7 +150,7 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva
         drainRemovals = atomically (tryReadTQueue filesToRemove) >>= \case
           Nothing -> pure ()
           Just f -> do
-            removeFile (webJsonDir </> f) `catch` \(_ :: SomeException) -> pure ()
+            removeFile (webJsonDir </> f) `catchOwn'` \(_ :: SomeException) -> pure ()
             drainRemovals
 
         -- flush the whole queue and render each group once: a burst of changes in one
@@ -202,7 +202,7 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva
     renderOneGroup WebPreviewState {publishableGroupIds} gId = do
       publishable <- atomically $ M.member gId <$> readTVar publishableGroupIds
       when publishable $
-        renderOrRemoveStale `catch` \(e :: SomeException) ->
+        renderOrRemoveStale `catchOwn'` \(e :: SomeException) ->
           logError $ "web preview: error rendering group " <> T.pack (show gId) <> ": " <> T.pack (show e)
       where
         renderOrRemoveStale = do
@@ -217,7 +217,7 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva
                 modifyTVar' publishableGroupIds (M.delete gId)
                 pure $ pgFileName <$> pg
               forM_ fName $ \f ->
-                removeFile (webJsonDir </> f) `catch` \(_ :: SomeException) -> pure ()
+                removeFile (webJsonDir </> f) `catchOwn'` \(_ :: SomeException) -> pure ()
               logInfo $ "web preview: group " <> T.pack (show gId) <> " no longer publishable"
 
     findUser f = go users
@@ -262,7 +262,7 @@ renderGroupPreview WebPreviewConfig {webJsonDir, webPreviewItemCount} cc user gI
       pure $ corsEntry publicGroupId <$> publicGroupAccess
     Nothing -> pure Nothing
   where
-    cxt = mkStoreCxt (config cc)
+    cxt = storeCxt cc
 
 channelContentChanged :: ChatController -> Int64 -> STM ()
 channelContentChanged cc gId =