dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-07-02 07:01:44 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge origin/master into sh/namespace

Browse Source 
The names (simplex_name / RSLV) feature and master's badge feature both
extended the contact/group profile row layer. Resolution keeps both, with
simplex_name ordered last (chronological - it is the newer column):
- Profile/LocalProfile gain badge + simplex_name; simplex_name last in the
  data types, record builds, schema, and SQL row types/SELECTs/INSERTs
- SQL row types, SELECTs and INSERT/UPDATE lists carry both badge_* and
  simplex_name columns (simplex_name after badge)
- migration lists ordered by date (master 0601/0602 before names 0603+)
- SQLite chat_schema.sql regenerated; Postgres chat_schema.sql hand-merged

Verified: lib + test suite build; SchemaDump, Operators, Protocol and
direct/group profile round-trip tests pass.
This commit is contained in:
shum
2026-06-23 11:05:27 +00:00
parent e08367dc9b 514bfc8519
commit e9656d0b18
191 changed files with 11177 additions and 1653 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+17 -2
View File
@@ -29,6 +29,7 @@ import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime, nominalDay)
import Simplex.Chat.Controller
import Simplex.Chat.Badges (BBSPublicKeyStr (..))
import Simplex.Chat.Library.Commands
import Simplex.Chat.Operators
import Simplex.Chat.Operators.Presets
@@ -65,6 +66,17 @@ defaultChatConfig =
tbqSize = 1024
},
chatVRange = supportedChatVRange,
badgePublicKeys =
M.fromList
[ (1, toBBSPublicKey "mW_5Zp1wHnXDF56wOZwFcRjGrf0GLLsfyymIQDqYoWfjfvS7oQWSfi7hH65N8JhuE9x8wbKXHidnQLO4GnOSMP_bRKUMH1qIzv5SQKFHNM8G4PaWcTcri8iZLc-3xhSI"),
(2, toBBSPublicKey "odGCB7uVDXTURsHgSvSciByV4Q3-3ZvEB8myDsDJqm-PwOYc5-At36uc7n_pyUDxEQEHr9i4RJgFih2FSArPW-EQBXNPNf4wTtA0znn74qLEGc4fh9pVYPEIm_ZGbnsJ"),
(3, toBBSPublicKey "txkT2003WMjc43KvYvPKEcR970NLmw5UZY51eUqgk91sgp53idt1HTlKYvnrEttJDFMlctYf1-bpri0e9DhBQ-xk1J4WoLN2uif_1OcA1pGCobpk9lwtsq1Idek4biy0"),
(4, toBBSPublicKey "q_YzegihaLYrEm9z3cAghsfDGNZfXuEpQGMJERJQS4M0Szl4gvSC_fV_muKc3NIMA_8iYuBN8qyvb5U55RctCRn3kleFQ4sqf-WBgoydX6UVo7BsYcUbXWWEFZXlOGIH"),
(5, toBBSPublicKey "oqymHASH_okefShrnz4HnTooUNlE1WoDRnSrgd0bTCpOacgJWBsMpwZpdmYlX-vQAKAC_zmI4VdKoOznnhW-sdUXZw6bthCi5JYjGxCR1Co27i1tix5UXCTbR5Jp901-"),
(6, toBBSPublicKey "kDqaB6zKSRp_97QPFj5JPDlo0vzfSTLSp9goFx1qajv4q4H6dR6BbkmWZ4xx_9Q2AxmcpqcV0ethz1OH-Jk_Sz2J1mIz1PUVM9LkdLhi_PNtqhezzO5dbVs-HJ1fNqe6"),
(7, toBBSPublicKey "rl36D5mg2N3NmmEybxE_RBeU9YZ_zeXNPfp7ZMLtUEuf2Mo4OQM_Up1v5rX_IqICD-AIJcuyptEBsELx_PJQzpmiNuG5I4cWO6HkRKtc6fVFvgZMrDJjaascPd1CIyxX"),
(8, toBBSPublicKey "joM3Bnt7JPt5JiwQwERHGjro2iVZ0mPD_clUh4hzkhxvbjuFrWuTmfSNA8PWBqGKEGNl13aRi1pMf6yY14E27c5C71JxWm7T-rZaBrGPEUWifhD-qidWuf3PU7KJCCWd")
],
confirmMigrations = MCConsole,
-- this property should NOT use operator = Nothing
-- non-operator servers can be passed via options
@@ -116,6 +128,7 @@ defaultChatConfig =
highlyAvailable = False,
deliveryWorkerDelay = 0,
deliveryBucketSize = 10000,
webPreviewConfig = Nothing,
channelSubscriberRole = GRObserver,
relayChecksInterval = 15 * 60, -- 15 minutes
relayInactiveTTL = nominalDay,
@@ -140,11 +153,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, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, deviceName, webPreviewConfig, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, 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, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'}
config = cfg {logLevel, showReactions, tbqSize, 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
@@ -182,6 +195,7 @@ newChatController
deliveryJobWorkers <- TM.emptyIO
relayRequestWorkers <- TM.emptyIO
relayGroupLinkChecksAsync <- newTVarIO Nothing
webPreviewState <- forM webPreviewConfig $ \_ -> newWebPreviewState
chatRelayTests <- TM.emptyIO
expireCIThreads <- TM.emptyIO
expireCIFlags <- TM.emptyIO
@@ -226,6 +240,7 @@ newChatController
deliveryJobWorkers,
relayRequestWorkers,
relayGroupLinkChecksAsync,
webPreviewState,
chatRelayTests,
expireCIThreads,
expireCIFlags,
src/Simplex/Chat/Badges.hs
+414
View File
@@ -0,0 +1,414 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Chat.Badges
( BadgeType (..),
BadgeStatus (..),
BadgeInfo (..),
BadgeCredential (..),
BadgeProof (..),
LocalBadge (..),
JSONBadge (..),
BBSPublicKeyStr (..),
localBadgeInfo,
localBadgeStatus,
maxXFTPFileSize,
maxFileSizeSupporter,
maxFileSizeLegend,
BadgePresHeaderTag (..),
BadgePresHeader (..),
BadgePurchase (..),
BadgeMasterKey (..),
BadgeRequest (..),
VerifiedBadgeRequest (..),
bbsBadgeHeader,
generateMasterKey,
verifyPayment,
issueBadge,
verifyCredential,
generateBadgeProof,
badgeProof,
verifyBadge,
verifyBadge_,
mkBadgeStatus,
BadgeRow,
badgeToRow,
localBadgeToRow,
rowToBadge,
) where
import Control.Concurrent.STM
import Crypto.Random (ChaChaDRG)
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson.TH as JQ
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight)
import Data.Int (Int64)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.String
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, nominalDay)
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.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
#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
-- Badge type
data BadgeType
= BTSupporter
| BTLegend
| BTInvestor
| BTUnknown Text
deriving (Eq, Show)
instance TextEncoding BadgeType where
textEncode = \case
BTSupporter -> "supporter"
BTLegend -> "legend"
BTInvestor -> "investor"
BTUnknown tag -> tag
textDecode s = Just $ case s of
"supporter" -> BTSupporter
"legend" -> BTLegend
"investor" -> BTInvestor
tag -> BTUnknown tag
instance ToJSON BadgeType where
toJSON = textToJSON
toEncoding = textToEncoding
instance FromJSON BadgeType where
parseJSON = textParseJSON "BadgeType"
-- Badge status
data BadgeStatus = BSActive | BSExpired | BSExpiredOld | BSFailed | BSUnknownKey
deriving (Eq, Show)
-- Disclosed badge content (BBS messages 1, 2, 3)
data BadgeInfo = BadgeInfo
{ badgeType :: BadgeType,
badgeExpiry :: Maybe UTCTime,
badgeExtra :: Text
}
deriving (Eq, Show)
-- a badge expired longer than this ago is BSExpiredOld and is not shown in the UI
badgeOldInterval :: NominalDiffTime
badgeOldInterval = 31 * nominalDay
-- the verification outcome of a received proof: Just True = verified, Just False = failed,
-- Nothing = the proof's key index is not among this app version's configured keys (BSUnknownKey).
mkBadgeStatus :: UTCTime -> Maybe Bool -> BadgeInfo -> BadgeStatus
mkBadgeStatus now verified BadgeInfo {badgeExpiry} = case verified of
Nothing -> BSUnknownKey
Just False -> BSFailed
Just True -> case badgeExpiry of
Just e
| addUTCTime badgeOldInterval e < now -> BSExpiredOld
| e < now -> BSExpired
_ -> BSActive
-- A badge credential (own, secret) and a proof (a presentation) are independent records.
-- badgeKeyIdx is the issuer key index: it tells verifiers which configured key to use.
-- Only proofs ride the wire (in a profile); credentials come from the badge service. Neither is
-- ever serialized as a sum - each travels as its own record, so the JSON carries no credential/proof tag.
data BadgeCredential = BadgeCredential
{ badgeKeyIdx :: Int,
masterKey :: BadgeMasterKey,
signature :: BBSSignature,
badgeInfo :: BadgeInfo
}
deriving (Eq, Show)
data BadgeProof = BadgeProof
{ badgeKeyIdx :: Int,
presHeader :: BBSPresHeader,
proof :: BBSProof,
badgeInfo :: BadgeInfo
}
deriving (Eq, Show)
-- Local badge: a stored badge plus its display status (the in-memory sum; never serialized as a sum).
-- OwnBadge - the user's own credential (loaded from the DB).
-- PeerBadge - a verified peer proof (from the DB, or received over the wire).
-- ShownBadge - decoded from a crypto-free profile JSON for display only: no crypto, so it cannot be sent.
data LocalBadge
= OwnBadge BadgeCredential BadgeStatus
| PeerBadge BadgeProof BadgeStatus
| ShownBadge BadgeInfo BadgeStatus
deriving (Eq, Show)
localBadgeInfo :: LocalBadge -> BadgeInfo
localBadgeInfo = \case
OwnBadge BadgeCredential {badgeInfo} _ -> badgeInfo
PeerBadge BadgeProof {badgeInfo} _ -> badgeInfo
ShownBadge i _ -> i
localBadgeStatus :: LocalBadge -> BadgeStatus
localBadgeStatus = \case
OwnBadge _ st -> st
PeerBadge _ st -> st
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 = gb 2
maxFileSizeLegend :: Int64
maxFileSizeLegend = gb 5
maxXFTPFileSize :: Maybe LocalBadge -> Int64
maxXFTPFileSize = \case
Just b | localBadgeStatus b == BSActive -> case badgeType (localBadgeInfo b) of
BTLegend -> maxFileSizeLegend
_ -> maxFileSizeSupporter
_ -> maxFileSize
-- 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 BadgePresHeaderTag = PHTestTag | PHUnknownTag Char
instance StrEncoding BadgePresHeaderTag where
strEncode = B.singleton . \case
PHTestTag -> 'T'
PHUnknownTag c -> c
strP = tag <$> A.anyChar
where
tag = \case
'T' -> PHTestTag
c -> PHUnknownTag c
data BadgePresHeader
= PHTest ByteString
| PHUnknown Char ByteString
instance StrEncoding BadgePresHeader where
strEncode = \case
PHTest nonce -> strEncode PHTestTag <> nonce
PHUnknown c b -> strEncode (PHUnknownTag c) <> b
strP =
strP >>= \case
PHTestTag -> PHTest <$> A.takeByteString
PHUnknownTag c -> PHUnknown c <$> A.takeByteString
-- v6.5.x accepts both; v7 will reject PHTest/PHUnknown
badgePresHeaderAccepted :: BadgePresHeader -> Bool
badgePresHeaderAccepted = \case
PHTest _ -> True
PHUnknown _ _ -> True
-- Payment proof
data BadgePurchase
= BPAppleReceipt Text
| BPGoogleReceipt Text
| BPStripeSession
| BPRedeemCode Text
deriving (Eq, Show)
-- Master key
newtype BadgeMasterKey = BadgeMasterKey ByteString
deriving newtype (Eq, Show, StrEncoding)
instance ToJSON BadgeMasterKey where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromJSON BadgeMasterKey where
parseJSON = strParseJSON "BadgeMasterKey"
generateMasterKey :: TVar ChaChaDRG -> IO BadgeMasterKey
generateMasterKey drg = BadgeMasterKey <$> atomically (C.randomBytes 32 drg)
-- Workflow types
data BadgeRequest = BadgeRequest
{ masterKey :: BadgeMasterKey,
badgeInfo :: BadgeInfo
}
deriving (Show)
newtype VerifiedBadgeRequest = VerifiedBadgeRequest BadgeRequest
deriving (Show)
-- Constants
bbsBadgeHeader :: BBSHeader
bbsBadgeHeader = BBSHeader "SimpleX badges v1"
bbsBadgeMessageCount :: Int
bbsBadgeMessageCount = 4
bbsBadgeDisclosedIndexes :: [Int]
bbsBadgeDisclosedIndexes = [1, 2, 3]
-- Message encoding
encodeExpiry :: Maybe UTCTime -> ByteString
encodeExpiry = maybe "lifetime" strEncode
badgeMessages :: BadgeMasterKey -> BadgeInfo -> [ByteString]
badgeMessages (BadgeMasterKey ms) info = ms : badgeInfoMessages info
badgeInfoMessages :: BadgeInfo -> [ByteString]
badgeInfoMessages BadgeInfo {badgeType, badgeExpiry, badgeExtra} =
[encodeExpiry badgeExpiry, encodeUtf8 (textEncode badgeType), encodeUtf8 badgeExtra]
-- Payment verification (stub - always passes)
verifyPayment :: BadgePurchase -> BadgeRequest -> IO (Maybe VerifiedBadgeRequest)
verifyPayment _payment req = pure $ Just (VerifiedBadgeRequest req)
-- Server-side: issue a badge credential, recording which issuer key signed it
issueBadge :: Int -> BBSSecretKey -> VerifiedBadgeRequest -> IO (Either String BadgeCredential)
issueBadge keyIdx sk (VerifiedBadgeRequest BadgeRequest {masterKey, badgeInfo})
| badgeExtra badgeInfo /= "" = pure $ Left "badgeExtra must be empty (reserved)"
| otherwise = fmap (\sig -> BadgeCredential keyIdx masterKey sig badgeInfo) <$> bbsSign sk bbsBadgeHeader (badgeMessages masterKey badgeInfo)
-- Client-side: verify the credential received from server
verifyCredential :: BBSPublicKey -> BadgeCredential -> IO Bool
verifyCredential pk (BadgeCredential _ masterKey signature badgeInfo) =
bbsVerify pk signature bbsBadgeHeader (badgeMessages masterKey badgeInfo)
-- Client-side: generate a proof for a contact/group; the proof carries the credential's key index
generateBadgeProof :: BBSPublicKey -> BadgeCredential -> BBSPresHeader -> IO (Either String BadgeProof)
generateBadgeProof pk (BadgeCredential keyIdx masterKey signature badgeInfo) ph =
fmap (\p -> BadgeProof keyIdx ph p badgeInfo) <$> bbsProofGen pk signature bbsBadgeHeader ph bbsBadgeDisclosedIndexes (badgeMessages masterKey badgeInfo)
-- application-level proof generation with a semantic presentation header
badgeProof :: BBSPublicKey -> BadgeCredential -> BadgePresHeader -> IO (Either String BadgeProof)
badgeProof pk cred ph = generateBadgeProof pk cred (BBSPresHeader $ strEncode ph)
-- Recipient-side: verify a badge proof with the configured key its index points to.
-- Nothing means the key index is not in the configured keys (this app version can't verify it).
verifyBadge :: Map Int BBSPublicKey -> BadgeProof -> IO (Maybe Bool)
verifyBadge keys b@(BadgeProof keyIdx _ _ _) = case M.lookup keyIdx keys of
Nothing -> pure Nothing
Just pk -> Just <$> verifyBadgeWith pk b
verifyBadgeWith :: BBSPublicKey -> BadgeProof -> IO Bool
verifyBadgeWith pk (BadgeProof _ ph@(BBSPresHeader phBytes) proof badgeInfo)
| either (const False) badgePresHeaderAccepted (strDecode phBytes) =
bbsProofVerify pk proof bbsBadgeHeader ph bbsBadgeDisclosedIndexes bbsBadgeMessageCount (badgeInfoMessages badgeInfo)
| otherwise = pure False
verifyBadge_ :: Map Int BBSPublicKey -> Maybe BadgeProof -> IO (Maybe Bool)
verifyBadge_ keys = maybe (pure (Just False)) (verifyBadge keys)
-- DB
instance FromField BadgeType where fromField = fromTextField_ textDecode
instance ToField BadgeType where toField = toField . textEncode
-- (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)
-- receive/store sites have a wire proof + a computed verification outcome;
-- the status here only drives the stored verified flag, the display status is recomputed on load
badgeToRow :: Maybe BadgeProof -> Maybe Bool -> BadgeRow
badgeToRow badge verified = localBadgeToRow $ (`PeerBadge` st) <$> badge
where
st = case verified of
Just True -> BSActive
Just False -> BSFailed
Nothing -> BSUnknownKey
localBadgeToRow :: Maybe LocalBadge -> BadgeRow
localBadgeToRow (Just lb) = case lb of
OwnBadge (BadgeCredential idx (BadgeMasterKey mk) (BBSSignature sg) BadgeInfo {badgeType, badgeExpiry, badgeExtra}) st ->
(Nothing, Nothing, badgeExpiry, Just (textEncode badgeType), verifiedField st, Just badgeExtra, Just (Binary mk), Just (Binary sg), Just idx)
PeerBadge (BadgeProof idx (BBSPresHeader ph) (BBSProof p) BadgeInfo {badgeType, badgeExpiry, badgeExtra}) st ->
(Just (Binary p), Just (Binary ph), badgeExpiry, Just (textEncode badgeType), verifiedField st, Just badgeExtra, Nothing, Nothing, Just idx)
ShownBadge BadgeInfo {badgeType, badgeExpiry, badgeExtra} st ->
(Nothing, Nothing, badgeExpiry, Just (textEncode badgeType), verifiedField st, Just badgeExtra, Nothing, Nothing, Nothing)
where
verifiedField st = case st of
BSFailed -> Just (BI False)
BSUnknownKey -> Nothing
_ -> Just (BI True)
localBadgeToRow Nothing = (Nothing, Nothing, Nothing, Nothing, Just (BI False), Nothing, Nothing, Nothing, Nothing)
rowToBadge :: UTCTime -> BadgeRow -> Maybe LocalBadge
rowToBadge now (p_, ph_, badgeExpiry, type_, verified_, extra_, mk_, sg_, idx_) = do
btText <- type_
bt <- textDecode btText
let info = BadgeInfo {badgeType = bt, badgeExpiry, badgeExtra = maybe "" id extra_}
-- NULL badge_verified means the key index was unknown when stored (Nothing)
st = mkBadgeStatus now (unBI <$> verified_) info
case (mk_, sg_, p_, ph_, idx_) of
(Just (Binary mk), Just (Binary sg), _, _, Just idx) -> Just $ OwnBadge (BadgeCredential idx (BadgeMasterKey mk) (BBSSignature sg) info) st
(_, _, Just (Binary p), Just (Binary ph), Just idx) -> Just $ PeerBadge (BadgeProof idx (BBSPresHeader ph) (BBSProof p) info) st
_ -> Just $ ShownBadge info st
-- JSON
$(JQ.deriveJSON (enumJSON $ dropPrefix "BS") ''BadgeStatus)
$(JQ.deriveJSON defaultJSON ''BadgeInfo)
$(JQ.deriveJSON defaultJSON ''BadgeRequest)
-- Each record is a plain JSON object (defaultJSON), platform-independent and with no credential/proof
-- tag - the context (a proof in a profile, a credential from the service) determines which it is.
$(JQ.deriveJSON defaultJSON ''BadgeCredential)
$(JQ.deriveJSON defaultJSON ''BadgeProof)
-- LocalBadge is sent to the UI/clients WITHOUT crypto - only disclosed info + status. The credential/proof
-- bytes stay core-side. FromJSON reconstructs a display-only badge (empty proof) for read-only consumers
-- (remote host, UI echoes); the authoritative badge is loaded from the DB (rowToBadge), never from this JSON.
data JSONBadge = JSONBadge {badge :: BadgeInfo, status :: BadgeStatus}
$(JQ.deriveJSON defaultJSON ''JSONBadge)
instance ToJSON LocalBadge where
toJSON lb = toJSON $ JSONBadge (localBadgeInfo lb) (localBadgeStatus lb)
toEncoding lb = toEncoding $ JSONBadge (localBadgeInfo lb) (localBadgeStatus lb)
instance FromJSON LocalBadge where
parseJSON v = do
JSONBadge info st <- parseJSON v
pure $ ShownBadge info st
newtype BBSPublicKeyStr = BBSPublicKeyStr {toBBSPublicKey :: BBSPublicKey}
instance IsString BBSPublicKeyStr where
fromString = BBSPublicKeyStr . fromRight (error "bad base64 in BBSPublicKey") . strDecode . B.pack
src/Simplex/Chat/Badges/CLI.hs
+87
View File
@@ -0,0 +1,87 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Offline operator tooling for supporter badges, invoked as `simplex-chat badge ...`.
-- keygen - the issuer keypair: the "secret" signs, the "public" goes into the app config.
-- master-key - the user's master secret (their unlinkability secret; generated client-side in the real flow).
-- sign - bind a user master secret to a badge with the issuer secret, printed as one-line JSON for `/badge add`.
module Simplex.Chat.Badges.CLI (runBadgeCommand) where
import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Time.Format (defaultTimeLocale, parseTimeM)
import Options.Applicative
import Simplex.Chat.Badges
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.BBS (BBSPublicKey (..), BBSSecretKey (..), bbsKeyGen)
import Simplex.Messaging.Encoding.String (strDecode, strEncode, textDecode)
import System.Exit (die)
bbsSecretLen :: Int
bbsSecretLen = 32
data BadgeCommand
= Keygen
| MasterKey
| Sign Int BBSSecretKey BadgeMasterKey BadgeType (Maybe UTCTime)
runBadgeCommand :: [String] -> IO ()
runBadgeCommand args =
handleParseResult (execParserPure defaultPrefs badgeInfo args) >>= \case
Keygen -> keygen
MasterKey -> genMasterKey
Sign keyIdx sk ms badgeType badgeExpiry -> sign keyIdx sk ms badgeType badgeExpiry
where
badgeInfo = info (helper <*> hsubparser badgeCmd) fullDesc
badgeCmd = command "badge" (info (helper <*> badgeCommandP) (progDesc "SimpleX supporter badge tooling"))
badgeCommandP :: Parser BadgeCommand
badgeCommandP =
hsubparser $
command "keygen" (info (pure Keygen) (progDesc "generate an issuer keypair (issuer secret + public, base64url)"))
<> command "master-key" (info (pure MasterKey) (progDesc "generate a user master secret (base64url)"))
<> command "sign" (info signP (progDesc "sign a badge for a user master secret, printed as one-line JSON"))
where
signP =
Sign
<$> option auto (long "key-idx" <> metavar "KEY_IDX" <> help "index of the issuer key in the app config")
<*> option (eitherReader secretR) (long "secret" <> metavar "ISSUER_SECRET" <> help "issuer secret from keygen (base64url)")
<*> option (eitherReader (strDecode . B.pack)) (long "master" <> metavar "MASTER" <> help "user master secret from master-key (base64url)")
<*> option (eitherReader badgeTypeR) (long "type" <> metavar "TYPE" <> help "badge type (supporter, legend, investor)")
<*> option (eitherReader expireR) (long "expire" <> metavar "lifetime|YYYY-MM-DD" <> help "expiry date, or 'lifetime'")
secretR s = do
sk@(BBSSecretKey b) <- strDecode (B.pack s)
if B.length b == bbsSecretLen
then Right sk
else Left "bad issuer secret - use the 'secret' value from keygen"
badgeTypeR = maybe (Left "invalid badge type") Right . textDecode . T.pack
expireR = \case
"lifetime" -> Right Nothing
s -> maybe (Left "use 'lifetime' or YYYY-MM-DD") (Right . Just) $ parseTimeM True defaultTimeLocale "%Y-%m-%d" s
keygen :: IO ()
keygen =
bbsKeyGen >>= \case
Left e -> die $ "keygen failed: " <> e
Right (BBSPublicKey pk, BBSSecretKey sk) -> do
B.putStrLn $ "secret " <> strEncode sk
B.putStrLn $ "public " <> strEncode pk
genMasterKey :: IO ()
genMasterKey = do
drg <- C.newRandom
mk <- generateMasterKey drg
B.putStrLn $ strEncode mk
sign :: Int -> BBSSecretKey -> BadgeMasterKey -> BadgeType -> Maybe UTCTime -> IO ()
sign keyIdx secretKey masterKey badgeType badgeExpiry = do
let req = VerifiedBadgeRequest (BadgeRequest {masterKey, badgeInfo = BadgeInfo {badgeType, badgeExpiry, badgeExtra = ""}} :: BadgeRequest)
issueBadge keyIdx secretKey req >>= \case
Left e -> die $ "sign failed: " <> e
-- single-line JSON (master secret + signature + info), pasted into the app via `/badge add`
Right cred -> LB.putStrLn $ J.encode cred
src/Simplex/Chat/Controller.hs
+47 -1
View File
@@ -39,6 +39,7 @@ import Data.Char (ord)
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import Data.Set (Set)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.String
@@ -81,6 +82,8 @@ 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.Messaging.Crypto.BBS (BBSPublicKey)
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Crypto.Ratchet (PQEncryption)
@@ -137,6 +140,8 @@ coreVersionInfo simplexmqCommit =
data ChatConfig = ChatConfig
{ agentConfig :: AgentConfig,
chatVRange :: VersionRangeChat,
-- issuer public keys by index: credentials and proofs name the key that signed them, for rotation
badgePublicKeys :: Map Int BBSPublicKey,
confirmMigrations :: MigrationConfirmation,
presetServers :: PresetServers,
shortLinkPresetServers :: NonEmpty SMPServer,
@@ -158,6 +163,7 @@ data ChatConfig = ChatConfig
ciExpirationInterval :: Int64, -- microseconds
deliveryWorkerDelay :: Int64, -- microseconds
deliveryBucketSize :: Int,
webPreviewConfig :: Maybe WebPreviewConfig,
channelSubscriberRole :: GroupMemberRole, -- TODO [relays] starting role should be communicated in protocol from owner to relays
relayChecksInterval :: NominalDiffTime,
relayInactiveTTL :: NominalDiffTime,
@@ -169,10 +175,47 @@ data ChatConfig = ChatConfig
chatHooks :: ChatHooks
}
data WebPreviewConfig = WebPreviewConfig
{ webDomain :: Text,
webJsonDir :: FilePath,
webCorsFile :: Maybe FilePath,
webUpdateInterval :: Int, -- seconds
webPreviewItemCount :: Int
}
data PublishableGroup = PublishableGroup
{ pgFileName :: FilePath,
pgCorsEntry :: Maybe (Text, CorsOrigin)
}
data CorsOrigin = CorsAny | CorsOrigins [Text]
deriving (Show)
data WebPreviewState = WebPreviewState
{ publishableGroupIds :: TVar (Map Int64 PublishableGroup),
priorityRender :: TQueue Int64,
filesToRemove :: TQueue FilePath,
corsNeeded :: TVar Bool,
routinePending :: TVar (Set Int64),
wakeSignal :: TMVar (),
webPreviewWorkerAsync :: TVar (Maybe (Async ()))
}
newWebPreviewState :: IO WebPreviewState
newWebPreviewState = do
publishableGroupIds <- newTVarIO mempty
priorityRender <- newTQueueIO
filesToRemove <- newTQueueIO
corsNeeded <- newTVarIO False
routinePending <- newTVarIO mempty
wakeSignal <- newEmptyTMVarIO
webPreviewWorkerAsync <- newTVarIO Nothing
pure WebPreviewState {publishableGroupIds, priorityRender, filesToRemove, corsNeeded, routinePending, wakeSignal, webPreviewWorkerAsync}
-- | 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} = StoreCxt chatVRange
mkStoreCxt ChatConfig {chatVRange, badgePublicKeys} = StoreCxt chatVRange badgePublicKeys
{-# INLINE mkStoreCxt #-}
data RandomAgentServers = RandomAgentServers
@@ -262,6 +305,7 @@ data ChatController = ChatController
deliveryJobWorkers :: TMap DeliveryWorkerKey Worker,
relayRequestWorkers :: TMap Int Worker, -- single global worker with key 1 is used to fit into existing worker management framework
relayGroupLinkChecksAsync :: TVar (Maybe (Async ())),
webPreviewState :: Maybe WebPreviewState,
chatRelayTests :: TMap ConnId RelayTest,
expireCIThreads :: TMap UserId (Maybe (Async ())),
expireCIFlags :: TMap UserId Bool,
@@ -556,6 +600,7 @@ data ChatCommand
| ShowGroupProfile GroupName
| UpdateGroupDescription GroupName (Maybe Text)
| ShowGroupDescription GroupName
| SetPublicGroupAccess GroupName PublicGroupAccess
| CreateGroupLink GroupName GroupMemberRole
| GroupLinkMemberRole GroupName GroupMemberRole
| DeleteGroupLink GroupName
@@ -581,6 +626,7 @@ data ChatCommand
| SetBotCommands [ChatBotCommand]
| UpdateProfile ContactName (Maybe Text) -- UserId (not used in UI)
| UpdateProfileImage (Maybe ImageData) -- UserId (not used in UI)
| AddBadge BadgeCredential -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`)
| ShowProfileImage
| SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI)
| SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)
src/Simplex/Chat/Core.hs
+1 -1
View File
@@ -140,7 +140,7 @@ createActiveUser cc CoreChatOpts {chatRelay} = \case
displayName <- T.pack <$> withPrompt "display name" getLine
createUser loop False $ mkProfile displayName
where
mkProfile displayName = Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Nothing, preferences = Nothing}
mkProfile displayName = Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, simplexName = Nothing}
createUser onError clientService p =
execChatCommand' (CreateActiveUser NewUser {profile = Just p, pastTimestamp = False, userChatRelay = BoolDef chatRelay, clientService = BoolDef clientService}) 0 `runReaderT` cc >>= \case
Right (CRActiveUser user) -> pure user
src/Simplex/Chat/Help.hs
+1 -6
View File
@@ -187,8 +187,6 @@ contactsHelpInfo =
indent <> highlight "/verify @<name> " <> " - clear security code verification",
indent <> highlight "/info @<name> " <> " - info about contact connection",
indent <> highlight "/switch @<name> " <> " - switch receiving messages to another SMP relay",
indent <> highlight "/pq @<name> on/off " <> " - [BETA] toggle quantum resistant / standard e2e encryption for a contact",
indent <> " " <> " (both have to enable for quantum resistance)",
"",
green "Contact chat preferences:",
indent <> highlight "/set voice @<name> yes/no/always " <> " - allow/prohibit voice messages with the contact",
@@ -324,16 +322,13 @@ settingsInfo =
map
styleMarkdown
[ green "Chat settings:",
indent <> highlight "/pq on/off " <> " - [BETA] toggle quantum resistant / standard e2e encryption for the new contacts",
indent <> highlight "/network " <> " - show / set network access options",
indent <> highlight "/smp " <> " - show / set configured SMP servers",
indent <> highlight "/xftp " <> " - show / set configured XFTP servers",
indent <> highlight "/info <contact> " <> " - information about contact connection",
indent <> highlight "/info #<group> <member> " <> " - information about member connection",
indent <> highlight "/(un)mute <contact> " <> " - (un)mute contact, the last messages can be printed with /tail command",
indent <> highlight "/(un)mute #<group> " <> " - (un)mute group",
indent <> highlight "/get stats " <> " - get usage statistics",
indent <> highlight "/reset stats " <> " - reset usage statistics"
indent <> highlight "/(un)mute #<group> " <> " - (un)mute group"
]
databaseHelpInfo :: [StyledString]
src/Simplex/Chat/Library/Commands.hs
+205 -109
View File
@@ -55,6 +55,7 @@ import Data.Type.Equality
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as V4
import Simplex.Chat.Library.Subscriber
import Simplex.Chat.Badges (BadgeCredential (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..))
@@ -89,6 +90,7 @@ import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Util (liftIOEither, zipWith3')
import qualified Simplex.Chat.Util as U
import Simplex.Chat.Web (webPreviewWorker)
import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSize, maxFileSizeHard)
import Simplex.Messaging.Agent
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
@@ -200,6 +202,7 @@ startChatController mainApp enableSndFiles = do
startCleanupManager
void $ forkIO $ mapM_ startExpireCIs users
startRelayChecks users
startWebPreview users
else when enableSndFiles $ startXFTP xftpStartSndWorkers
pure a1
startXFTP startWorkers = do
@@ -231,6 +234,20 @@ startChatController mainApp enableSndFiles = do
a <- Just <$> async (void $ runExceptT $ runRelayGroupLinkChecks relayUser)
atomically $ writeTVar relayAsync a
_ -> pure ()
startWebPreview users = do
let relayUsers = filter (\User {userChatRelay} -> isTrue userChatRelay) users
ChatConfig {webPreviewConfig = cfg_} <- asks config
case (relayUsers, cfg_) of
(_ : _, Just cfg) -> do
wps_ <- asks webPreviewState
forM_ wps_ $ \WebPreviewState {webPreviewWorkerAsync} ->
readTVarIO webPreviewWorkerAsync >>= \case
Nothing -> do
cc <- ask
a <- Just <$> async (liftIO $ webPreviewWorker cfg cc relayUsers)
atomically $ writeTVar webPreviewWorkerAsync a
_ -> pure ()
_ -> pure ()
startExpireCIs user = whenM shouldExpireChats $ do
startExpireCIThread user
setExpireCIFlag user True
@@ -364,16 +381,16 @@ processChatCommand cxt nm = \case
user <- withFastStore $ \db -> do
user <- createUserRecordAt db (AgentUserId auId) (isTrue userChatRelay) service p True ts
mapM_ (setUserServers db user ts) uss
createPresetContactCards db user `catchAllErrors` \_ -> pure ()
createPresetContactCards db cxt user `catchAllErrors` \_ -> pure ()
createNoteFolder db user
pure user
atomically . writeTVar u $ Just user
pure $ CRActiveUser user
where
createPresetContactCards :: DB.Connection -> User -> ExceptT StoreError IO ()
createPresetContactCards db user = do
createContact db user simplexStatusContactProfile
createContact db user simplexTeamContactProfile
createPresetContactCards :: DB.Connection -> StoreCxt -> User -> ExceptT StoreError IO ()
createPresetContactCards db cxt user = do
createContact db cxt user simplexStatusContactProfile
createContact db cxt user simplexTeamContactProfile
chooseServers :: Maybe User -> CM ([UpdatedUserOperatorServers], (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP)))
chooseServers user_ = do
as <- asks randomAgentServers
@@ -652,12 +669,14 @@ processChatCommand cxt nm = \case
_ <- createChatTag db user emoji text
CRChatTags user <$> getUserChatTags db user
APISetChatTags (ChatRef cType chatId scope) tagIds -> withUser $ \user -> case cType of
CTDirect -> withFastStore' $ \db -> do
updateDirectChatTags db chatId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> getUserChatTags db user <*> getDirectChatTags db chatId
CTGroup | isNothing scope -> withFastStore' $ \db -> do
updateGroupChatTags db chatId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> getUserChatTags db user <*> getGroupChatTags db chatId
CTDirect -> withFastStore $ \db -> do
Contact {contactId} <- getContact db cxt user chatId
liftIO $ updateDirectChatTags db contactId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> liftIO (getUserChatTags db user) <*> liftIO (getDirectChatTags db contactId)
CTGroup | isNothing scope -> withFastStore $ \db -> do
GroupInfo {groupId} <- getGroupInfo db cxt user chatId
liftIO $ updateGroupChatTags db groupId (maybe [] L.toList tagIds)
CRTagsUpdated user <$> liftIO (getUserChatTags db user) <*> liftIO (getGroupChatTags db groupId)
_ -> throwCmdError "not supported"
APIDeleteChatTag tagId -> withUser $ \user -> do
withFastStore' $ \db -> deleteChatTag db user tagId
@@ -1270,6 +1289,8 @@ processChatCommand cxt nm = \case
filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
withGroupLock "deleteChat group" chatId $ do
deleteCIFiles user filesInfo
-- the roster blob file has no chat item, so it is missed by getGroupFileInfo above
cleanupGroupRosterFile user gInfo
(members, recipients) <- getRecipients gInfo
let doSendDel = memberActive membership && isOwner
msgSigned <-
@@ -1692,8 +1713,11 @@ processChatCommand cxt nm = \case
CRServerOperatorConditions <$> getServerOperators db
APISetChatTTL userId (ChatRef cType chatId scope) newTTL_ ->
withUserId userId $ \user -> checkStoreNotChanged $ withChatLock "setChatTTL" $ do
(oldTTL_, globalTTL, ttlCount) <- withStore' $ \db ->
(,,) <$> getSetChatTTL db <*> getChatItemTTL db user <*> getChatTTLCount db user
(oldTTL_, globalTTL, ttlCount) <- withStore $ \db -> do
oldTTL <- getSetChatTTL db user
globalTTL <- liftIO $ getChatItemTTL db user
ttlCount <- liftIO $ getChatTTLCount db user
pure (oldTTL, globalTTL, ttlCount)
let newTTL = fromMaybe globalTTL newTTL_
oldTTL = fromMaybe globalTTL oldTTL_
when (newTTL > 0 && (newTTL < oldTTL || oldTTL == 0)) $ do
@@ -1702,9 +1726,13 @@ processChatCommand cxt nm = \case
lift $ setChatItemsExpiration user globalTTL ttlCount
ok user
where
getSetChatTTL db = case cType of
CTDirect -> getDirectChatTTL db chatId <* setDirectChatTTL db chatId newTTL_
CTGroup | isNothing scope -> getGroupChatTTL db chatId <* setGroupChatTTL db chatId newTTL_
getSetChatTTL db currentUser = case cType of
CTDirect -> do
Contact {contactId} <- getContact db cxt currentUser chatId
liftIO $ getDirectChatTTL db contactId <* setDirectChatTTL db contactId newTTL_
CTGroup | isNothing scope -> do
GroupInfo {groupId} <- getGroupInfo db cxt currentUser chatId
liftIO $ getGroupChatTTL db groupId <* setGroupChatTTL db groupId newTTL_
_ -> pure Nothing
expireChat user globalTTL = do
currentTs <- liftIO getCurrentTime
@@ -1955,7 +1983,8 @@ processChatCommand cxt nm = \case
-- [incognito] generate profile for connection
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
subMode <- chatReadVar subscriptionMode
let userData = contactShortLinkData (userProfileDirect user incognitoProfile Nothing True) Nothing
linkProfile <- presentUserBadge user incognitoProfile $ userProfileDirect user incognitoProfile Nothing True
let userData = contactShortLinkData linkProfile Nothing
userLinkData = UserInvLinkData userData
(connId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation (Just userLinkData) Nothing IKPQOn subMode
ccLink' <- shortenCreatedLink ccLink
@@ -1976,7 +2005,7 @@ processChatCommand cxt nm = \case
updatePCCIncognito db user conn (Just pId) sLnk
pure $ CRConnectionIncognitoUpdated user conn' (Just incognitoProfile)
(ConnNew, Just pId, False) -> do
sLnk <- updatePCCShortLinkData conn $ userProfileDirect user Nothing Nothing True
sLnk <- updatePCCShortLinkData conn =<< presentUserBadge user Nothing (userProfileDirect user Nothing Nothing True)
conn' <- withFastStore' $ \db -> do
deletePCCIncognitoProfile db user pId
updatePCCIncognito db user conn Nothing sLnk
@@ -1995,9 +2024,10 @@ processChatCommand cxt nm = \case
recreateConn user conn@PendingContactConnection {customUserProfileId, connLinkInv} newUser = do
subMode <- chatReadVar subscriptionMode
let short = isJust $ connShortLink' =<< connLinkInv
userLinkData_
| short = Just $ UserInvLinkData $ contactShortLinkData (userProfileDirect newUser Nothing Nothing True) Nothing
| otherwise = Nothing
userLinkData_ <-
if short
then Just . UserInvLinkData . (`contactShortLinkData` Nothing) <$> presentUserBadge newUser Nothing (userProfileDirect newUser Nothing Nothing True)
else pure Nothing
(agConnId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId newUser) True False SCMInvitation userLinkData_ Nothing IKPQOn subMode
ccLink' <- shortenCreatedLink ccLink
conn' <- withFastStore' $ \db -> do
@@ -2022,9 +2052,9 @@ processChatCommand cxt nm = \case
gVar <- asks random
(gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar cxt user groupProfile True ccLink welcomeSharedMsgId False GRMember Nothing Nothing
hostMember <- maybe (throwCmdError "no host member") pure hostMember_
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = CDGroupRcv gInfo Nothing hostMember
createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing
createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing Nothing
cInfo = GroupChat gInfo Nothing
void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent) message
@@ -2034,9 +2064,9 @@ processChatCommand cxt nm = \case
pure $ CRNewPreparedChat user $ AChat SCTGroup chat
ACCL _ (CCLink cReq _) -> do
ct <- withStore $ \db -> createPreparedContact db cxt user profile accLink welcomeSharedMsgId Nothing
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = CDDirectRcv ct
createItem sharedMsgId content = createChatItem user cd False content sharedMsgId Nothing
createItem sharedMsgId content = createChatItem user cd False content sharedMsgId Nothing Nothing
cInfo = DirectChat ct
void $ createItem Nothing $ CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ connRequestPQEncryption cReq
void $ createFeatureEnabledItems_ user ct
@@ -2053,11 +2083,11 @@ processChatCommand cxt nm = \case
subRole <- if useRelays then asks $ channelSubscriberRole . config else pure GRMember
gVar <- asks random
(gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar cxt user gp False ccLink welcomeSharedMsgId useRelays subRole publicMemberCount_ Nothing
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let cd = maybe (CDChannelRcv gInfo Nothing) (CDGroupRcv gInfo Nothing) hostMember_
cInfo = GroupChat gInfo Nothing
void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo
aci <- forM description $ \descr -> createChatItem user cd True (CIRcvMsgContent $ MCText descr) welcomeSharedMsgId Nothing
aci <- forM description $ \descr -> createChatItem user cd True (CIRcvMsgContent $ MCText descr) welcomeSharedMsgId Nothing Nothing
let chat = case aci of
Just (AChatItem SCTGroup dir _ ci) -> Chat cInfo [CChatItem dir ci] emptyChatStats {unreadCount = 1, minUnreadItemId = chatItemId' ci}
_ -> Chat cInfo [] emptyChatStats
@@ -2125,7 +2155,7 @@ processChatCommand cxt nm = \case
-- create changed feature items (connecting incognito sends default preferences, instead of user preferences)
lift . when incognito $ createContactChangedFeatureItems user ct ct'
forM_ msg_ $ \(sharedMsgId, mc) -> do
ci <- createChatItem user (CDDirectSnd ct') False (CISndMsgContent mc) (Just sharedMsgId) Nothing
ci <- createChatItem user (CDDirectSnd ct') False (CISndMsgContent mc) (Just sharedMsgId) Nothing Nothing
toView $ CEvtNewChatItems user [ci]
pure $ CRStartedConnectionToContact user ct' customUserProfile
CVRConnectedContact ct' -> pure $ CRContactAlreadyExists user ct'
@@ -2218,7 +2248,7 @@ processChatCommand cxt nm = \case
liftIO $ setPreparedGroupStartedConnection db groupId
getGroupInfo db cxt user groupId
forM_ msg_ $ \(sharedMsgId, mc) -> do
ci <- createChatItem user (CDGroupSnd gInfo' Nothing) False (CISndMsgContent mc) (Just sharedMsgId) Nothing
ci <- createChatItem user (CDGroupSnd gInfo' Nothing) False (CISndMsgContent mc) (Just sharedMsgId) Nothing Nothing
toView $ CEvtNewChatItems user [ci]
pure $ CRStartedConnectionToGroup user gInfo' customUserProfile []
CVRConnectedContact _ct -> throwChatError $ CEException "contact already exists when connecting to group"
@@ -2274,10 +2304,11 @@ processChatCommand cxt nm = \case
Right _ -> throwError $ ChatErrorStore SEDuplicateContactLink
subMode <- chatReadVar subscriptionMode
-- TODO [relays] relay: add identity, key to link data?
let userData
| isTrue userChatRelay = relayShortLinkData (userProfileDirect user Nothing Nothing True)
| otherwise = contactShortLinkData (userProfileDirect user Nothing Nothing True) Nothing
userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
userData <-
if isTrue userChatRelay
then pure $ relayShortLinkData (userProfileDirect user Nothing Nothing True)
else (`contactShortLinkData` Nothing) <$> presentUserBadge user Nothing (userProfileDirect user Nothing Nothing True)
let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
(connId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userLinkData) Nothing IKPQOn subMode
ccLink' <- shortenCreatedLink ccLink
let ccLink'' = if isTrue userChatRelay then setShortLinkType CCTRelay ccLink' else ccLink'
@@ -2730,34 +2761,45 @@ processChatCommand cxt nm = \case
-- TODO [relays] possible optimization is to read only required members + relays
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db cxt user groupId
when (selfSelected gInfo) $ throwCmdError "can't change role for self"
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending, anyPrivilegedTarget, finalPrivilegedCount) = selectMembers members
when (length invitedMems + length currentMems + length unchangedMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
when (length memberIds > 1 && (anyAdmin || newRole >= GRAdmin)) $
throwCmdError "can't change role of multiple members when admins selected, or new role is admin"
when anyPending $ throwCmdError "can't change role of members pending approval"
assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole])
-- in relay groups the roster has a single signer, so only the owner may change moderator/admin roles
when (useRelays' gInfo && (isRosterRole newRole || anyPrivilegedTarget) && memberRole' (membership gInfo) /= GROwner) $
throwCmdError "only the group owner can change moderator and admin roles"
when (useRelays' gInfo && isRosterRole newRole && finalPrivilegedCount > maxGroupRosterSize) $
throwCmdError $ "the number of members, moderators and admins would exceed the limit of " <> show maxGroupRosterSize
(errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems
(errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g currentMems
let doBumpRoster = useRelays' gInfo && memberRole' (membership gInfo) == GROwner && (isRosterRole newRole || anyPrivilegedTarget)
rosterVer <- if doBumpRoster then Just <$> reserveRosterVersion gInfo else pure Nothing
(errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g rosterVer currentMems
forM_ rosterVer $ \v -> broadcastRoster user gInfo v `catchAllErrors` eToView
unless (null acis) $ toView $ CEvtNewChatItems user acis
let errs = errs1 <> errs2
unless (null errs) $ toView $ CEvtChatErrors errs
pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole, msgSigned} -- same order is not guaranteed
where
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
selectMembers = foldr' addMember ([], [], [], GRObserver, False, False)
-- anyPrivilegedTarget: a target currently moderator/admin; finalPrivilegedCount:
-- moderators + admins after the change (targets take newRole, others keep their role).
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool, Bool, Int)
selectMembers = foldr' addMember ([], [], [], GRObserver, False, False, False, 0)
where
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin, anyPending)
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin, anyPending, anyPrivTarget, privCount)
| groupMemberId `elem` memberIds =
let maxRole' = max maxRole memberRole
anyAdmin' = anyAdmin || memberRole >= GRAdmin
anyPending' = anyPending || memberPending m
in
if
| memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin', anyPending')
| memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin', anyPending')
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending')
| otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending)
anyPrivTarget' = anyPrivTarget || isRosterRole memberRole
privCount' = if isRosterRole newRole then privCount + 1 else privCount
in if
| memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', privCount')
| memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', privCount')
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending', anyPrivTarget', privCount')
| otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending, anyPrivTarget, if isRosterRole memberRole then privCount + 1 else privCount)
changeRoleInvitedMems :: User -> GroupInfo -> [GroupMember] -> CM ([ChatError], [GroupMember])
changeRoleInvitedMems user gInfo memsToChange = do
-- not batched, as we need to send different invitations to different connections anyway
@@ -2772,19 +2814,20 @@ processChatCommand cxt nm = \case
withFastStore' $ \db -> updateGroupMemberRole db user m newRole
pure (m :: GroupMember) {memberRole = newRole}
_ -> throwChatError $ CEGroupCantResendInvitation gInfo cName
changeRoleCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
changeRoleCurrentMems user (Group gInfo members) memsToChange = case L.nonEmpty memsToChange of
changeRoleCurrentMems :: User -> Group -> Maybe VersionRoster -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
changeRoleCurrentMems user (Group gInfo members) rosterVer memsToChange = case L.nonEmpty memsToChange of
Nothing -> pure ([], [], [], False)
Just memsToChange' -> do
let events = L.map (\GroupMember {memberId} -> XGrpMemRole memberId newRole) memsToChange'
let mKey m = if isJust rosterVer then MemberKey <$> memberPubKey m else Nothing
events = L.map (\m@GroupMember {memberId} -> XGrpMemRole memberId newRole (mKey m) rosterVer) memsToChange'
recipients = filter memberCurrent members
(msgs_, _gsr) <- sendGroupMessages user gInfo Nothing False recipients events
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch"
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
pure (errs, changed, acis, signed)
where
sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c
@@ -2848,20 +2891,25 @@ processChatCommand cxt nm = \case
withGroupLock "removeMembers" groupId $ do
-- TODO [relays] possible optimization is to read only required members + relays
Group gInfo members <- withFastStore $ \db -> getGroup db cxt user groupId
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin) = selectMembers gmIds members
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin, anyPrivilegedRemoved) = selectMembers gmIds members
gmIds = S.fromList $ L.toList groupMemberIds
memCount = length groupMemberIds
when (count /= memCount) $ throwChatError CEGroupMemberNotFound
when (memCount > 1 && anyAdmin) $ throwCmdError "can't remove multiple members when admins selected"
assertUserGroupRole gInfo $ max GRAdmin maxRole
when (useRelays' gInfo && anyPrivilegedRemoved && memberRole' (membership gInfo) /= GROwner) $
throwCmdError "only the group owner can remove members, moderators and admins"
(errs1, deleted1) <- deleteInvitedMems user invitedMems
let recipients = filter memberCurrent members
(errs2, deleted2, acis2, signed2) <- deleteMemsSend user gInfo Nothing recipients currentMems
let doBumpRoster = useRelays' gInfo && memberRole' (membership gInfo) == GROwner && anyPrivilegedRemoved
rosterVer <- if doBumpRoster then Just <$> reserveRosterVersion gInfo else pure Nothing
(errs2, deleted2, acis2, signed2) <- deleteMemsSend user gInfo Nothing rosterVer recipients currentMems
(errs3, deleted3, acis3, signed3) <-
foldM (\acc m -> deletePendingMember acc user gInfo [m] m) ([], [], [], False) pendingApprvMems
let moderators = filter (\GroupMember {memberRole} -> memberRole >= GRModerator) members
(errs4, deleted4, acis4, signed4) <-
foldM (\acc m -> deletePendingMember acc user gInfo (m : moderators) m) ([], [], [], False) pendingRvwMems
forM_ rosterVer $ \v -> broadcastRoster user gInfo v `catchAllErrors` eToView
let acis = acis2 <> acis3 <> acis4
errs = errs1 <> errs2 <> errs3 <> errs4
deleted = deleted1 <> deleted2 <> deleted3 <> deleted4
@@ -2876,19 +2924,20 @@ processChatCommand cxt nm = \case
unless (null errs) $ toView $ CEvtChatErrors errs
pure $ CRUserDeletedMembers user gInfo' deleted withMessages msgSigned -- same order is not guaranteed
where
selectMembers :: S.Set GroupMemberId -> [GroupMember] -> (Int, [GroupMember], [GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool)
selectMembers gmIds = foldl' addMember (0, [], [], [], [], GRObserver, False)
selectMembers :: S.Set GroupMemberId -> [GroupMember] -> (Int, [GroupMember], [GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
selectMembers gmIds = foldl' addMember (0, [], [], [], [], GRObserver, False, False)
where
addMember acc@(n, invited, pendingApprv, pendingRvw, current, maxRole, anyAdmin) m@GroupMember {groupMemberId, memberStatus, memberRole}
addMember acc@(n, invited, pendingApprv, pendingRvw, current, maxRole, anyAdmin, anyPrivRemoved) m@GroupMember {groupMemberId, memberStatus, memberRole}
| groupMemberId `S.member` gmIds =
let maxRole' = max maxRole memberRole
anyAdmin' = anyAdmin || memberRole >= GRAdmin
anyPrivRemoved' = anyPrivRemoved || isRosterRole memberRole
n' = n + 1
in case memberStatus of
GSMemInvited -> (n', m : invited, pendingApprv, pendingRvw, current, maxRole', anyAdmin')
GSMemPendingApproval -> (n', invited, m : pendingApprv, pendingRvw, current, maxRole', anyAdmin')
GSMemPendingReview -> (n', invited, pendingApprv, m : pendingRvw, current, maxRole', anyAdmin')
_ -> (n', invited, pendingApprv, pendingRvw, m : current, maxRole', anyAdmin')
GSMemInvited -> (n', m : invited, pendingApprv, pendingRvw, current, maxRole', anyAdmin', anyPrivRemoved')
GSMemPendingApproval -> (n', invited, m : pendingApprv, pendingRvw, current, maxRole', anyAdmin', anyPrivRemoved')
GSMemPendingReview -> (n', invited, pendingApprv, m : pendingRvw, current, maxRole', anyAdmin', anyPrivRemoved')
_ -> (n', invited, pendingApprv, pendingRvw, m : current, maxRole', anyAdmin', anyPrivRemoved')
| otherwise = acc
deleteInvitedMems :: User -> [GroupMember] -> CM ([ChatError], [GroupMember])
deleteInvitedMems user memsToDelete = do
@@ -2901,14 +2950,14 @@ processChatCommand cxt nm = \case
deletePendingMember :: ([ChatError], [GroupMember], [AChatItem], Bool) -> User -> GroupInfo -> [GroupMember] -> GroupMember -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
deletePendingMember (accErrs, accDeleted, accACIs, accSigned) user gInfo recipients m = do
(m', scopeInfo) <- mkMemberSupportChatInfo m
(errs, deleted, acis, signed) <- deleteMemsSend user gInfo (Just scopeInfo) recipients [m']
(errs, deleted, acis, signed) <- deleteMemsSend user gInfo (Just scopeInfo) Nothing recipients [m']
pure (errs <> accErrs, deleted <> accDeleted, acis <> accACIs, accSigned || signed)
deleteMemsSend :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
deleteMemsSend user gInfo chatScopeInfo recipients memsToDelete = case L.nonEmpty memsToDelete of
deleteMemsSend :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> Maybe VersionRoster -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool)
deleteMemsSend user gInfo chatScopeInfo rosterVer recipients memsToDelete = case L.nonEmpty memsToDelete of
Nothing -> pure ([], [], [], False)
Just memsToDelete' -> do
let chatScope = toChatScope <$> chatScopeInfo
events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages) memsToDelete'
events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages rosterVer) memsToDelete'
(msgs_, _gsr) <- sendGroupMessages user gInfo chatScope False recipients events
let signed = any (either (const False) (isJust . signedMsg_)) msgs_
itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_)
@@ -3050,6 +3099,12 @@ processChatCommand cxt nm = \case
updateGroupProfileByName gName $ \p -> p {description}
ShowGroupDescription gName -> withUser $ \user ->
CRGroupDescription user <$> withFastStore (\db -> getGroupInfoByName db cxt user gName)
SetPublicGroupAccess gName access -> withUser $ \user -> do
gInfo@GroupInfo {groupProfile = p@GroupProfile {publicGroup}} <- withStore $ \db ->
getGroupIdByName db user gName >>= getGroupInfo db cxt user
case publicGroup of
Just pg -> runUpdateGroupProfile user gInfo p {publicGroup = Just pg {publicGroupAccess = Just access}}
Nothing -> throwChatError $ CECommandError "not a public group"
APICreateGroupLink groupId mRole -> withUser $ \user -> withGroupLock "createGroupLink" groupId $ do
gInfo@GroupInfo {groupProfile} <- withFastStore $ \db -> getGroupInfo db cxt user groupId
assertUserGroupRole gInfo GRAdmin
@@ -3102,7 +3157,7 @@ processChatCommand cxt nm = \case
(connId, CCLink cReq _) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation Nothing Nothing IKPQOff subMode
-- [incognito] reuse membership incognito profile
ct <- withFastStore' $ \db -> createMemberContact db user connId cReq g m mConn subMode
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart)
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing Nothing (Just epochStart)
-- TODO not sure it is correct to set connections status here?
pure $ CRNewMemberContact user ct g m
_ -> throwChatError CEGroupMemberNotActive
@@ -3158,7 +3213,7 @@ processChatCommand cxt nm = \case
joinPreparedConn subMode conn
joinPreparedConn subMode conn = do
-- [incognito] send membership incognito profile
let p = userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True
p <- presentUserBadge user (incognitoMembershipProfile gInfo) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True
dm <- encodeConnInfo $ XInfo p
sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode
let newStatus = if sqSecured then ConnSndReady else ConnJoined
@@ -3308,6 +3363,7 @@ processChatCommand cxt nm = \case
fileStatus <- withFastStore $ \db -> getFileTransferProgress db user fileId
pure $ CRFileTransferStatus user fileStatus
ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile)
AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user
SetBotCommands commands -> withUser $ \user@User {profile} -> do
let LocalProfile {preferences} = profile
prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands}
@@ -3535,7 +3591,7 @@ processChatCommand cxt nm = \case
conn <- withFastStore' $ \db -> createDirectConnection' db userId connId ccLink contactId_ ConnPrepared incognitoProfile subMode chatV pqSup'
joinPreparedConn conn incognitoProfile chatV
joinPreparedConn conn incognitoProfile chatV = do
let profileToSend = userProfileDirect user incognitoProfile Nothing True
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user incognitoProfile Nothing True
dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend
sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup' subMode
let newStatus = if sqSecured then ConnSndReady else ConnJoined
@@ -3580,13 +3636,18 @@ processChatCommand cxt nm = \case
where
cReqHash1 = contactCReqHash $ CRContactUri crData {crScheme = SSSimplex}
cReqHash2 = contactCReqHash $ CRContactUri crData {crScheme = simplexChat}
-- relay-group joins (only via connectToRelay) carry the target relay member in preparedEntity_;
-- its memberId binds the join signature so a sibling relay can't replay it
relayMemberId_ = case preparedEntity_ of
Just (PCEGroup gInfo m) | useRelays' gInfo -> Just (memberId' m)
_ -> Nothing
joinPreparedConn' xContactId_ conn@Connection {customUserProfileId} gInfo_ = do
when (incognito /= isJust customUserProfileId) $ throwCmdError "incognito mode is different from prepared connection"
-- TODO [relays] member: refactor joinContact and up avoiding parallel ifs, xContactId is not used
xContactId <- mkXContactId xContactId_
localIncognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ PQSupportOn
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ PQSupportOn
pure $ CVRSentInvitation conn' incognitoProfile
connect' groupLinkId xContactId_ gInfo_ = do
let inGroup = isJust groupLinkId
@@ -3601,7 +3662,7 @@ processChatCommand cxt nm = \case
subMode <- chatReadVar subscriptionMode
let sLnk' = serverShortLink <$> sLnk
conn <- withFastStore' $ \db -> createConnReqConnection db userId connId preparedEntity_ cReq cReqHash1 sLnk' xContactId incognitoProfile_ groupLinkId subMode chatV pqSup
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ pqSup
conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup
pure $ CVRSentInvitation conn' incognitoProfile
connectContactViaAddress :: User -> IncognitoEnabled -> Contact -> CreatedLinkContact -> CM ChatResponse
connectContactViaAddress user@User {userId} incognito ct@Contact {contactId, activeConn} (CCLink cReq shortLink) =
@@ -3616,7 +3677,7 @@ processChatCommand cxt nm = \case
subMode <- chatReadVar subscriptionMode
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
conn <- withFastStore' $ \db -> createConnReqConnection db userId connId (Just $ PCEContact ct) cReq cReqHash shortLink newXContactId (NewIncognito <$> incognitoProfile) Nothing subMode chatV pqSup
void $ joinContact user conn cReq incognitoProfile newXContactId Nothing Nothing Nothing pqSup
void $ joinContact user conn cReq incognitoProfile newXContactId Nothing Nothing Nothing Nothing pqSup
ct' <- withStore $ \db -> getContact db cxt user contactId
pure $ CRSentInvitationToContact user ct' incognitoProfile
Just conn@Connection {connStatus, xContactId = xContactId_, customUserProfileId} -> case connStatus of
@@ -3625,7 +3686,7 @@ processChatCommand cxt nm = \case
xContactId <- mkXContactId xContactId_
localIncognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
void $ joinContact user conn cReq incognitoProfile xContactId Nothing Nothing Nothing PQSupportOn
void $ joinContact user conn cReq incognitoProfile xContactId Nothing Nothing Nothing Nothing PQSupportOn
ct' <- withStore $ \db -> getContact db cxt user contactId
pure $ CRSentInvitationToContact user ct' incognitoProfile
_ -> throwCmdError "contact already has connection"
@@ -3637,13 +3698,14 @@ processChatCommand cxt nm = \case
r <- tryAllErrors $ do
(fd@FixedLinkData {rootKey = relayKey, linkEntityId}, cData) <- getShortLinkConnReq nm user relayLink
relayLinkData_ <- liftIO $ decodeLinkUserData cData
case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) ->
withFastStore $ \db -> updateRelayMemberData db user relayMember (MemberId entityId) (MemberKey relayKey) p
relayMemberId <- case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) -> do
withFastStore $ \db -> updateRelayMemberData db cxt user relayMember (MemberId entityId) (MemberKey relayKey) p
pure $ MemberId entityId
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
let cReq = linkConnReq fd
relayLinkToConnect = CCLink cReq (Just relayLink)
void $ connectViaContact user (Just $ PCEGroup gInfo relayMember) (incognitoMembership gInfo) relayLinkToConnect Nothing Nothing
void $ connectViaContact user (Just $ PCEGroup gInfo (relayMember {memberId = relayMemberId})) (incognitoMembership gInfo) relayLinkToConnect Nothing Nothing
relayMember' <- withFastStore $ \db -> getGroupMember db cxt user (groupId' gInfo) (groupMemberId' relayMember)
pure (relayLink, relayMember', r)
syncSubscriberRelays :: User -> GroupInfo -> [ShortLinkContact] -> CM ()
@@ -3679,23 +3741,20 @@ processChatCommand cxt nm = \case
pure (connId, chatV)
mkXContactId :: Maybe XContactId -> CM XContactId
mkXContactId = maybe (XContactId <$> drgRandomBytes 16) pure
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfo) -> PQSupport -> CM Connection
joinContact user conn@Connection {connChatVersion = chatV} cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ pqSup = do
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfo) -> Maybe MemberId -> PQSupport -> CM Connection
joinContact user conn@Connection {connChatVersion = chatV} cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup = do
-- gInfo_ is Maybe (Maybe GroupInfo), where Just Nothing means "some unknown group", e.g. when joining via link without profile
let profileToSend = case gInfo_ of
Just gInfo_' ->
let allowSimplexLinks = maybe True (groupFeatureUserAllowed SGFSimplexLinks) gInfo_'
in userProfileInGroup' user allowSimplexLinks incognitoProfile
Nothing -> userProfileDirect user incognitoProfile Nothing True
chatEvent <- case gInfo_ of
Just (Just gInfo) | useRelays' gInfo -> do
let GroupInfo {membership = GroupMember {memberId}} = gInfo
memberPubKey <- case groupKeys gInfo of
Just GroupKeys {memberPrivKey} -> pure $ C.publicKey memberPrivKey
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
pure $ XMember profileToSend memberId (MemberKey memberPubKey)
_ -> pure $ XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_
dm <- encodeConnInfoPQ pqSup chatV chatEvent
profileToSend <-
presentUserBadge user incognitoProfile $ case gInfo_ of
Just gInfo_' ->
let allowSimplexLinks = maybe True groupUserAllowSimplexLinks gInfo_'
in userProfileInGroup' user allowSimplexLinks incognitoProfile
Nothing -> userProfileDirect user incognitoProfile Nothing True
dm <- case gInfo_ of
Just (Just gInfo) | useRelays' gInfo -> case relayMemberId_ of
Just relayMemberId -> encodeXMemberConnInfo gInfo relayMemberId profileToSend
Nothing -> throwChatError $ CEInternalError "relay group join without target relay memberId"
_ -> encodeConnInfoPQ pqSup chatV $ XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_
subMode <- chatReadVar subscriptionMode
void $ withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup subMode
withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared ConnJoined
@@ -3703,12 +3762,12 @@ processChatCommand cxt nm = \case
contactMember Contact {contactId} =
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
cId == Just contactId && s /= GSMemRejected && s /= GSMemRemoved && s /= GSMemLeft
checkSndFile :: CryptoFile -> CM Integer
checkSndFile (CryptoFile f cfArgs) = do
checkSndFile :: Maybe LocalBadge -> CryptoFile -> CM Integer
checkSndFile sndBadge (CryptoFile f cfArgs) = do
fsFilePath <- lift $ toFSFilePath f
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs
when (fromInteger fileSize > maxFileSize) $ throwChatError $ CEFileSize f
when (fromInteger fileSize > maxXFTPFileSize sndBadge) $ throwChatError $ CEFileSize f
pure fileSize
updateProfile :: User -> Profile -> CM ChatResponse
updateProfile user p' = updateProfile_ user p' True $ withFastStore $ \db -> updateUserProfile db user p'
@@ -3738,7 +3797,7 @@ processChatCommand cxt nm = \case
case changedCts_ of
Nothing -> pure $ UserProfileUpdateSummary 0 0 []
Just changedCts -> do
let idsEvts = L.map ctSndEvent changedCts
idsEvts <- mapM ctSndEvent changedCts
msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts
(errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_
unless (null errs) $ toView $ CEvtChatErrors errs
@@ -3762,8 +3821,11 @@ processChatCommand cxt nm = \case
mergedProfile = userProfileDirect user Nothing (Just ct) False
ct' = updateMergedPreferences user' ct
mergedProfile' = userProfileDirect user' Nothing (Just ct') False
ctSndEvent :: ChangedProfileContact -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, Nothing, XInfo mergedProfile')
-- non-incognito (filtered above), so the user's badge is presented; a profile update keeps the badge instead of clearing it
ctSndEvent :: ChangedProfileContact -> CM (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)
ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = do
p <- presentUserBadge user' Nothing mergedProfile'
pure (ConnectionId connId, Nothing, XInfo p)
ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq
ctMsgReq ChangedProfileContact {conn} =
fmap $ \SndMessage {msgId, msgBody} ->
@@ -3771,9 +3833,9 @@ processChatCommand cxt nm = \case
setMyAddressData :: User -> UserContactLink -> CM UserContactLink
setMyAddressData user@User {userChatRelay} ucl@UserContactLink {userContactLinkId, connLinkContact = CCLink connFullLink _sLnk_, addressSettings} = do
conn <- withFastStore $ \db -> getUserAddressConnection db cxt user
let shortLinkProfile = userProfileDirect user Nothing Nothing True
-- TODO [short links] do not save address to server if data did not change, spinners, error handling
userData
shortLinkProfile <- presentUserBadge user Nothing $ userProfileDirect user Nothing Nothing True
-- TODO [short links] do not save address to server if data did not change, spinners, error handling
let userData
| isTrue userChatRelay = relayShortLinkData shortLinkProfile
| otherwise = contactShortLinkData shortLinkProfile $ Just addressSettings
userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData}
@@ -3794,7 +3856,8 @@ processChatCommand cxt nm = \case
mergedProfile' = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') False
when (mergedProfile' /= mergedProfile) $
withContactLock "updateContactPrefs" (contactId' ct) $ do
void (sendDirectContactMessage user ct' $ XInfo mergedProfile') `catchAllErrors` eToView
p <- presentUserBadge user incognitoProfile mergedProfile'
void (sendDirectContactMessage user ct' $ XInfo p) `catchAllErrors` eToView
lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
pure $ CRContactPrefsUpdated user ct ct'
runUpdateGroupProfile :: User -> GroupInfo -> GroupProfile -> CM ChatResponse
@@ -3993,10 +4056,10 @@ processChatCommand cxt nm = \case
conn <- createRelayConnection db cxt user (groupMemberId' relayMember) connId ConnPrepared chatV subMode
pure (relayMember, conn, groupRelay)
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo
membershipProfile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership
allowSimplexLinks = groupUserAllowSimplexLinks gInfo
GroupMember {memberId = relayMemberId} = relayMember
relayInv = GroupRelayInvitation {
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership
let relayInv = GroupRelayInvitation {
fromMember = MemberIdRole userMemberId userRole,
fromMemberProfile = membershipProfile,
relayMemberId,
@@ -4084,7 +4147,7 @@ processChatCommand cxt nm = \case
Just r -> pure r
Nothing -> do
(FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user l'
contactSLinkData_ <- liftIO $ decodeLinkUserData cData
contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData)
let ov = verifyLinkOwner rootKey [] l sig_
invitationReqAndPlan cReq (Just l') contactSLinkData_ ov
where
@@ -4111,7 +4174,7 @@ processChatCommand cxt nm = \case
withFastStore' (\db -> getContactWithoutConnViaShortAddress db cxt user l') >>= \case
Just ct' | not (contactDeleted ct') -> pure (con cReq, CPContactAddress (CAPContactViaAddress ct'))
_ -> do
contactSLinkData_ <- liftIO $ decodeLinkUserData cData
contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData)
let ContactLinkData _ UserContactData {owners} = cData
ov = verifyLinkOwner rootKey owners l' sig_
plan <- contactRequestPlan user cReq contactSLinkData_ ov
@@ -4313,7 +4376,7 @@ processChatCommand cxt nm = \case
contactShortLinkData p settings =
let msg = autoReply =<< settings
business = maybe False businessAddress settings
contactData = ContactShortLinkData p msg business
contactData = ContactShortLinkData p msg business Nothing
in encodeShortLinkData contactData
relayShortLinkData :: Profile -> UserLinkData
relayShortLinkData Profile {displayName, fullName, shortDescr, image} =
@@ -4377,7 +4440,8 @@ processChatCommand cxt nm = \case
setupSndFileTransfers =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _, _) -> case file_ of
Just file -> do
fileSize <- checkSndFile file
let User {profile = LocalProfile {localBadge}} = user
fileSize <- checkSndFile (if contactConnIncognito ct then Nothing else localBadge) file
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 $ CGContact ct
pure (Just fInv, Just ciFile)
Nothing -> pure (Nothing, Nothing)
@@ -4458,7 +4522,8 @@ processChatCommand cxt nm = \case
setupSndFileTransfers n =
forM cmrs $ \(ComposedMessage {fileSource = file_}, _, _, _) -> case file_ of
Just file -> do
fileSize <- checkSndFile file
let User {profile = LocalProfile {localBadge}} = user
fileSize <- checkSndFile (if incognitoMembership gInfo then Nothing else localBadge) file
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup gInfo recipients
pure (Just fInv, Just ciFile)
Nothing -> pure (Nothing, Nothing)
@@ -4830,6 +4895,28 @@ createContactsSndFeatureItems user cts =
CUPContact {preference} -> preference
CUPUser {preference} -> preference
-- attach an issued badge credential to the user's own profile and present it to all current contacts.
-- the credential is stored once; every profile send generates a fresh single-use proof (see presentUserBadge).
addUserBadge :: User -> BadgeCredential -> CM ()
addUserBadge user cred@(BadgeCredential keyIdx _ _ info) = do
keys <- asks $ badgePublicKeys . config
key <- maybe (throwCmdError "unknown badge key index") pure $ M.lookup keyIdx keys
verified <- liftIO $ verifyCredential key cred
unless verified $ throwCmdError "badge credential does not verify against configured key"
now <- liftIO getCurrentTime
user' <- withFastStore' $ \db -> setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info)))
asks currentUser >>= atomically . (`writeTVar` Just user')
cxt <- asks $ mkStoreCxt . config
contacts <- withFastStore' $ \db -> getUserContacts db cxt user'
withChatLock "addUserBadge" $ forM_ contacts $ \ct ->
case contactSendConn_ ct of
Right conn
| not (connIncognito conn) -> do
let ct' = updateMergedPreferences user' ct
p <- presentUserBadge user' Nothing $ userProfileDirect user' Nothing (Just ct') False
void (sendDirectContactMessage user' ct' (XInfo p)) `catchAllErrors` eToView
_ -> pure ()
assertDirectAllowed :: User -> MsgDirection -> Contact -> CMEventTag e -> CM ()
assertDirectAllowed user dir ct event =
unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $
@@ -5026,10 +5113,11 @@ runRelayGroupLinkChecks user = do
then do
-- TODO [relays] emit event to UI when relay own status promoted to RSActive
-- CEvtGroupRelayUpdated requires GroupRelay (owner-side), not available on relay side
void $ withStore' $ \db -> updateRelayOwnStatusFromTo db gInfo RSAccepted RSActive
void $ withStore' $ \db -> updateRelayOwnStatus_ db gInfo RSActive
else void $ withStore' $ \db -> updateRelayOwnStatusFromTo db gInfo RSActive RSInactive
_ -> pure ()
_ -> pure ()
sendRelayCapIfNeeded user gInfo
checkRelayInactiveGroups = do
cxt <- chatStoreCxt
ttl <- asks (relayInactiveTTL . config)
@@ -5353,6 +5441,7 @@ chatCommandP =
"/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP),
("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupNames <$> displayNameP <* A.space <*> groupProfile),
("/group_profile " <|> "/gp ") *> char_ '#' *> (ShowGroupProfile <$> displayNameP),
"/public group access " *> char_ '#' *> (SetPublicGroupAccess <$> displayNameP <*> publicGroupAccessP),
"/group_descr " *> char_ '#' *> (UpdateGroupDescription <$> displayNameP <*> optional (A.space *> msgTextP)),
"/set welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayNameP <* A.space <*> (Just <$> msgTextP)),
"/delete welcome " *> char_ '#' *> (UpdateGroupDescription <$> displayNameP <*> pure Nothing),
@@ -5441,6 +5530,7 @@ chatCommandP =
"/show profile image" $> ShowProfileImage,
("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> profileNameDescr),
("/profile" <|> "/p") $> ShowProfile,
"/badge add " *> (AddBadge <$> jsonP),
"/set bot commands " *> (SetBotCommands <$> botCommandsP),
"/delete bot commands" $> SetBotCommands [],
"/set voice #" *> (SetGroupFeatureRole (AGFR SGFVoice) <$> displayNameP <*> _strP <*> optional memberRole),
@@ -5559,6 +5649,12 @@ chatCommandP =
clearOverrides <- (" clear_overrides=" *> onOffP) <|> pure False
pure UserMsgReceiptSettings {enable, clearOverrides}
onOffP = ("on" $> True) <|> ("off" $> False)
publicGroupAccessP = do
groupWebPage <- optional (" web=" *> (safeDecodeUtf8 <$> A.takeTill A.isSpace))
groupDomain <- optional (" domain=" *> (safeDecodeUtf8 <$> A.takeTill A.isSpace))
domainWebPage <- (" domain_page=" *> onOffP) <|> pure False
allowEmbedding <- (" embed=" *> onOffP) <|> pure False
pure PublicGroupAccess {groupWebPage, groupDomain, domainWebPage, allowEmbedding}
profileNameDescr = (,) <$> displayNameP <*> shortDescrP
-- 'Help with bot':'link <ID>','Menu of commands':[...]
botCommandsP :: Parser [ChatBotCommand]
@@ -5579,7 +5675,7 @@ chatCommandP =
newUserP relay = do
(cName, shortDescr) <- profileNameDescr
service <- (" service=" *> onOffP) <|> pure False
let profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Nothing, preferences = Nothing}
let profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, simplexName = Nothing}
pure NewUser {profile, pastTimestamp = False, userChatRelay = BoolDef relay, clientService = BoolDef service}
newBotUserP = do
files_ <- optional $ "files=" *> onOffP <* A.space
@@ -5588,7 +5684,7 @@ chatCommandP =
let preferences = case files_ of
Just True -> Nothing
_ -> Just (emptyChatPrefs :: Preferences) {files = Just FilesPreference {allow = FANo}}
profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Just CPTBot, preferences}
profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences, badge = Nothing, simplexName = Nothing}
pure NewUser {profile, pastTimestamp = False, userChatRelay = BoolDef False, clientService = BoolDef service}
jsonP :: J.FromJSON a => Parser a
jsonP = J.eitherDecodeStrict' <$?> A.takeByteString
src/Simplex/Chat/Library/Internal.hs
+299 -63
View File
@@ -53,12 +53,13 @@ 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 (..), BadgePresHeader (..), BadgeProof (..), BadgeStatus (..), LocalBadge (..), badgeProof, mkBadgeStatus, verifyBadge)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Files
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (BatchMode (..), MsgBatch (..), batchMessages, encodeBinaryBatch, encodeFwdElement)
import Simplex.Chat.Messages.Batch (BatchMode (..), MsgBatch (..), batchMessages, encodeBatchElement, encodeBinaryBatch, encodeFwdElement)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.Operators
@@ -79,6 +80,7 @@ import Simplex.Chat.Types.Shared
import Simplex.Chat.Util (encryptFile, shuffle)
import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription)
import qualified Simplex.FileTransfer.Description as FD
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
import Simplex.Messaging.Agent
@@ -89,7 +91,7 @@ import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Client (NetworkConfig (..), NetworkRequestMode (..))
import Simplex.Messaging.Compression (compressionLevel)
import Simplex.Messaging.Compression (compressionLevel, limitDecompress')
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
@@ -366,7 +368,7 @@ prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> MsgContent -> Maybe MarkdownList -> Bool
prohibitedSimplexLinks gInfo m mc ft =
not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo)
&& (isChatLink mc || maybe False (any ftIsSimplexLink) ft)
&& (isChatLink mc || maybe False (any ftIsSimplexLink) ft || hasObfuscatedSimplexLink (msgContentText mc))
where
isChatLink = \case
MCChat {} -> True
@@ -699,7 +701,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
ci <- xftpAcceptRcvFT db cxt user fileId filePath userApproved
rfd <- getRcvFileDescrByRcvFileId db fileId
pure (ci, rfd)
receiveViaCompleteFD user fileId rfd userApproved cryptoArgs
receiveViaCompleteFD user fileId rfd fileSize userApproved cryptoArgs
pure ci
(Nothing, Just _fileConnReq) -> throwChatError $ CEException "accepting file via a separate connection is deprecated"
-- group & direct file protocol
@@ -741,10 +743,17 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|| (rcvInline_ == Just True && fileSize <= fileChunkSize * offerChunks)
)
receiveViaCompleteFD :: User -> FileTransferId -> RcvFileDescr -> Bool -> Maybe CryptoFileArgs -> CM ()
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} userApprovedRelays cfArgs =
receiveViaCompleteFD :: User -> FileTransferId -> RcvFileDescr -> Integer -> Bool -> Maybe CryptoFileArgs -> CM ()
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} expectedFileSize userApprovedRelays cfArgs =
when fileDescrComplete $ do
rd <- parseFileDescription fileDescrText
let FD.ValidFileDescription FD.FileDescription {size = FD.FileSize encSize, redirect} = rd
redirectSize = maybe 0 (\FD.RedirectFileInfo {size = FD.FileSize s} -> toInteger s) redirect
-- for a redirect, encSize is the description blob and redirectSize the final file; take the larger
rcvSize = max (toInteger encSize) redirectSize
-- 10 MB margin: encryption and chunk-size rounding make the transfer larger than the advertised size
maxRcvSize = min expectedFileSize (toInteger FD.maxFileSizeHard) + toInteger (FD.mb 10 :: Int64)
when (rcvSize > maxRcvSize) $ throwChatError $ CEFileRcvChunk "declared file size exceeds the file invitation size"
if userApprovedRelays
then receive' rd True
else do
@@ -904,7 +913,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
Just conn@Connection {customUserProfileId} -> do
incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
pure (ct, conn, ExistingIncognito <$> incognitoProfile)
let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend
(ct,conn,) <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode)
@@ -916,7 +925,7 @@ acceptContactRequestAsync
UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId, pqSupport = cReqPQSup}
incognitoProfile = do
subMode <- chatReadVar subscriptionMode
let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
(cmdId, acId) <- agentAcceptContactAsync user True cReqInvId (XInfo profileToSend) subMode cReqPQSup chatV
@@ -927,9 +936,9 @@ acceptContactRequestAsync
liftIO $ setCommandConnId db user cmdId connId
getContact db cxt user contactId
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> CM GroupMember
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
user@User {userId}
uclId
gInfo@GroupInfo {groupProfile, membership, businessChat}
cReqInvId
@@ -941,11 +950,22 @@ acceptGroupJoinRequestAsync
gAccepted
gLinkMemRole
incognitoProfile
memberKey_ = do
memberKey_
existingMem_ = do
gVar <- asks random
let initialStatus = acceptanceToStatus (memberAdmission groupProfile) gAccepted
(groupMemberId, memberId) <- withStore $ \db ->
createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_
-- a roster-established privileged member attaches a connection to its existing record (keeping
-- owner-authoritative role + key); everyone else is created fresh with the group-link role
cxt <- chatStoreCxt
(groupMemberId, memberId) <- case existingMem_ of
Just m -> do
-- refresh the hash placeholder name from the authenticated join profile; role + key stay roster-authoritative
withStore $ \db -> do
liftIO $ updateGroupMemberStatus db userId m initialStatus
void $ updateMemberProfile db cxt user m cReqProfile
pure (groupMemberId' m, memberId' m)
Nothing -> withStore $ \db ->
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_
let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo
let Profile {displayName} = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile)
GroupMember {memberRole = userRole, memberId = userMemberId} = membership
@@ -961,7 +981,6 @@ acceptGroupJoinRequestAsync
groupSize = Just currentMemCount
}
subMode <- chatReadVar subscriptionMode
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
withStore $ \db -> do
@@ -979,8 +998,9 @@ acceptGroupJoinSendRejectAsync
cReqXContactId_
rejectionReason = do
gVar <- asks random
cxt <- chatStoreCxt
(groupMemberId, memberId) <- withStore $ \db ->
createJoiningMember db gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ Nothing Nothing GRObserver GSMemRejected Nothing
createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile cReqXContactId_ Nothing Nothing GRObserver GSMemRejected Nothing
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
msg =
XGrpLinkReject $
@@ -991,7 +1011,6 @@ acceptGroupJoinSendRejectAsync
rejectionReason
}
subMode <- chatReadVar subscriptionMode
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
connIds <- agentAcceptContactAsync user False cReqInvId msg subMode PQSupportOff chatV
withStore $ \db -> do
@@ -1045,8 +1064,9 @@ acceptRelayJoinRequestAsync
cReqInvId
cReqChatVRange
relayLink = do
-- TODO [channel web] derive RelayCapabilities from relay config (RelayWebOptions)
let msg = XGrpRelayAcpt relayLink defaultRelayCapabilities
ChatConfig {webPreviewConfig} <- asks config
let webDomain_ = (\WebPreviewConfig {webDomain} -> webDomain) <$> webPreviewConfig
msg = XGrpRelayAcpt relayLink RelayCapabilities {webDomain = webDomain_}
subMode <- chatReadVar subscriptionMode
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
@@ -1160,24 +1180,50 @@ memberIntroEvt gInfo reMember =
mRestrictions = memberRestrictions reMember
in XGrpMemIntro mInfo mRestrictions
-- 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 =
when (member `supportsVersion` groupRosterVersion) $ do
cxt <- chatStoreCxt
withStore' (\db -> getGroupRoster db gInfo) >>= \case
Just (ownerGMId, brokerTs, sm@SignedMsg {signedBody}, blob_) ->
case J.eitherDecodeStrict' signedBody :: Either String (ChatMessage 'Json) of
Left e -> logError $ "serveRoster: cannot decode saved roster message: " <> tshow e
Right chatMsg@ChatMessage {msgId} ->
withStore' (\db -> runExceptT $ getGroupMemberById db cxt user ownerGMId) >>= \case
Right owner -> do
let fwd = GrpMsgForward {fwdSender = FwdMember (memberId' owner) (memberShortenedName owner), fwdBrokerTs = brokerTs}
sendFwdMemberMessage member fwd (VMSigned MSSVerified sm chatMsg)
forM_ ((,) <$> msgId <*> blob_) $ \(sid, blob) ->
sendInlineBlobChunks user gInfo [member] sid blob
Left e -> logError $ "serveRoster: roster owner not found: " <> tshow e
Nothing -> pure ()
-- 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 _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
introduceInChannel cxt user gInfo subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
(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
withStore' $ \db ->
setMemberVectorNewRelations db subscriber [(indexInGroup m, (IDSubjectIntroduced, MRIntroduced)) | m <- modMs]
let introEvts = map (memberIntroEvt gInfo) modMs
forM_ (L.nonEmpty introEvts) $ \introEvts' ->
sendGroupMemberMessages user gInfo conn introEvts'
-- 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
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
userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup user = userProfileInGroup' user . groupFeatureUserAllowed SGFSimplexLinks
userProfileInGroup user = userProfileInGroup' user . groupUserAllowSimplexLinks
{-# INLINE userProfileInGroup #-}
userProfileInGroup' :: User -> Bool -> Maybe Profile -> Profile
@@ -1195,16 +1241,40 @@ memberInfo g m@GroupMember {memberId, memberRole, memberProfile, memberPubKey, a
memberKey = MemberKey <$> memberPubKey
}
where
allowSimplexLinks = groupFeatureMemberAllowed SGFSimplexLinks m g
allowSimplexLinks = groupFeatureMemberAllowed SGFSimplexLinks m g && groupFeatureMemberAllowed SGFDirectMessages m g
redactedMemberProfile :: Bool -> Profile -> Profile
redactedMemberProfile allowSimplexLinks Profile {displayName, fullName, shortDescr, image, simplexName, peerType} =
Profile {displayName, fullName, shortDescr = removeSimplexLink =<< shortDescr, image, contactLink = Nothing, simplexName, preferences = Nothing, peerType}
redactedMemberProfile allowSimplexLinks Profile {displayName, fullName, shortDescr, image, peerType, badge, simplexName} =
Profile {displayName, fullName, shortDescr = removeSimplexLink =<< shortDescr, image, contactLink = Nothing, preferences = Nothing, peerType, badge, simplexName}
where
removeSimplexLink s
| allowSimplexLinks = Just s
| hasObfuscatedSimplexLink s = Nothing
| otherwise = maybe (Just s) (\fts -> if any ftIsSimplexLink fts then Nothing else Just s) $ parseMaybeMarkdownList s
-- Roles carried by the roster; owners are on the link, not the roster.
isRosterRole :: GroupMemberRole -> Bool
isRosterRole r = r == GRMember || r == GRModerator || r == GRAdmin
-- Drop non-privileged-role entries and de-duplicate by memberId, keeping the first.
-- Runs on the parsed roster blob.
validateGroupRoster :: [RosterMember] -> [RosterMember]
validateGroupRoster entries =
dedup S.empty $ filter (\RosterMember {role} -> isRosterRole role) entries
where
dedup _ [] = []
dedup seen (rm@RosterMember {memberId} : rms)
| memberId `S.member` seen = dedup seen rms
| otherwise = rm : dedup (S.insert memberId seen) rms
-- Privileged members without a known key are skipped (recipients can't verify them).
buildGroupRoster :: [GroupMember] -> [RosterMember]
buildGroupRoster mods = take maxGroupRosterSize $ mapMaybe rosterMember mods
where
rosterMember GroupMember {memberId, memberPubKey, memberRole}
| isRosterRole memberRole = (\k -> RosterMember {memberId, key = MemberKey k, role = memberRole, privileges = 0}) <$> memberPubKey
| otherwise = Nothing
sendHistory :: User -> GroupInfo -> GroupMember -> CM ()
sendHistory _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just conn} =
@@ -1331,7 +1401,7 @@ setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM G
setGroupLinkData nm user gInfo gLink = do
cxt <- chatStoreCxt
(conn, groupRelays) <- withFastStore $ \db ->
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo 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))
@@ -1341,7 +1411,7 @@ setGroupLinkDataAsync :: User -> GroupInfo -> GroupLink -> CM ()
setGroupLinkDataAsync user gInfo gLink = do
cxt <- chatStoreCxt
(conn, groupRelays) <- withStore $ \db ->
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
setAgentConnShortLinkAsync user conn userLinkData (Just crClientData)
@@ -1367,6 +1437,9 @@ updatePublicGroupData user gInfo
pure (gInfo', gLink)
setGroupLinkDataAsync user gInfo' gLink
pure gInfo'
| useRelays' gInfo && isRelay (membership gInfo) = do
cxt <- chatStoreCxt
withStore $ \db -> updatePublicMemberCount db cxt user gInfo
| otherwise = pure gInfo
updateGroupFromLinkData :: User -> GroupInfo -> GroupShortLinkData -> CM (GroupInfo, Bool)
@@ -1437,10 +1510,9 @@ encodeShortLinkData d =
decodeLinkUserData :: J.FromJSON a => ConnLinkData c -> IO (Maybe a)
decodeLinkUserData cData
| B.null s = pure Nothing
| B.head s == 'X' = case Z1.decompress $ B.drop 1 s of
Z1.Error e -> Nothing <$ logError ("Error decompressing link data: " <> tshow e)
Z1.Skip -> pure Nothing
Z1.Decompress s' -> decode s'
| B.head s == 'X' = case limitDecompress' maxDecompressedMsgLength $ B.drop 1 s of
Left e -> Nothing <$ logError ("Error decompressing link data: " <> tshow e)
Right s' -> decode s'
| otherwise = decode s
where
decode s' = case J.eitherDecodeStrict s' of
@@ -1616,13 +1688,16 @@ sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg =
chSize = fromIntegral chunkSize
parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json)
parseChatMessage conn s = do
parseChatMessage conn s = snd <$> parseChatMessage' conn s
{-# INLINE parseChatMessage #-}
parseChatMessage' :: Connection -> ByteString -> CM (Maybe SignedMsg, ChatMessage 'Json)
parseChatMessage' conn s =
case parseChatMessages s of
[msg] -> liftEither . first (ChatError . errType) $ (\(APMsg _ (ParsedMsg _ _ m)) -> checkEncoding m) =<< msg
[msg] -> liftEither . first (ChatError . errType) $ (\(APMsg _ (ParsedMsg _ sm m)) -> (sm,) <$> checkEncoding m) =<< msg
_ -> throwChatError $ CEException "parseChatMessage: single message is expected"
where
errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s)
{-# INLINE parseChatMessage #-}
getChatScopeInfo :: StoreCxt -> User -> GroupChatScope -> CM GroupChatScopeInfo
getChatScopeInfo cxt user = \case
@@ -1819,6 +1894,51 @@ closeFileHandle fileId files = do
h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m)
liftIO $ mapM_ hClose h_ `catchAll_` pure ()
-- The roster file has no chat item, so chat-item file enumeration misses it; clean it up by group.
cleanupGroupRosterFile :: User -> GroupInfo -> CM ()
cleanupGroupRosterFile User {userId} GroupInfo {groupId} = do
infos <- withStore' $ \db -> getGroupRosterFileInfo db userId groupId
forM_ infos $ \(fileId, filePath_) -> do
lift $ closeFileHandle fileId rcvFiles
forM_ filePath_ removeFsFile
withStore' $ \db -> do
deleteGroupRosterFile db userId groupId
deleteGroupRosterTransfers db groupId
-- Supersede/cancel one source relay's in-flight roster transfer: remove its on-disk file + cached
-- handle first (the cascade only does rows), then the files + transfer rows.
cleanupRosterTransfer :: GroupInfo -> GroupMemberId -> CM ()
cleanupRosterTransfer gInfo fromMemberId =
withStore' (\db -> getRosterTransferId db gInfo fromMemberId) >>= mapM_ cleanupRosterTransferById
cleanupRosterTransferById :: Int64 -> CM ()
cleanupRosterTransferById transferId = do
file_ <- withStore' $ \db -> getRosterTransferFile db transferId
forM_ file_ $ \(fileId, filePath_) -> do
lift $ closeFileHandle fileId rcvFiles
forM_ filePath_ removeFsFile
withStore' $ \db -> do
deleteRosterTransferFile db transferId
deleteRosterTransfer db transferId
-- MUST evict the cached AppendMode handle before deleting chunks, else re-driven bytes append
-- after the stale prefix and corrupt the blob.
resetRosterPartialChunks :: RcvFileTransfer -> CM ()
resetRosterPartialChunks ft@RcvFileTransfer {fileId, fileStatus} = do
lift $ closeFileHandle fileId rcvFiles
forM_ (rcvFilePath fileStatus) removeFsFile
withStore' $ \db -> deleteRcvFileChunks db ft
where
rcvFilePath = \case
RFSAccepted p -> Just p
RFSConnected p -> Just p
_ -> Nothing
removeFsFile :: FilePath -> CM ()
removeFsFile fp = do
p <- lift $ toFSFilePath fp
removeFile p `catchAllErrors` \_ -> pure ()
deleteMembersConnections :: User -> [GroupMember] -> CM ()
deleteMembersConnections user members = deleteMembersConnections' user members False
@@ -1911,6 +2031,33 @@ sendDirectContactMessages' user ct events = do
forM_ pqEnc_ $ \pqEnc' -> void $ createContactPQSndItem user ct conn pqEnc'
pure sndMsgs'
-- present the user's own badge on an outgoing profile: a fresh, single-use proof from the stored credential.
-- the send's incognito profile (when set) suppresses it - an incognito identity must never carry the badge.
-- a long-expired badge is not presented at all (receivers would hide it anyway).
presentUserBadge :: User -> Maybe i -> Profile -> CM Profile
presentUserBadge User {profile = LocalProfile {localBadge}} incognitoProfile p = case (incognitoProfile, localBadge) of
(Nothing, Just (OwnBadge cred@(BadgeCredential keyIdx _ _ _) st)) | st == BSActive || st == BSExpired -> do
keys <- asks $ badgePublicKeys . config
case M.lookup keyIdx keys of
Nothing -> p <$ logError "presentUserBadge: badge key index not in config"
Just key -> do
nonce <- drgRandomBytes 16
liftIO (badgeProof key cred (PHTest nonce)) >>= \case
Right proof -> pure p {badge = Just proof}
Left e -> p <$ logError ("presentUserBadge: proof generation failed: " <> T.pack e)
_ -> pure p
-- receiving side of contact/invitation link data: verify the badge proof from the link profile
-- and set the crypto-free display badge for the UI (the raw proof stays in profile for APIPrepareContact)
linkDataBadge :: ContactShortLinkData -> CM ContactShortLinkData
linkDataBadge cld@ContactShortLinkData {profile = Profile {badge}} = case badge of
Nothing -> pure cld
Just b@(BadgeProof _ _ _ info) -> do
keys <- asks $ badgePublicKeys . config
verified <- liftIO $ verifyBadge keys b
now <- liftIO getCurrentTime
pure (cld :: ContactShortLinkData) {localBadge = Just $ ShownBadge info (mkBadgeStatus now verified info)}
sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64)
sendDirectContactMessage user ct chatMsgEvent = do
conn@Connection {connId} <- liftEither $ contactSendConn_ ct
@@ -2024,6 +2171,26 @@ encodeConnInfoPQ pqSup v chatMsgEvent = do
_ -> pure connInfo
ECMLarge -> throwChatError $ CEException "large info"
-- conn-info wrapped as a signed element, so the receiver can verify the signature over the body
encodeSignedConnInfo :: MsgEncodingI e => MsgSigning -> ChatMsgEvent e -> CM ByteString
encodeSignedConnInfo signing chatMsgEvent = do
vr <- chatVersionRange
let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent}
case encodeChatMessage maxEncodedInfoLength info of
ECMEncoded body -> pure $ encodeBatchElement (Just $ signChatMsgBody signing body) body
ECMLarge -> throwChatError $ CEException "large signed info"
-- 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"
deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
deliverMessage conn cmEventTag msgBody msgId = do
let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
@@ -2097,6 +2264,68 @@ sendGroupMessage' user gInfo members chatMsgEvent =
((Right msg) :| [], _) -> pure msg
_ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message"
-- TODO [relays] improvement: publish roster_version in link data so the owner can recover the latest version
-- TODO after restoring from a stale backup (relays accept only strictly-greater versions)
-- Persist the next roster version before sending the events that carry it (so a recipient never advances
-- past a version the owner hasn't recorded). The matching blob is broadcast separately, by broadcastRoster,
-- after the change is applied to the owner's members - so the served roster excludes demoted/removed members.
reserveRosterVersion :: GroupInfo -> CM VersionRoster
reserveRosterVersion gInfo = do
let rosterVer = maybe (VersionRoster 0) (\(VersionRoster n) -> VersionRoster (n + 1)) (rosterVersion gInfo)
withStore' $ \db -> setGroupRosterVersion db gInfo rosterVer
pure rosterVer
broadcastRoster :: User -> GroupInfo -> VersionRoster -> CM ()
broadcastRoster user gInfo rosterVer = do
cxt <- chatStoreCxt
(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 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 =
forM_ (rosterVersion gInfo) $ \rosterVer -> do
cxt <- chatStoreCxt
rosterMems <- withStore' $ \db -> getGroupRosterMembers db cxt user gInfo
sendRoster user gInfo [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 gInfo members rosterVer roster = do
let blob = encodeRosterBlob roster
fileInv = InlineFileInvitation {fileSize = fromIntegral (B.length blob), fileDigest = FD.FileDigest $ LC.sha512Hash $ LB.fromStrict blob}
SndMessage {sharedMsgId} <- sendGroupMessage' user gInfo members (XGrpRoster GroupRoster {version = rosterVer, fileInv})
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 gInfo members sharedMsgId blob = do
chSize <- fromIntegral <$> asks (fileChunkSize . config)
go chSize 1 blob
where
go chSize chunkNo bytes = do
let (chunk, rest) = B.splitAt chSize bytes
void $ sendGroupMessage' user gInfo members (BFileChunk sharedMsgId (FileChunk chunkNo chunk))
unless (B.null rest) $ go chSize (chunkNo + 1) rest
-- 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
ChatConfig {webPreviewConfig} <- asks config
let currentWebDomain = (\WebPreviewConfig {webDomain} -> webDomain) <$> webPreviewConfig
sentWebDomain <- withStore' (`getRelaySentWebDomain` gInfo)
when (currentWebDomain /= sentWebDomain) $ do
cxt <- chatStoreCxt
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})
withStore' $ \db -> updateRelaySentWebDomain db gInfo currentWebDomain
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages user gInfo scope asGroup members events = do
-- TODO [knocking] send current profile to pending member after approval?
@@ -2117,9 +2346,10 @@ sendGroupMessages user gInfo scope asGroup members events = do
_ -> False
sendProfileUpdate = do
let members' = filter (`supportsVersion` memberProfileUpdateVersion) members
allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo
profileUpdateEvent = XInfo $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile p
void $ sendGroupMessage' user gInfo members' profileUpdateEvent
allowSimplexLinks = groupUserAllowSimplexLinks gInfo
-- shouldSendProfileUpdate excludes incognito membership, so the badge is presented
profileUpdate <- presentUserBadge user Nothing $ redactedMemberProfile allowSimplexLinks $ fromLocalProfile p
void $ sendGroupMessage' user gInfo members' $ XInfo profileUpdate
currentTs <- liftIO getCurrentTime
withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs
@@ -2316,10 +2546,14 @@ saveDirectRcvMSG conn@Connection {connId} agentMsgMeta chatMsg@ChatMessage {chat
msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing
pure (conn', msg)
saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> VerifiedMsg e -> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg :: forall e. MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> VerifiedMsg e -> CM (GroupMember, Connection, RcvMessage)
saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta verifiedMsg = do
let ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = verifiedChatMsg verifiedMsg
(am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- updateMemberChatVRange authorMember conn chatVRange
-- binary messages (file chunks) carry only the initial-version sentinel, not the sender's range;
-- applying it would downgrade the member's negotiated version and suppress version-gated delivery
(am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- case encoding @e of
SBinary -> pure (authorMember, conn)
SJson -> updateMemberChatVRange authorMember conn chatVRange
let agentMsgId = fst $ recipient agentMsgMeta
brokerTs = metaBrokerTs agentMsgMeta
newMsg = NewRcvMessage {chatMsgEvent, verifiedMsg, brokerTs}
@@ -2457,11 +2691,11 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMem
_ -> Nothing
-- TODO [mentions] optimize by avoiding unnecessary parsing
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs =
mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember msgSigned currentTs =
let ts@(_, ft_) = ciContentTexts content
hasLink_ = ciContentHasLink content ft_
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember Nothing currentTs
in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs
mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Maybe MsgSigStatus -> UTCTime -> ChatItem c d
mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs =
@@ -2623,7 +2857,7 @@ createFeatureEnabledItems_ :: User -> Contact -> CM [AChatItem]
createFeatureEnabledItems_ user ct@Contact {mergedPreferences} =
forM allChatFeatures $ \(ACF f) -> do
let state = featureState $ getContactUserPreference f mergedPreferences
createChatItem user (CDDirectRcv ct) False (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing Nothing
createChatItem user (CDDirectRcv ct) False (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing Nothing Nothing
createFeatureItems ::
MsgDirectionI d =>
@@ -2653,15 +2887,15 @@ createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do
unless (null errs) $ toView' $ CEvtChatErrors errs
toView' $ CEvtNewChatItems user acis
where
contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)])
contactChangedFeatures :: (Contact, Contact) -> (ChatDirection 'CTDirect d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)])
contactChangedFeatures (Contact {mergedPreferences = cups}, ct'@Contact {mergedPreferences = cups'}) = do
let contents = mapMaybe (\(ACF f) -> featureCIContent_ f) allChatFeatures
(chatDir ct', False, contents)
where
featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId)
featureCIContent_ :: forall f. FeatureI f => SChatFeature f -> Maybe (CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)
featureCIContent_ f
| state /= state' = Just (fContent ciFeature state', Nothing)
| prefState /= prefState' = Just (fContent ciOffer prefState', Nothing)
| state /= state' = Just (fContent ciFeature state', Nothing, Nothing)
| prefState /= prefState' = Just (fContent ciOffer prefState', Nothing, Nothing)
| otherwise = Nothing
where
fContent :: FeatureContent a d -> (a, Maybe Int) -> CIContent d
@@ -2694,16 +2928,16 @@ createGroupFeatureItems_ user cd showGroupAsSender ciContent GroupInfo {fullGrou
forM allGroupFeatures $ \(AGF f) -> do
let p = getGroupPreference f fullGroupPreferences
(_, param, role) = groupFeatureState p
createChatItem user cd showGroupAsSender (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing Nothing
createChatItem user cd showGroupAsSender (ciContent (toGroupFeature f) (toGroupPreference p) param role) Nothing Nothing Nothing
createInternalChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> CIContent d -> Maybe UTCTime -> CM ()
createInternalChatItem user cd content itemTs_ = do
ci <- createChatItem user cd False content Nothing itemTs_
ci <- createChatItem user cd False content Nothing Nothing itemTs_
toView $ CEvtNewChatItems user [ci]
createChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Maybe UTCTime -> CM AChatItem
createChatItem user cd showGroupAsSender content sharedMsgId itemTs_ =
lift (createChatItems user itemTs_ [(cd, showGroupAsSender, [(content, sharedMsgId)])]) >>= \case
createChatItem :: (ChatTypeI c, MsgDirectionI d) => User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Maybe MsgSigStatus -> Maybe UTCTime -> CM AChatItem
createChatItem user cd showGroupAsSender content sharedMsgId msgSigned itemTs_ =
lift (createChatItems user itemTs_ [(cd, showGroupAsSender, [(content, sharedMsgId, msgSigned)])]) >>= \case
[Right ci] -> pure ci
[Left e] -> throwError e
rs -> throwChatError $ CEInternalError $ "createInternalChatItem: expected 1 result, got " <> show (length rs)
@@ -2715,7 +2949,7 @@ createChatItems ::
(ChatTypeI c, MsgDirectionI d) =>
User ->
Maybe UTCTime ->
[(ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)])] ->
[(ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)])] ->
CM' [Either ChatError AChatItem]
createChatItems user itemTs_ dirsCIContents = do
createdAt <- liftIO getCurrentTime
@@ -2724,24 +2958,24 @@ createChatItems user itemTs_ dirsCIContents = do
void . withStoreBatch' $ \db -> map (updateChat db cxt createdAt) dirsCIContents
withStoreBatch' $ \db -> concatMap (createACIs db itemTs createdAt) dirsCIContents
where
updateChat :: DB.Connection -> StoreCxt -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> IO ()
updateChat :: DB.Connection -> StoreCxt -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)]) -> IO ()
updateChat db cxt createdAt (cd, _, contents)
| any (ciRequiresAttention . fst) contents || contactChatDeleted cd = void $ updateChatTsStats db cxt user cd createdAt memberChatStats
| any (\(content, _, _) -> ciRequiresAttention content) contents || contactChatDeleted cd = void $ updateChatTsStats db cxt user cd createdAt memberChatStats
| otherwise = pure ()
where
memberChatStats :: Maybe (Int, MemberAttention, Int)
memberChatStats = case cd of
CDGroupRcv _g (Just scope) m -> do
let unread = length $ filter (ciRequiresAttention . fst) contents
let unread = length $ filter (\(content, _, _) -> ciRequiresAttention content) contents
in Just (unread, memberAttentionChange unread itemTs_ (Just m) scope, 0)
_ -> Nothing
createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> [IO AChatItem]
createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId, Maybe MsgSigStatus)]) -> [IO AChatItem]
createACIs db itemTs createdAt (cd, showGroupAsSender, contents) = map createACI contents
where
createACI (content, sharedMsgId) = do
createACI (content, sharedMsgId, msgSigned) = do
let hasLink_ = ciContentHasLink content Nothing
ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ itemTs createdAt
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt
ciId <- createNewChatItemNoMsg db user cd showGroupAsSender content sharedMsgId hasLink_ msgSigned itemTs createdAt
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing msgSigned createdAt
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
-- rcvMem_ Nothing means message from channel - treated same as message from moderator,
@@ -2854,7 +3088,8 @@ simplexTeamContactProfile =
contactLink = Just $ CLFull adminContactReq,
simplexName = Nothing,
peerType = Nothing,
preferences = Nothing
preferences = Nothing,
badge = Nothing
}
simplexStatusContactProfile :: Profile
@@ -2867,7 +3102,8 @@ simplexStatusContactProfile =
contactLink = Just (either error CLFull $ strDecode "simplex:/contact/#/?v=1-2&smp=smp%3A%2F%2Fu2dS9sG8nMNURyZwqASV4yROM28Er0luVTx5X1CsMrU%3D%40smp4.simplex.im%2FShQuD-rPokbDvkyotKx5NwM8P3oUXHxA%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEA6fSx1k9zrOmF0BJpCaTarZvnZpMTAVQhd3RkDQ35KT0%253D%26srv%3Do5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"),
simplexName = Nothing,
peerType = Just CPTBot,
preferences = Nothing
preferences = Nothing,
badge = Nothing
}
timeItToView :: String -> CM' a -> CM' a
src/Simplex/Chat/Library/Subscriber.hs
+548 -198
View File
File diff suppressed because it is too large Load Diff
src/Simplex/Chat/Markdown.hs
+11
View File
@@ -18,6 +18,7 @@ import Control.Monad
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import qualified Data.Attoparsec.ByteString.Char8 as AB
import Data.Attoparsec.Text (Parser)
import qualified Data.Attoparsec.Text as A
import Data.ByteString.Char8 (ByteString)
@@ -191,6 +192,16 @@ isLink = \case
hasLinks :: MarkdownList -> Bool
hasLinks = any $ \(FormattedText f _) -> maybe False isLink f
hasObfuscatedSimplexLink :: Text -> Bool
hasObfuscatedSimplexLink t =
fromRight False $ AB.parseOnly findLinkP $ encodeUtf8 $ T.filter (not . isSpace) t
where
findLinkP = do
AB.skipWhile (\c -> c /= 's' && c /= 'h') -- links start only with "simplex:" or "https://"
(True <$ (strP :: AB.Parser AConnectionLink))
<|> (AB.anyChar *> findLinkP)
<|> pure False
markdownP :: Parser Markdown
markdownP = mconcat <$> A.many' fragmentP
where
src/Simplex/Chat/Messages/Batch.hs
+7 -7
View File
@@ -24,7 +24,6 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B
import Data.Char (ord)
import Data.Function (on)
import Data.Foldable (foldr')
import Data.List (foldl', sortBy)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
@@ -79,15 +78,15 @@ batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0)
let encoded = encodeBatch mode bodies
in Right (MsgBatch encoded msgs) : batches
-- | Batches delivery tasks into (batch, accepted, large).
-- | Batches delivery tasks into (batch if any task was accepted, accepted, large).
-- Always uses binary batch format for relay groups.
batchDeliveryTasks1 :: VersionRangeChat -> Int -> NonEmpty MessageDeliveryTask -> (ByteString, [MessageDeliveryTask], [MessageDeliveryTask])
batchDeliveryTasks1 :: VersionRangeChat -> Int -> NonEmpty MessageDeliveryTask -> (Maybe ByteString, [MessageDeliveryTask], [MessageDeliveryTask])
batchDeliveryTasks1 _vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0) . L.toList
where
addToBatch :: ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int) -> MessageDeliveryTask -> ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int)
addToBatch (msgBodies, accepted, large, len, n) task
-- too large: skip, record in large
| msgLen > maxLen = (msgBodies, accepted, task : large, len, n)
-- element can't fit even a singleton batch (4-byte binary-batch framing)
| msgLen + 4 > maxLen = (msgBodies, accepted, task : large, len, n)
-- fits: include in batch
-- batch overhead: '=' + count (2) + 2-byte length prefix per element
| len' + (n + 1) * 2 + 2 <= maxLen = (msgBody : msgBodies, task : accepted, large, len', n + 1)
@@ -98,10 +97,11 @@ batchDeliveryTasks1 _vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0)
msgBody = encodeFwdElement GrpMsgForward {fwdSender, fwdBrokerTs} verifiedMsg
msgLen = B.length msgBody
len' = len + msgLen
toResult :: ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int) -> (ByteString, [MessageDeliveryTask], [MessageDeliveryTask])
toResult :: ([ByteString], [MessageDeliveryTask], [MessageDeliveryTask], Int, Int) -> (Maybe ByteString, [MessageDeliveryTask], [MessageDeliveryTask])
toResult (msgBodies, accepted, large, _, _) =
let encoded = encodeBinaryBatch (reverse msgBodies)
in (encoded, reverse accepted, reverse large)
body = if null accepted then Nothing else Just encoded
in (body, reverse accepted, reverse large)
-- | Encode a batch element for relay groups: ><GrpMsgForward>[/<sigs>]<body>.
encodeFwdElement :: GrpMsgForward -> VerifiedMsg 'Json -> ByteString
src/Simplex/Chat/Mobile.hs
+6
View File
@@ -38,6 +38,7 @@ import Simplex.Chat
import Simplex.Chat.Controller
import Simplex.Chat.Library.Commands
import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList, parseUri, sanitizeUri)
import Simplex.Chat.Mobile.Badges
import Simplex.Chat.Mobile.File
import Simplex.Chat.Mobile.Shared
import Simplex.Chat.Mobile.WebRTC
@@ -138,6 +139,10 @@ foreign export ccall "chat_valid_name" cChatValidName :: CString -> IO CString
foreign export ccall "chat_json_length" cChatJsonLength :: CString -> IO CInt
foreign export ccall "chat_badge_keygen" cChatBadgeKeygen :: IO CJSONString
foreign export ccall "chat_badge_issue" cChatBadgeIssue :: CString -> IO CJSONString
foreign export ccall "chat_encrypt_media" cChatEncryptMedia :: StablePtr ChatController -> CString -> Ptr Word8 -> CInt -> IO CString
foreign export ccall "chat_decrypt_media" cChatDecryptMedia :: CString -> Ptr Word8 -> CInt -> IO CString
@@ -256,6 +261,7 @@ mobileChatOpts dbOptions =
tbqSize = 4096,
deviceName = Nothing,
chatRelay = False,
webPreviewConfig = Nothing,
highlyAvailable = False,
yesToUpMigrations = False,
migrationBackupPath = Just "",
src/Simplex/Chat/Mobile/Badges.hs
+74
View File
@@ -0,0 +1,74 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Mobile.Badges
( cChatBadgeKeygen,
cChatBadgeIssue,
BadgeResult (..),
BadgeIssueReq (..),
IssuerKeyPair (..),
)
where
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import qualified Data.ByteString as B
import Data.Text (Text)
import qualified Data.Text as T
import Foreign.C (CString)
import Simplex.Chat.Badges
import Simplex.Chat.Mobile.Shared (CJSONString, newCStringFromLazyBS)
import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen)
import Simplex.Messaging.Parsers (defaultJSON)
-- FFI envelope for a generated issuer keypair (the BBS keypair tuple serialized with named fields)
data IssuerKeyPair = IssuerKeyPair
{ publicKey :: BBSPublicKey,
secretKey :: BBSSecretKey
}
data BadgeIssueReq = BadgeIssueReq
{ badgeKeyIdx :: Int,
secretKey :: BBSSecretKey,
request :: BadgeRequest
}
data BadgeResult r
= BadgeResult {result :: r}
| BadgeError {error :: Text}
$(JQ.deriveJSON defaultJSON ''IssuerKeyPair)
$(JQ.deriveJSON defaultJSON ''BadgeIssueReq)
$(pure [])
instance ToJSON r => ToJSON (BadgeResult r) where
toEncoding = $(JQ.mkToEncoding (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''BadgeResult)
toJSON = $(JQ.mkToJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''BadgeResult)
instance FromJSON r => FromJSON (BadgeResult r) where
parseJSON = $(JQ.mkParseJSON (defaultJSON {J.sumEncoding = J.UntaggedValue}) ''BadgeResult)
cChatBadgeKeygen :: IO CJSONString
cChatBadgeKeygen =
bbsKeyGen >>= \case
Right (pk, sk) -> encodeResult $ BadgeResult (IssuerKeyPair pk sk)
Left e -> encodeResult @IssuerKeyPair $ BadgeError (T.pack e)
cChatBadgeIssue :: CString -> IO CJSONString
cChatBadgeIssue cReq = do
bs <- B.packCString cReq
encodeResult @BadgeCredential =<< case J.eitherDecodeStrict' bs of
Left e -> pure $ BadgeError (T.pack e)
Right BadgeIssueReq {badgeKeyIdx, secretKey, request} ->
either (BadgeError . T.pack) BadgeResult <$> issueBadge badgeKeyIdx secretKey (VerifiedBadgeRequest request)
encodeResult :: ToJSON r => BadgeResult r -> IO CJSONString
encodeResult = newCStringFromLazyBS . J.encode
src/Simplex/Chat/Options.hs
+43 -1
View File
@@ -28,7 +28,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Numeric.Natural (Natural)
import Options.Applicative
import Simplex.Chat.Controller (ChatLogLevel (..), SimpleNetCfg (..), updateStr, versionNumber, versionString)
import Simplex.Chat.Controller (ChatLogLevel (..), SimpleNetCfg (..), WebPreviewConfig (..), updateStr, versionNumber, versionString)
import Simplex.FileTransfer.Description (mb)
import Simplex.Messaging.Client (HostMode (..), SMPWebPortServers (..), SocksMode (..), textToHostMode)
import Simplex.Messaging.Encoding.String
@@ -66,6 +66,7 @@ data CoreChatOpts = CoreChatOpts
tbqSize :: Natural,
deviceName :: Maybe Text,
chatRelay :: Bool,
webPreviewConfig :: Maybe WebPreviewConfig,
highlyAvailable :: Bool,
yesToUpMigrations :: Bool,
migrationBackupPath :: Maybe FilePath,
@@ -240,6 +241,46 @@ coreChatOptsP appDir defaultDbName = do
( long "relay"
<> help "Run as a chat relay client"
)
webPreviewConfig <- do
webDomain_ <-
optional $
strOption
( long "relay-web-domain"
<> metavar "DOMAIN"
<> help "Domain for channel web previews (relay only)"
)
webJsonDir_ <-
optional $
strOption
( long "relay-web-dir"
<> metavar "DIR"
<> help "Directory for channel web preview JSON files (relay only)"
)
webCorsFile <-
optional $
strOption
( long "relay-web-cors-file"
<> metavar "FILE"
<> help "Path to generated Caddy CORS config file (relay only)"
)
webUpdateInterval <-
option auto
( long "relay-web-interval"
<> metavar "SECONDS"
<> help "Interval between web preview regeneration in seconds (relay only)"
<> value 300
)
webPreviewItemCount <-
option auto
( long "relay-web-item-count"
<> metavar "COUNT"
<> help "Number of recent messages in channel web preview (relay only)"
<> value 50
)
pure $ case (webDomain_, webJsonDir_) of
(Just webDomain, Just webJsonDir) -> Just WebPreviewConfig {webDomain, webJsonDir, webCorsFile, webUpdateInterval, webPreviewItemCount}
(Nothing, Nothing) -> Nothing
_ -> errorWithoutStackTrace "--relay-web-domain and --relay-web-dir must both be provided"
highlyAvailable <-
switch
( long "ha"
@@ -283,6 +324,7 @@ coreChatOptsP appDir defaultDbName = do
tbqSize,
deviceName,
chatRelay,
webPreviewConfig,
highlyAvailable,
yesToUpMigrations,
migrationBackupPath,
src/Simplex/Chat/ProfileGenerator.hs
+1 -1
View File
@@ -10,7 +10,7 @@ generateRandomProfile :: IO Profile
generateRandomProfile = do
adjective <- pick adjectives
noun <- pickNoun adjective 2
pure $ Profile {displayName = adjective <> noun, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Nothing, peerType = Nothing, preferences = Nothing}
pure $ Profile {displayName = adjective <> noun, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing, badge = Nothing, simplexName = Nothing}
where
pick :: [a] -> IO a
pick xs = (xs !!) <$> randomRIO (0, length xs - 1)
src/Simplex/Chat/Protocol.hs
+105 -14
View File
@@ -48,12 +48,14 @@ import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Data.Word (Word16, Word32)
import Simplex.Chat.Badges (LocalBadge)
import Simplex.Chat.Call
import Simplex.Chat.Options.DB (FromField (..), ToField (..))
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import qualified Simplex.FileTransfer.Description as FD
import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion)
import Simplex.Messaging.Agent.Store.DB (blobFieldDecoder, fromTextField_)
import Simplex.Messaging.Compression (Compressed, compress1, decompress1, decompressedSize)
@@ -82,12 +84,14 @@ import Simplex.Messaging.Version hiding (version)
-- 15 - support specifying message scopes for group messages (2025-03-12)
-- 16 - support short link data (2025-06-10)
-- 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)
-- 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 17
currentChatVersion = VersionChat 19
-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
supportedChatVRange :: VersionRangeChat
@@ -154,6 +158,15 @@ shortLinkDataVersion = VersionChat 16
memberSupportVoiceVersion :: VersionChat
memberSupportVoiceVersion = VersionChat 17
-- relay sends web preview capabilities to owner
relayWebCapVersion :: VersionChat
relayWebCapVersion = VersionChat 18
-- owner-signed roster (promoted members/moderators/admins) and the relay roster-ack handshake;
-- a relay below this version is published without the handshake (it can't ack a roster)
groupRosterVersion :: VersionChat
groupRosterVersion = VersionChat 19
agentToChatVersion :: VersionSMPA -> VersionChat
agentToChatVersion v
| v < pqdrSMPAgentVersion = initialChatVersion
@@ -367,6 +380,36 @@ data GrpMsgForward = GrpMsgForward
}
deriving (Eq, Show)
-- | Owner-signed roster header for the privileged (moderator/admin/member) set; owners
-- are not included, their keys come from the link. The member list itself is not
-- here: it is sent as a binary blob over the inline file transfer, and this header
-- carries only its inline-file invitation (size + owner-attested digest).
data GroupRoster = GroupRoster
{ version :: VersionRoster,
fileInv :: InlineFileInvitation
}
deriving (Eq, Show)
-- | Lean always-inline file invitation for the roster blob, carried in the signed
-- header. The digest authenticates the unsigned blob; integrity is entirely the digest.
data InlineFileInvitation = InlineFileInvitation
{ fileSize :: Integer,
fileDigest :: FD.FileDigest
}
deriving (Eq, Show)
data RosterMember = RosterMember
{ memberId :: MemberId,
key :: MemberKey, -- trust-on-first-use pinned per memberId
role :: GroupMemberRole,
privileges :: Word16 -- reserved: serialized as 0, parsed and ignored in v1
}
deriving (Eq, Show)
-- RosterMember is binary-only: it rides in the roster blob, never in a JSON message.
instance Encoding RosterMember where
smpEncode RosterMember {memberId, key, role, privileges} = smpEncode (memberId, key, role, privileges)
smpP = RosterMember <$> smpP <*> smpP <*> smpP <*> smpP
instance Encoding FwdSender where
smpEncode = \case
@@ -433,6 +476,11 @@ data MsgSigning = MsgSigning
encodeChatBinding :: ChatBinding -> ByteString -> ByteString
encodeChatBinding cb bindingData = smpEncode cb <> bindingData
signChatMsgBody :: MsgSigning -> ByteString -> SignedMsg
signChatMsgBody MsgSigning {bindingTag, bindingData, keyRef, privKey} msgBody =
let sig = C.ASignature C.SEd25519 $ C.sign' privKey (encodeChatBinding bindingTag bindingData <> msgBody)
in SignedMsg {chatBinding = bindingTag, signatures = MsgSignature keyRef sig L.:| [], signedBody = msgBody}
data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
@@ -446,7 +494,7 @@ data ChatMsgEvent (e :: MsgEncoding) where
XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
XInfo :: Profile -> ChatMsgEvent 'Json
XContact :: {profile :: Profile, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json
XMember :: {profile :: Profile, newMemberId :: MemberId, newMemberKey :: MemberKey} -> 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
@@ -465,16 +513,18 @@ data ChatMsgEvent (e :: MsgEncoding) where
XGrpMemInv :: MemberId -> IntroInvitation -> ChatMsgEvent 'Json
XGrpMemFwd :: MemberInfo -> IntroInvitation -> ChatMsgEvent 'Json
XGrpMemInfo :: MemberId -> Profile -> ChatMsgEvent 'Json
XGrpMemRole :: MemberId -> GroupMemberRole -> ChatMsgEvent 'Json
XGrpMemRole :: MemberId -> GroupMemberRole -> Maybe MemberKey -> Maybe VersionRoster -> ChatMsgEvent 'Json
XGrpMemRestrict :: MemberId -> MemberRestrictions -> ChatMsgEvent 'Json
XGrpMemCon :: MemberId -> ChatMsgEvent 'Json
XGrpMemConAll :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
XGrpMemDel :: MemberId -> Bool -> ChatMsgEvent 'Json
XGrpMemDel :: MemberId -> Bool -> Maybe VersionRoster -> ChatMsgEvent 'Json
XGrpLeave :: ChatMsgEvent 'Json
XGrpDel :: ChatMsgEvent 'Json
XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json
XGrpPrefs :: GroupPreferences -> ChatMsgEvent 'Json
XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> Maybe MsgScope -> ChatMsgEvent 'Json
XGrpRoster :: GroupRoster -> ChatMsgEvent 'Json
XGrpRosterAck :: VersionRoster -> Maybe Text -> ChatMsgEvent 'Json
XGrpMsgForward :: GrpMsgForward -> ChatMessage 'Json -> ChatMsgEvent 'Json
XInfoProbe :: Probe -> ChatMsgEvent 'Json
XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json
@@ -518,6 +568,7 @@ isForwardedGroupMsg ev = case ev of
XGrpDel -> True
XGrpInfo _ -> True
XGrpPrefs _ -> True
XGrpRoster _ -> True
_ -> False
data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object}
@@ -786,6 +837,8 @@ data MsgMention = MsgMention {memberId :: MemberId}
newtype MsgMentions = MsgMentions (Map MemberName MsgMention)
deriving (Eq, Show)
$(JQ.deriveJSON defaultJSON ''InlineFileInvitation)
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MCL") ''MsgChatLink)
$(JQ.deriveJSON defaultJSON ''LinkOwnerSig)
@@ -886,6 +939,28 @@ maxCompressedMsgLength = 13380
maxDecompressedMsgLength :: Int
maxDecompressedMsgLength = 65536
-- Defensive entry-count bound for the roster blob parser (rosterBlobP) and the
-- promotion cap over the promoted (member/moderator/admin) set.
maxGroupRosterSize :: Int
maxGroupRosterSize = 256
-- Receive-side byte bound: reject an owner-signed header whose claimed fileSize exceeds what
-- maxGroupRosterSize entries can occupy (128 B/entry is a generous worst case), before a file is created.
-- 128 B/entry ~ memberId + X.509 Ed25519 key (44 B) + role + privileges + 1-byte length prefixes (~2x the ~65 B typical).
maxGroupRosterBytes :: Integer
maxGroupRosterBytes = fromIntegral maxGroupRosterSize * 128
-- The byte sequence the owner-signed digest is computed over and verified against
-- before parsing. Word16 count (smpEncodeList's 1-byte count is too small for the future cap).
encodeRosterBlob :: [RosterMember] -> ByteString
encodeRosterBlob ms = smpEncode (fromIntegral (length ms) :: Word16) <> B.concat (map smpEncode ms)
rosterBlobP :: A.Parser [RosterMember]
rosterBlobP = do
n <- fromIntegral <$> smpP @Word16
when (n > maxGroupRosterSize) $ fail "roster: too many entries"
A.count n smpP
-- maxEncodedMsgLength - delta between MSG and INFO + 100 (returned for forward overhead)
-- delta between MSG and INFO = e2eEncUserMsgLength (no PQ) - e2eEncConnInfoLength (no PQ) = 1008
maxEncodedInfoLength :: Int
@@ -931,7 +1006,7 @@ parseChatMessages msg = case B.head msg of
Right (compressed :: L.NonEmpty Compressed) -> case traverse decompressedSize compressed of
Nothing -> [Left "compressed size not specified"]
Just sizes
| sum sizes > maxDecompressedMsgLength -> [Left "decompressed size exceeds limit"]
| any (maxDecompressedMsgLength <) sizes || maxDecompressedMsgLength < sum sizes -> [Left "decompressed size exceeds limit"]
| otherwise -> concatMap (either (\e -> [Left e]) parseUncompressed' . decompress1) compressed
parseUncompressed' "" = [Left "empty string"]
parseUncompressed' s = parseUncompressed (B.head s) s
@@ -1022,6 +1097,8 @@ data CMEventTag (e :: MsgEncoding) where
XGrpInfo_ :: CMEventTag 'Json
XGrpPrefs_ :: CMEventTag 'Json
XGrpDirectInv_ :: CMEventTag 'Json
XGrpRoster_ :: CMEventTag 'Json
XGrpRosterAck_ :: CMEventTag 'Json
XGrpMsgForward_ :: CMEventTag 'Json
XInfoProbe_ :: CMEventTag 'Json
XInfoProbeCheck_ :: CMEventTag 'Json
@@ -1082,6 +1159,8 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where
XGrpInfo_ -> "x.grp.info"
XGrpPrefs_ -> "x.grp.prefs"
XGrpDirectInv_ -> "x.grp.direct.inv"
XGrpRoster_ -> "x.grp.roster"
XGrpRosterAck_ -> "x.grp.roster.ack"
XGrpMsgForward_ -> "x.grp.msg.forward"
XInfoProbe_ -> "x.info.probe"
XInfoProbeCheck_ -> "x.info.probe.check"
@@ -1143,6 +1222,8 @@ instance StrEncoding ACMEventTag where
"x.grp.info" -> XGrpInfo_
"x.grp.prefs" -> XGrpPrefs_
"x.grp.direct.inv" -> XGrpDirectInv_
"x.grp.roster" -> XGrpRoster_
"x.grp.roster.ack" -> XGrpRosterAck_
"x.grp.msg.forward" -> XGrpMsgForward_
"x.info.probe" -> XInfoProbe_
"x.info.probe.check" -> XInfoProbeCheck_
@@ -1190,7 +1271,7 @@ toCMEventTag msg = case msg of
XGrpMemInv _ _ -> XGrpMemInv_
XGrpMemFwd _ _ -> XGrpMemFwd_
XGrpMemInfo _ _ -> XGrpMemInfo_
XGrpMemRole _ _ -> XGrpMemRole_
XGrpMemRole {} -> XGrpMemRole_
XGrpMemRestrict _ _ -> XGrpMemRestrict_
XGrpMemCon _ -> XGrpMemCon_
XGrpMemConAll _ -> XGrpMemConAll_
@@ -1200,6 +1281,8 @@ toCMEventTag msg = case msg of
XGrpInfo _ -> XGrpInfo_
XGrpPrefs _ -> XGrpPrefs_
XGrpDirectInv {} -> XGrpDirectInv_
XGrpRoster _ -> XGrpRoster_
XGrpRosterAck {} -> XGrpRosterAck_
XGrpMsgForward {} -> XGrpMsgForward_
XInfoProbe _ -> XInfoProbe_
XInfoProbeCheck _ -> XInfoProbeCheck_
@@ -1258,6 +1341,7 @@ requiresSignature = \case
XGrpMemRestrict_ -> True
XGrpLeave_ -> True
XGrpRelayNew_ -> True
XGrpRoster_ -> True
XInfo_ -> True
_ -> False
@@ -1326,7 +1410,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
reqContent <- opt "content"
let requestMsg = (,) <$> reqMsgId <*> reqContent
pure XContact {profile, contactReqId, welcomeMsgId, requestMsg}
XMember_ -> XMember <$> p "profile" <*> p "newMemberId" <*> p "newMemberKey"
XMember_ -> XMember <$> p "profile" <*> p "newMemberId" <*> p "newMemberKey" <*> opt "viaRelay"
XDirectDel_ -> pure XDirectDel
XGrpInv_ -> XGrpInv <$> p "groupInvitation"
XGrpAcpt_ -> XGrpAcpt <$> p "memberId"
@@ -1348,16 +1432,18 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro"
XGrpMemFwd_ -> XGrpMemFwd <$> p "memberInfo" <*> p "memberIntro"
XGrpMemInfo_ -> XGrpMemInfo <$> p "memberId" <*> p "profile"
XGrpMemRole_ -> XGrpMemRole <$> p "memberId" <*> p "role"
XGrpMemRole_ -> XGrpMemRole <$> p "memberId" <*> p "role" <*> opt "memberKey" <*> opt "rosterVersion"
XGrpMemRestrict_ -> XGrpMemRestrict <$> p "memberId" <*> p "memberRestrictions"
XGrpMemCon_ -> XGrpMemCon <$> p "memberId"
XGrpMemConAll_ -> XGrpMemConAll <$> p "memberId"
XGrpMemDel_ -> XGrpMemDel <$> p "memberId" <*> Right (fromRight False $ p "messages")
XGrpMemDel_ -> XGrpMemDel <$> p "memberId" <*> Right (fromRight False $ p "messages") <*> opt "rosterVersion"
XGrpLeave_ -> pure XGrpLeave
XGrpDel_ -> pure XGrpDel
XGrpInfo_ -> XGrpInfo <$> p "groupProfile"
XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences"
XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope"
XGrpRoster_ -> XGrpRoster <$> (GroupRoster <$> p "version" <*> p "fileInv")
XGrpRosterAck_ -> XGrpRosterAck <$> p "version" <*> opt "error"
XGrpMsgForward_ -> do
fwdSender <- opt "memberId" >>= \case
Just memberId -> FwdMember memberId . fromMaybe "" <$> opt "memberName"
@@ -1399,7 +1485,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
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]
XMember {profile, newMemberId, newMemberKey} -> o ["profile" .= profile, "newMemberId" .= newMemberId, "newMemberKey" .= newMemberKey]
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]
@@ -1420,16 +1506,18 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro]
XGrpMemFwd memInfo memIntro -> o ["memberInfo" .= memInfo, "memberIntro" .= memIntro]
XGrpMemInfo memId profile -> o ["memberId" .= memId, "profile" .= profile]
XGrpMemRole memId role -> o ["memberId" .= memId, "role" .= role]
XGrpMemRole memId role memberKey rosterVersion -> o $ ("memberKey" .=? memberKey) $ ("rosterVersion" .=? rosterVersion) ["memberId" .= memId, "role" .= role]
XGrpMemRestrict memId memRestrictions -> o ["memberId" .= memId, "memberRestrictions" .= memRestrictions]
XGrpMemCon memId -> o ["memberId" .= memId]
XGrpMemConAll memId -> o ["memberId" .= memId]
XGrpMemDel memId messages -> o $ ("messages" .=? if messages then Just True else Nothing) ["memberId" .= memId]
XGrpMemDel memId messages rosterVersion -> o $ ("rosterVersion" .=? rosterVersion) $ ("messages" .=? if messages then Just True else Nothing) ["memberId" .= memId]
XGrpLeave -> JM.empty
XGrpDel -> JM.empty
XGrpInfo p -> o ["groupProfile" .= p]
XGrpPrefs p -> o ["groupPreferences" .= p]
XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq]
XGrpRoster GroupRoster {version, fileInv} -> o ["version" .= version, "fileInv" .= fileInv]
XGrpRosterAck version err -> o $ ("error" .=? err) ["version" .= version]
XGrpMsgForward GrpMsgForward {fwdSender, fwdBrokerTs} msg -> o $ encodeFwdSender fwdSender ["msg" .= msg, "msgTs" .= fwdBrokerTs]
where
encodeFwdSender = \case
@@ -1481,7 +1569,10 @@ instance FromField (ChatMessage 'Json) where
data ContactShortLinkData = ContactShortLinkData
{ profile :: Profile,
message :: Maybe MsgContent,
business :: Bool
business :: Bool,
-- set by the receiving client for the UI: the link profile's badge, verified and crypto-free.
-- never part of the published link data (the link carries the proof inside profile).
localBadge :: Maybe LocalBadge
}
deriving (Show)
src/Simplex/Chat/Store/Connections.hs
+21 -14
View File
@@ -29,7 +29,8 @@ import Control.Monad.IO.Class
import Data.Bitraversable (bitraverse)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock (UTCTime, getCurrentTime)
import Simplex.Chat.Badges (rowToBadge)
import Simplex.Chat.Protocol
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Groups
@@ -104,8 +105,9 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
(userId, agentConnId, ConnDeleted)
getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact
getContactRec_ contactId c = ExceptT $ do
currentTs <- getCurrentTime
chatTags <- getDirectChatTags db contactId
firstRow (toContact' contactId c chatTags) (SEInternalError "referenced contact not found") $
firstRow (toContact' currentTs contactId c chatTags) (SEInternalError "referenced contact not found") $
DB.query
db
[sql|
@@ -113,16 +115,18 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, c.contact_used, c.contact_status, c.enable_ntfs, c.send_rcpts, c.favorite,
p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts, c.conn_full_link_to_connect, c.conn_short_link_to_connect, c.welcome_shared_msg_id, c.request_shared_msg_id, c.contact_request_id,
c.contact_group_member_id, c.contact_grp_inv_sent, c.grp_direct_inv_link, c.grp_direct_inv_from_group_id, c.grp_direct_inv_from_group_member_id, c.grp_direct_inv_from_member_conn_id, c.grp_direct_inv_started_connection,
c.ui_themes, c.chat_deleted, c.custom_data, c.chat_item_ttl, c.simplex_name, p.simplex_name, c.simplex_name_verified_at
c.ui_themes, c.chat_deleted, c.custom_data, c.chat_item_ttl,
p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx,
c.simplex_name, p.simplex_name, c.simplex_name_verified_at
FROM contacts c
JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id
WHERE c.user_id = ? AND c.contact_id = ? AND c.contact_status = ? AND c.deleted = 0
|]
(userId, contactId, CSActive)
toContact' :: Int64 -> Connection -> [ChatTagId] -> ContactRow' -> Contact
toContact' contactId conn chatTags ((profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL, ctSimplexNameRaw, cpSimplexNameRaw, simplexNameVerifiedAt)) =
toContact' :: UTCTime -> Int64 -> Connection -> [ChatTagId] -> ContactRow' -> Contact
toContact' currentTs contactId conn chatTags ((profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow :. (ctSimplexNameRaw, cpSimplexNameRaw, simplexNameVerifiedAt)) =
let simplexName = decodeSimplexName ctSimplexNameRaw
profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName cpSimplexNameRaw, peerType, preferences, localAlias}
profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName cpSimplexNameRaw, peerType, localBadge = rowToBadge currentTs badgeRow, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn
activeConn = Just conn
@@ -131,9 +135,10 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
in Contact {contactId, localDisplayName, profile, activeConn, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, preparedContact, contactRequestId, contactGroupMemberId, contactGrpInvSent, groupDirectInv, chatTags, chatItemTTL, uiThemes, chatDeleted, customData, simplexName, simplexNameVerifiedAt}
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember_ groupMemberId c = do
currentTs <- liftIO getCurrentTime
gm <-
ExceptT $
firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $
firstRow (toGroupAndMember currentTs c) (SEInternalError "referenced group member not found") $
-- Mirrors Store/Shared.hs groupInfoQueryFields — keep column lists in sync.
DB.query
db
@@ -147,19 +152,21 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
g.conn_full_link_to_connect, g.conn_short_link_to_connect, g.conn_link_prepared_connection, g.conn_link_started_connection, g.welcome_shared_msg_id, g.request_shared_msg_id,
g.business_chat, g.business_member_id, g.customer_member_id,
g.use_relays, g.relay_own_status,
g.ui_themes, g.summary_current_members_count, g.public_member_count, g.custom_data, g.chat_item_ttl, g.members_require_attention, g.via_group_link_uri,
g.ui_themes, g.summary_current_members_count, g.public_member_count, g.roster_version, g.custom_data, g.chat_item_ttl, g.members_require_attention, g.via_group_link_uri,
g.root_priv_key, g.root_pub_key, g.member_priv_key,
g.simplex_name, gp.simplex_name, g.simplex_name_verified_at,
-- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.index_in_group, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
-- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.short_descr, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences, pu.simplex_name,
pu.display_name, pu.full_name, pu.short_descr, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences,
pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, pu.badge_key_idx, pu.simplex_name,
mu.created_at, mu.updated_at,
mu.support_chat_ts, mu.support_chat_items_unread, mu.support_chat_items_member_attention, mu.support_chat_items_mentions, mu.support_chat_last_msg_from_member_ts, mu.member_pub_key, mu.relay_link,
-- from GroupMember
m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction,
m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, p.simplex_name,
m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences,
p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.simplex_name,
m.created_at, m.updated_at,
m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link
FROM group_members m
@@ -173,10 +180,10 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
|]
(groupMemberId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
liftIO $ bitraverse (addGroupChatTags db) pure gm
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
toGroupAndMember c (groupInfoRow :. memberRow) =
let groupInfo = toGroupInfo cxt userContactId [] groupInfoRow
member = toGroupMember userContactId memberRow
toGroupAndMember :: UTCTime -> Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
toGroupAndMember currentTs c (groupInfoRow :. memberRow) =
let groupInfo = toGroupInfo currentTs cxt userContactId [] groupInfoRow
member = toGroupMember currentTs userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = Just c})
getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact
getUserContact_ userContactLinkId = ExceptT $ do
src/Simplex/Chat/Store/ContactRequest.hs
+31 -14
View File
@@ -24,6 +24,7 @@ import Control.Monad.IO.Class
import Crypto.Random (ChaChaDRG)
import Data.Int (Int64)
import Data.Time.Clock (getCurrentTime)
import Simplex.Chat.Badges (badgeToRow, verifyBadge_)
import Simplex.Chat.Protocol (MsgContent, businessChatsVersion)
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Groups
@@ -72,7 +73,7 @@ createOrUpdateContactRequest
isSimplexTeam
invId
cReqChatVRange@(VersionRange minV maxV)
profile@Profile {displayName, fullName, shortDescr, image, contactLink, preferences}
profile@Profile {displayName, fullName, shortDescr, image, contactLink, badge, preferences}
xContactId_
welcomeMsgId_
requestMsg_
@@ -103,8 +104,9 @@ createOrUpdateContactRequest
where
getAcceptedContact :: XContactId -> IO (Maybe Contact)
getAcceptedContact xContactId = do
currentTs <- getCurrentTime
ct_ <-
maybeFirstRow (toContact cxt user []) $
maybeFirstRow (toContact currentTs cxt user []) $
DB.query
db
[sql|
@@ -113,7 +115,8 @@ createOrUpdateContactRequest
ct.contact_id, ct.contact_profile_id, ct.local_display_name, cp.display_name, cp.full_name, cp.short_descr, cp.image, cp.contact_link, cp.chat_peer_type, cp.local_alias, ct.contact_used, ct.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.conn_full_link_to_connect, ct.conn_short_link_to_connect, ct.welcome_shared_msg_id, ct.request_shared_msg_id, ct.contact_request_id,
ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl, ct.simplex_name, cp.simplex_name, ct.simplex_name_verified_at,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl,
cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx, ct.simplex_name, cp.simplex_name, ct.simplex_name_verified_at,
-- Connection
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, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
@@ -127,26 +130,29 @@ createOrUpdateContactRequest
mapM (addDirectChatTags db) ct_
getAcceptedBusinessChat :: XContactId -> IO (Maybe GroupInfo)
getAcceptedBusinessChat xContactId = do
currentTs <- getCurrentTime
g_ <-
maybeFirstRow (toGroupInfo cxt userContactId []) $
maybeFirstRow (toGroupInfo currentTs cxt userContactId []) $
DB.query
db
(groupInfoQuery <> " WHERE g.business_xcontact_id = ? AND g.user_id = ? AND mu.contact_id = ?")
(xContactId, userId, userContactId)
mapM (addGroupChatTags db) g_
getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest)
getContactRequestByXContactId xContactId =
maybeFirstRow toContactRequest $
getContactRequestByXContactId xContactId = do
currentTs <- getCurrentTime
maybeFirstRow (toContactRequest currentTs) $
DB.query
db
[sql|
SELECT
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id,
cr.contact_id, cr.business_group_id, cr.user_contact_link_id,
cr.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.simplex_name, cr.xcontact_id,
cr.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, cr.xcontact_id,
cr.pq_support, cr.welcome_shared_msg_id, cr.request_shared_msg_id, p.preferences,
cr.created_at, cr.updated_at,
cr.peer_chat_min_version, cr.peer_chat_max_version
cr.peer_chat_min_version, cr.peer_chat_max_version,
p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.simplex_name
FROM contact_requests cr
JOIN contact_profiles p USING (contact_profile_id)
WHERE cr.user_id = ?
@@ -157,12 +163,13 @@ createOrUpdateContactRequest
createContactRequest :: ExceptT StoreError IO RequestStage
createContactRequest = do
currentTs <- liftIO $ getCurrentTime
badgeVerified <- liftIO $ verifyBadge_ (badgeKeys cxt) badge
ExceptT $ withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
liftIO $
DB.execute
db
"INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(displayName, fullName, shortDescr, image, contactLink, userId, preferences, currentTs, currentTs)
"INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, local_alias, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature, badge_key_idx) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
((displayName, fullName, shortDescr, image, contactLink, userId) :. ("" :: LocalAlias, preferences, currentTs, currentTs) :. badgeToRow badge badgeVerified)
profileId <- liftIO $ insertedRowId db
liftIO $
DB.execute
@@ -214,7 +221,7 @@ createOrUpdateContactRequest
ucr <- getContactRequest db user contactRequestId
pure $ RSCurrentRequest Nothing ucr (Just $ REBusinessChat gInfo clientMember)
updateContactRequest :: UserContactRequest -> ExceptT StoreError IO RequestStage
updateContactRequest ucr@UserContactRequest {contactRequestId, contactId_, localDisplayName = oldLdn, profile = Profile {displayName = oldDisplayName}} = do
updateContactRequest ucr@UserContactRequest {contactRequestId, contactId_, localDisplayName = oldLdn, profile = LocalProfile {displayName = oldDisplayName}} = do
currentTs <- liftIO getCurrentTime
liftIO $ updateProfile currentTs
updateRequest currentTs
@@ -222,7 +229,8 @@ createOrUpdateContactRequest
re_ <- getRequestEntity ucr'
pure $ RSCurrentRequest (Just ucr) ucr' re_
where
updateProfile currentTs =
updateProfile currentTs = do
badgeVerified <- liftIO $ verifyBadge_ (badgeKeys cxt) badge
DB.execute
db
[sql|
@@ -232,7 +240,16 @@ createOrUpdateContactRequest
short_descr = ?,
image = ?,
contact_link = ?,
updated_at = ?
updated_at = ?,
badge_proof = ?,
badge_pres_header = ?,
badge_expiry = ?,
badge_type = ?,
badge_verified = ?,
badge_extra = ?,
badge_master_key = ?,
badge_signature = ?,
badge_key_idx = ?
WHERE contact_profile_id IN (
SELECT contact_profile_id
FROM contact_requests
@@ -240,7 +257,7 @@ createOrUpdateContactRequest
AND contact_request_id = ?
)
|]
(displayName, fullName, shortDescr, image, contactLink, currentTs, userId, contactRequestId)
((displayName, fullName, shortDescr, image, contactLink, currentTs) :. badgeToRow badge badgeVerified :. (userId, contactRequestId))
updateRequest currentTs =
if displayName == oldDisplayName
then
src/Simplex/Chat/Store/Delivery.hs
+2 -1
View File
@@ -367,7 +367,8 @@ getGroupMembersByCursor db cxt user@User {userContactId} GroupInfo {groupId} cur
:. (cursorGMId, count)
)
#if defined(dbPostgres)
map (toContactMember cxt user) <$>
currentTs <- getCurrentTime
map (toContactMember currentTs cxt user) <$>
DB.query
db
(groupMemberQuery <> " WHERE m.group_member_id IN ? ORDER BY m.group_member_id ASC")
src/Simplex/Chat/Store/Direct.hs
+78 -56
View File
@@ -109,6 +109,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Data.Type.Equality
import Simplex.Chat.Badges (badgeToRow)
import Simplex.Chat.Messages
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
@@ -312,8 +313,9 @@ getConnReqContactXContactId db cxt user@User {userId} cReqHash1 cReqHash2 =
getContactByConnReqHash :: DB.Connection -> StoreCxt -> User -> ConnReqUriHash -> ConnReqUriHash -> IO (Maybe Contact)
getContactByConnReqHash db cxt user@User {userId} cReqHash1 cReqHash2 = do
currentTs <- getCurrentTime
ct <-
maybeFirstRow (toContact cxt user []) $
maybeFirstRow (toContact currentTs cxt user []) $
DB.query
db
[sql|
@@ -322,7 +324,9 @@ getContactByConnReqHash db cxt user@User {userId} cReqHash1 cReqHash2 = do
ct.contact_id, ct.contact_profile_id, ct.local_display_name, cp.display_name, cp.full_name, cp.short_descr, cp.image, cp.contact_link, cp.chat_peer_type, cp.local_alias, ct.contact_used, ct.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.conn_full_link_to_connect, ct.conn_short_link_to_connect, ct.welcome_shared_msg_id, ct.request_shared_msg_id, ct.contact_request_id,
ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl, ct.simplex_name, cp.simplex_name, ct.simplex_name_verified_at,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl,
cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx,
ct.simplex_name, cp.simplex_name, ct.simplex_name_verified_at,
-- Connection
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, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
@@ -405,7 +409,7 @@ createPreparedContact db cxt user p connLinkToConnect welcomeSharedMsgId simplex
currentTs <- liftIO getCurrentTime
let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
ctUserPreferences = newContactUserPrefs user p
contactId <- createContact_ db user p ctUserPreferences prepared "" currentTs simplexName
contactId <- createContact_ db cxt user p ctUserPreferences prepared "" currentTs simplexName
getContact db cxt user contactId
updatePreparedContactUser :: DB.Connection -> StoreCxt -> User -> Contact -> User -> ExceptT StoreError IO Contact
@@ -450,7 +454,7 @@ createDirectContact :: DB.Connection -> StoreCxt -> User -> Connection -> Profil
createDirectContact db cxt user Connection {connId, localAlias} p simplexName = do
currentTs <- liftIO getCurrentTime
let ctUserPreferences = newContactUserPrefs user p
contactId <- createContact_ db user p ctUserPreferences Nothing localAlias currentTs simplexName
contactId <- createContact_ db cxt user p ctUserPreferences Nothing localAlias currentTs simplexName
liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId)
getContact db cxt user contactId
@@ -566,31 +570,34 @@ deleteUnusedProfile_ db userId profileId =
-- Also clears contacts.simplex_name_verified_at when the peer's simplex_name
-- claim changes (any value transition, including Nothing<->Just): the prior
-- verification was tied to the prior claim and must be re-issued by the user.
updateContactProfile :: DB.Connection -> User -> Contact -> Profile -> ExceptT StoreError IO Contact
updateContactProfile db user@User {userId} c p'
| displayName == newName = do
liftIO $ clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
liftIO $ updateContactProfile_ db userId profileId p'
liftIO clearVerifiedAtIfClaimChanged
pure $ c' {profile, mergedPreferences}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
updateContactProfile_' db userId profileId p' currentTs
updateContactLDN_ db user contactId localDisplayName ldn currentTs
clearVerifiedAtIfClaimChanged
pure $ Right c' {localDisplayName = ldn, profile, mergedPreferences}
updateContactProfile :: DB.Connection -> StoreCxt -> User -> Contact -> Profile -> ExceptT StoreError IO Contact
updateContactProfile db cxt user@User {userId} c p' = do
currentTs <- liftIO getCurrentTime
badgeVerified <- liftIO $ profileBadgeVerified (badgeKeys cxt) lp p'
let profile = toLocalProfile profileId p' localAlias currentTs badgeVerified
updateContactProfile' currentTs badgeVerified profile
where
Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias, simplexName = prevClaim}, userPreferences} = c
Contact {contactId, localDisplayName, profile = lp@LocalProfile {profileId, displayName, localAlias, simplexName = prevClaim}, userPreferences} = c
Profile {displayName = newName, simplexName = profileSimplexName, preferences} = p'
profile = toLocalProfile profileId p' localAlias
mergedPreferences = contactUserPreferences user userPreferences preferences $ contactConnIncognito c
claimChanged = prevClaim /= profileSimplexName
c' = if claimChanged then (c :: Contact) {simplexNameVerifiedAt = Nothing} else c
clearVerifiedAtIfClaimChanged =
when claimChanged $
DB.execute db "UPDATE contacts SET simplex_name_verified_at = NULL WHERE user_id = ? AND contact_id = ?" (userId, contactId)
updateContactProfile' currentTs badgeVerified profile
| displayName == newName = do
liftIO $ clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
liftIO $ updateContactProfile_' db userId profileId p' badgeVerified currentTs
liftIO clearVerifiedAtIfClaimChanged
pure c' {profile, mergedPreferences}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
updateContactProfile_' db userId profileId p' badgeVerified currentTs
updateContactLDN_ db user contactId localDisplayName ldn currentTs
clearVerifiedAtIfClaimChanged
pure $ Right c' {localDisplayName = ldn, profile, mergedPreferences}
-- | Records that the user successfully RSLV-verified the peer's simplex_name
-- claim against the contact's stored connection link. Cleared back to NULL by
@@ -727,55 +734,61 @@ setQuotaErrCounter db User {userId} Connection {connId} counter = do
updatedAt <- getCurrentTime
DB.execute db "UPDATE connections SET quota_err_counter = ?, updated_at = ? WHERE user_id = ? AND connection_id = ?" (counter, updatedAt, userId, connId)
updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO ()
updateContactProfile_ db userId profileId profile = do
updateContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> IO ()
updateContactProfile_ db userId profileId profile badgeVerified = do
currentTs <- getCurrentTime
updateContactProfile_' db userId profileId profile currentTs
updateContactProfile_' db userId profileId profile badgeVerified currentTs
updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
updateContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, image, contactLink, simplexName, preferences, peerType} updatedAt = do
updateContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO ()
updateContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, image, contactLink, simplexName, preferences, peerType, badge} badgeVerified updatedAt =
DB.execute
db
[sql|
UPDATE contact_profiles
SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = ?, simplex_name = ?, preferences = ?, chat_peer_type = ?, updated_at = ?
SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = ?, preferences = ?, chat_peer_type = ?, updated_at = ?,
badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?,
simplex_name = ?
WHERE user_id = ? AND contact_profile_id = ?
|]
((displayName, fullName, shortDescr, image, contactLink, simplexName, preferences, peerType, updatedAt) :. (userId, profileId))
((displayName, fullName, shortDescr, image, contactLink, preferences, peerType, updatedAt) :. badgeToRow badge badgeVerified :. Only simplexName :. (userId, profileId))
-- update only member profile fields (when member doesn't have associated contact - we can reset contactLink and prefs)
updateMemberContactProfileReset_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO ()
updateMemberContactProfileReset_ db userId profileId profile = do
updateMemberContactProfileReset_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> IO ()
updateMemberContactProfileReset_ db userId profileId profile badgeVerified = do
currentTs <- getCurrentTime
updateMemberContactProfileReset_' db userId profileId profile currentTs
updateMemberContactProfileReset_' db userId profileId profile badgeVerified currentTs
updateMemberContactProfileReset_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
updateMemberContactProfileReset_' db userId profileId Profile {displayName, fullName, shortDescr, image, simplexName} updatedAt = do
updateMemberContactProfileReset_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO ()
updateMemberContactProfileReset_' db userId profileId Profile {displayName, fullName, shortDescr, image, simplexName, badge} badgeVerified updatedAt =
DB.execute
db
[sql|
UPDATE contact_profiles
SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = NULL, simplex_name = ?, preferences = NULL, updated_at = ?
SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = NULL, preferences = NULL, updated_at = ?,
badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?,
simplex_name = ?
WHERE user_id = ? AND contact_profile_id = ?
|]
(displayName, fullName, shortDescr, image, simplexName, updatedAt, userId, profileId)
((displayName, fullName, shortDescr, image, updatedAt) :. badgeToRow badge badgeVerified :. Only simplexName :. (userId, profileId))
-- update only member profile fields (when member has associated contact - we keep contactLink and prefs)
updateMemberContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> IO ()
updateMemberContactProfile_ db userId profileId profile = do
updateMemberContactProfile_ :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> IO ()
updateMemberContactProfile_ db userId profileId profile badgeVerified = do
currentTs <- getCurrentTime
updateMemberContactProfile_' db userId profileId profile currentTs
updateMemberContactProfile_' db userId profileId profile badgeVerified currentTs
updateMemberContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
updateMemberContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, image, simplexName} updatedAt = do
updateMemberContactProfile_' :: DB.Connection -> UserId -> ProfileId -> Profile -> Maybe Bool -> UTCTime -> IO ()
updateMemberContactProfile_' db userId profileId Profile {displayName, fullName, shortDescr, image, simplexName, badge} badgeVerified updatedAt =
DB.execute
db
[sql|
UPDATE contact_profiles
SET display_name = ?, full_name = ?, short_descr = ?, image = ?, simplex_name = ?, updated_at = ?
SET display_name = ?, full_name = ?, short_descr = ?, image = ?, updated_at = ?,
badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?,
simplex_name = ?
WHERE user_id = ? AND contact_profile_id = ?
|]
(displayName, fullName, shortDescr, image, simplexName, updatedAt, userId, profileId)
((displayName, fullName, shortDescr, image, updatedAt) :. badgeToRow badge badgeVerified :. Only simplexName :. (userId, profileId))
updateContactLDN_ :: DB.Connection -> User -> Int64 -> ContactName -> ContactName -> UTCTime -> IO ()
updateContactLDN_ db user@User {userId} contactId displayName newName updatedAt = do
@@ -823,18 +836,21 @@ getUserContactLinkIdByCReq db contactRequestId =
DB.query db "SELECT user_contact_link_id FROM contact_requests WHERE contact_request_id = ?" (Only contactRequestId)
getContactRequest :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO UserContactRequest
getContactRequest db User {userId} contactRequestId =
ExceptT . firstRow toContactRequest (SEContactRequestNotFound contactRequestId) $
getContactRequest db User {userId} contactRequestId = do
currentTs <- liftIO getCurrentTime
ExceptT . firstRow (toContactRequest currentTs) (SEContactRequestNotFound contactRequestId) $
DB.query db (contactRequestQuery <> " WHERE cr.user_id = ? AND cr.contact_request_id = ?") (userId, contactRequestId)
getContactRequest' :: DB.Connection -> User -> Int64 -> IO (Maybe UserContactRequest)
getContactRequest' db User {userId} contactRequestId =
maybeFirstRow toContactRequest $
getContactRequest' db User {userId} contactRequestId = do
currentTs <- getCurrentTime
maybeFirstRow (toContactRequest currentTs) $
DB.query db (contactRequestQuery <> " WHERE cr.user_id = ? AND cr.contact_request_id = ?") (userId, contactRequestId)
getBusinessContactRequest :: DB.Connection -> User -> GroupId -> IO (Maybe UserContactRequest)
getBusinessContactRequest db _user groupId =
maybeFirstRow toContactRequest $
getBusinessContactRequest db _user groupId = do
currentTs <- getCurrentTime
maybeFirstRow (toContactRequest currentTs) $
DB.query db (contactRequestQuery <> " WHERE cr.business_group_id = ?") (Only groupId)
contactRequestQuery :: Query
@@ -843,10 +859,12 @@ contactRequestQuery =
SELECT
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id,
cr.contact_id, cr.business_group_id, cr.user_contact_link_id,
cr.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.simplex_name, cr.xcontact_id,
cr.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, cr.xcontact_id,
cr.pq_support, cr.welcome_shared_msg_id, cr.request_shared_msg_id, p.preferences,
cr.created_at, cr.updated_at,
cr.peer_chat_min_version, cr.peer_chat_max_version
cr.peer_chat_min_version, cr.peer_chat_max_version,
p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx,
p.simplex_name
FROM contact_requests cr
JOIN contact_profiles p USING (contact_profile_id)
|]
@@ -882,7 +900,7 @@ deleteContactRequest db User {userId} contactRequestId = do
(userId, userId, contactRequestId, userId)
DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId)
createContactFromRequest :: DB.Connection -> User -> Maybe Int64 -> ConnId -> VersionChat -> VersionRangeChat -> ContactName -> ProfileId -> Profile -> Maybe XContactId -> Maybe IncognitoProfile -> SubscriptionMode -> PQSupport -> Bool -> IO (Contact, Connection)
createContactFromRequest :: DB.Connection -> User -> Maybe Int64 -> ConnId -> VersionChat -> VersionRangeChat -> ContactName -> ProfileId -> LocalProfile -> Maybe XContactId -> Maybe IncognitoProfile -> SubscriptionMode -> PQSupport -> Bool -> IO (Contact, Connection)
createContactFromRequest db user@User {userId, profile = LocalProfile {preferences}} uclId_ agentConnId connChatVersion cReqChatVRange localDisplayName profileId profile xContactId incognitoProfile subMode pqSup contactUsed = do
currentTs <- getCurrentTime
let userPreferences = fromMaybe emptyChatPrefs $ incognitoProfile >> preferences
@@ -898,7 +916,7 @@ createContactFromRequest db user@User {userId, profile = LocalProfile {preferenc
Contact
{ contactId,
localDisplayName,
profile = toLocalProfile profileId profile "",
profile,
activeConn = Just conn,
contactUsed,
contactStatus = CSActive,
@@ -956,8 +974,9 @@ getContact db cxt user contactId = getContact_ db cxt user contactId False
getContact_ :: DB.Connection -> StoreCxt -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact
getContact_ db cxt user@User {userId} contactId deleted = do
currentTs <- liftIO getCurrentTime
chatTags <- liftIO $ getDirectChatTags db contactId
ExceptT . firstRow (toContact cxt user chatTags) (SEContactNotFound contactId) $
ExceptT . firstRow (toContact currentTs cxt user chatTags) (SEContactNotFound contactId) $
DB.query
db
[sql|
@@ -966,7 +985,9 @@ getContact_ db cxt user@User {userId} contactId deleted = do
ct.contact_id, ct.contact_profile_id, ct.local_display_name, cp.display_name, cp.full_name, cp.short_descr, cp.image, cp.contact_link, cp.chat_peer_type, cp.local_alias, ct.contact_used, ct.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.conn_full_link_to_connect, ct.conn_short_link_to_connect, ct.welcome_shared_msg_id, ct.request_shared_msg_id, ct.contact_request_id,
ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.grp_direct_inv_link, ct.grp_direct_inv_from_group_id, ct.grp_direct_inv_from_group_member_id, ct.grp_direct_inv_from_member_conn_id, ct.grp_direct_inv_started_connection,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl, ct.simplex_name, cp.simplex_name, ct.simplex_name_verified_at,
ct.ui_themes, ct.chat_deleted, ct.custom_data, ct.chat_item_ttl,
cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx,
ct.simplex_name, cp.simplex_name, ct.simplex_name_verified_at,
-- Connection
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, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
@@ -980,8 +1001,9 @@ getContact_ db cxt user@User {userId} contactId deleted = do
(userId, contactId, BI deleted)
getUserByContactRequestId :: DB.Connection -> Int64 -> ExceptT StoreError IO User
getUserByContactRequestId db contactRequestId =
ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $
getUserByContactRequestId db contactRequestId = do
now <- liftIO getCurrentTime
ExceptT . firstRow (toUser now) (SEUserNotFoundByContactRequestId contactRequestId) $
DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId)
getContactConnections :: DB.Connection -> StoreCxt -> UserId -> Contact -> IO [Connection]
src/Simplex/Chat/Store/Files.hs
+123 -13
View File
@@ -31,12 +31,19 @@ module Simplex.Chat.Store.Files
getSharedMsgIdByFileId,
getFileIdBySharedMsgId,
getGroupFileIdBySharedMsgId,
getGroupRcvFileId,
getGroupRosterFileInfo,
deleteGroupRosterFile,
getRosterTransferFile,
deleteRosterTransferFile,
getRcvFileLastChunkNo,
getDirectFileIdBySharedMsgId,
getChatRefByFileId,
lookupChatRefByFileId,
updateSndFileStatus,
createRcvFileTransfer,
createRcvGroupFileTransfer,
createRosterRcvFile,
createRcvStandaloneFileTransfer,
appendRcvFD,
getRcvFileDescrByRcvFileId,
@@ -79,6 +86,7 @@ import Data.Functor ((<&>))
import Data.Int (Int64)
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (addUTCTime)
import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
import Data.Type.Equality
@@ -320,6 +328,64 @@ getGroupFileIdBySharedMsgId db userId groupId sharedMsgId =
|]
(userId, groupId, sharedMsgId)
-- Resolve the in-flight received group inline file for a chunk: read its file_type by shared_msg_id
-- (LIMIT 1 is safe -- all files sharing a shared_msg_id share a type), then look up by type: a roster
-- file is scoped to its source relay (every relay re-serves the owner's same shared_msg_id, so the source
-- disambiguates), a normal file is by shared_msg_id. Nothing => no in-flight transfer (orphaned chunk).
getGroupRcvFileId :: DB.Connection -> UserId -> Int64 -> GroupMemberId -> SharedMsgId -> IO (Maybe Int64)
getGroupRcvFileId db userId groupId fromMemberId sharedMsgId = do
fileType_ <- getFileType
case fileType_ of
Just FTRoster ->
maybeFirstRow fromOnly $
DB.query db (rcvFileIdQ <> " AND r.group_member_id = ?") (userId, groupId, sharedMsgId, FTRoster, fromMemberId)
Just FTNormal ->
maybeFirstRow fromOnly $
DB.query db rcvFileIdQ (userId, groupId, sharedMsgId, FTNormal)
Nothing -> pure Nothing
where
getFileType =
maybeFirstRow fromOnly $
DB.query db "SELECT file_type FROM files WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? LIMIT 1" (userId, groupId, sharedMsgId)
rcvFileIdQ =
[sql|
SELECT f.file_id FROM files f
JOIN rcv_files r ON r.file_id = f.file_id
WHERE f.user_id = ? AND f.group_id = ? AND f.shared_msg_id = ? AND f.file_type = ?
|]
-- The roster scratch file for a transfer (for fs/handle cleanup before deleting the transfer).
-- A transfer owns exactly one file (created together in one transaction), so this is single-valued.
getRosterTransferFile :: DB.Connection -> Int64 -> IO (Maybe (Int64, Maybe FilePath))
getRosterTransferFile db transferId =
maybeFirstRow id $ DB.query db "SELECT file_id, file_path FROM files WHERE roster_transfer_id = ?" (Only transferId)
-- Deletes a transfer's file row; rcv_files and rcv_file_chunks cascade on the FK.
deleteRosterTransferFile :: DB.Connection -> Int64 -> IO ()
deleteRosterTransferFile db transferId =
DB.execute db "DELETE FROM files WHERE roster_transfer_id = ?" (Only transferId)
-- For roster-file cleanup keyed on the group (not a chat item): every matching file_id and its on-disk
-- path, so the caller evicts the handle and removes the file for each — delete-all like deleteGroupRosterFile.
getGroupRosterFileInfo :: DB.Connection -> UserId -> Int64 -> IO [(Int64, Maybe FilePath)]
getGroupRosterFileInfo db userId groupId =
DB.query
db
"SELECT file_id, file_path FROM files WHERE user_id = ? AND group_id = ? AND file_type = ?"
(userId, groupId, FTRoster)
-- Deletes the roster files row; rcv_files and rcv_file_chunks cascade on the FK.
deleteGroupRosterFile :: DB.Connection -> UserId -> Int64 -> IO ()
deleteGroupRosterFile db userId groupId =
DB.execute db "DELETE FROM files WHERE user_id = ? AND group_id = ? AND file_type = ?" (userId, groupId, FTRoster)
-- The highest stored chunk number, or Nothing if no partial chunks exist (used to decide
-- whether an arriving chunk 1 is a re-driven transfer that must reset).
getRcvFileLastChunkNo :: DB.Connection -> RcvFileTransfer -> IO (Maybe Integer)
getRcvFileLastChunkNo db RcvFileTransfer {fileId} =
maybeFirstRow fromOnly $
DB.query db "SELECT chunk_number FROM rcv_file_chunks WHERE file_id = ? ORDER BY chunk_number DESC LIMIT 1" (Only fileId)
getDirectFileIdBySharedMsgId :: DB.Connection -> User -> Contact -> SharedMsgId -> ExceptT StoreError IO Int64
getDirectFileIdBySharedMsgId db User {userId} Contact {contactId} sharedMsgId =
ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
@@ -378,10 +444,10 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
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, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing}
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, fileType = FTNormal, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing}
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> Maybe GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
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, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
@@ -393,15 +459,34 @@ 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, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs)
"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) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, fileType, sharedMsgId_, currentTs, currentTs)
insertedRowId db
liftIO $
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, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = grpMemberId_, cryptoArgs = Nothing}
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, 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.
createRosterRcvFile :: DB.Connection -> UserId -> GroupInfo -> GroupMember -> Int64 -> SharedMsgId -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRosterRcvFile db userId GroupInfo {groupId} src@GroupMember {localDisplayName = senderName} transferId sharedMsgId f@FileInvitation {fileName, fileSize, fileConnReq, fileInline} rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime
let grpMemberId_ = groupMemberId' src
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, roster_transfer_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
((userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, FPSMP, FTRoster) :. (sharedMsgId, transferId, currentTs, currentTs))
insertedRowId db
liftIO $
DB.execute
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}
createRcvStandaloneFileTransfer :: DB.Connection -> UserId -> CryptoFile -> Int64 -> Word32 -> ExceptT StoreError IO Int64
createRcvStandaloneFileTransfer db userId (CryptoFile filePath cfArgs_) fileSize chunkSize = do
@@ -422,7 +507,7 @@ createRcvStandaloneFileTransfer db userId (CryptoFile filePath cfArgs_) fileSize
createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr
createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
when (fileDescrPartNo /= 0) $ throwError SERcvFileInvalidDescrPart
when (fileDescrPartNo /= 0 || not (rcvFileDescrWithinLimits fileDescrPartNo fileDescrText)) $ throwError SERcvFileInvalidDescrPart
fileDescrId <- liftIO $ do
DB.execute
db
@@ -450,8 +535,8 @@ appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileD
fileDescrPartNo = rfdPNo,
fileDescrComplete = rfdComplete
} -> do
when (fileDescrPartNo /= rfdPNo + 1 || rfdComplete) $ throwError SERcvFileInvalidDescrPart
let fileDescrText' = rfdText <> fileDescrText
when (fileDescrPartNo /= rfdPNo + 1 || rfdComplete || not (rcvFileDescrWithinLimits fileDescrPartNo fileDescrText')) $ throwError SERcvFileInvalidDescrPart
liftIO $
DB.execute
db
@@ -463,6 +548,23 @@ appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileD
(fileDescrText', fileDescrPartNo, BI fileDescrComplete, fileDescrId)
pure RcvFileDescr {fileDescrId, fileDescrText = fileDescrText', fileDescrPartNo, fileDescrComplete}
-- Upper bounds sized above the largest legitimate received description; derived from simplexmq's
-- chunk tiers and redundancy, so a change there must revisit them.
-- ~1280 chunks max = maxFileSizeHard (5gb) / largest chunk tier (4mb).
-- ~150 chars per chunk in the description YAML = replicaId 24 + Ed25519 key 64 + SHA-256 digest 44 + chunkNo/colons.
-- Total ~0.18 MB at 1 replica/chunk (~0.42 MB at 3x), under the 1mb text and 1024 part caps.
maxRcvFileDescrParts :: Int
maxRcvFileDescrParts = 1024
maxRcvFileDescrTextLength :: Int
maxRcvFileDescrTextLength = 1024 * 1024
rcvFileDescrWithinLimits :: Int -> Text -> Bool
rcvFileDescrWithinLimits partNo descrText =
partNo >= 0
&& partNo <= maxRcvFileDescrParts
&& T.length descrText <= maxRcvFileDescrTextLength
getRcvFileDescrByRcvFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByRcvFileId db fileId = do
liftIO (getRcvFileDescrByRcvFileId_ db fileId) >>= \case
@@ -530,7 +632,7 @@ 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
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type
FROM rcv_files r
JOIN files f USING (file_id)
LEFT JOIN contacts cs ON cs.contact_id = f.contact_id
@@ -544,9 +646,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) :. Only (Maybe ContactName) ->
(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) ->
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) :. Only groupName_) =
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. (groupName_, fileType)) =
case contactName_ <|> memberName_ <|> groupName_ <|> standaloneName_ of
Nothing -> throwError $ SERcvFileInvalid fileId
Just name ->
@@ -564,7 +666,7 @@ getRcvFileTransfer_ db userId fileId = do
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
cryptoArgs = CFArgs <$> fileKey <*> fileNonce
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted, userApprovedRelays}) <$> rfd_
in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs}
in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, fileType, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs}
filePath = case filePath_ of
Nothing -> throwError $ SERcvFileInvalid fileId
Just fp -> pure fp
@@ -660,7 +762,15 @@ createRcvFileChunk db RcvFileTransfer {fileId, fileInvitation = FileInvitation {
currentTs <- getCurrentTime
DB.execute
db
"INSERT OR REPLACE INTO rcv_file_chunks (file_id, chunk_number, chunk_agent_msg_id, created_at, updated_at) VALUES (?,?,?,?,?)"
[sql|
INSERT INTO rcv_file_chunks (file_id, chunk_number, chunk_agent_msg_id, created_at, updated_at)
VALUES (?,?,?,?,?)
ON CONFLICT (file_id, chunk_number) DO UPDATE SET
chunk_agent_msg_id = excluded.chunk_agent_msg_id,
chunk_stored = 0,
created_at = excluded.created_at,
updated_at = excluded.updated_at
|]
(fileId, chunkNo, msgId, currentTs, currentTs)
pure status
where
src/Simplex/Chat/Store/Groups.hs
+425 -130
View File
@@ -71,6 +71,10 @@ module Simplex.Chat.Store.Groups
getGroupMembersByIndexes,
getSupportScopeMembersByIndexes,
getGroupModerators,
getGroupRosterMembers,
getGroupAdminsMods,
getGroupOnlyMembers,
getGroupOwners,
getGroupRelayMembers,
getGroupMembersForExpiration,
getRemovedMembersToCleanup,
@@ -87,7 +91,19 @@ module Simplex.Chat.Store.Groups
getGroupRelayById,
getGroupRelayByGMId,
getGroupRelays,
getConnectedGroupRelays,
getPublishableGroupRelays,
setGroupRosterVersion,
getGroupRosterVersion,
getGroupRoster,
RcvRosterTransfer (..),
createRosterTransfer,
getRosterTransferVersion,
getRosterTransferId,
getRosterTransfer,
setGroupLiveRoster,
deleteRosterTransfer,
deleteGroupRosterTransfers,
setGroupMemberKeyRole,
createRelayForOwner,
getCreateRelayForMember,
createRelayConnection,
@@ -102,9 +118,12 @@ module Simplex.Chat.Store.Groups
createRelayRequestGroup,
updateRelayOwnStatusFromTo,
updateRelayOwnStatus_,
getRelaySentWebDomain,
updateRelaySentWebDomain,
isRelayGroupRejected,
allowRelayGroup,
getRelayServedGroups,
getRelayPublishableGroups,
getRelayInactiveGroups,
createNewContactMemberAsync,
createJoiningMember,
@@ -173,6 +192,7 @@ module Simplex.Chat.Store.Groups
createLinkOwnerMember,
updatePreparedChannelMember,
updateUnknownMemberAnnounced,
updateRosterMemberAnnounced,
updateUserMemberProfileSentAt,
setGroupCustomData,
setGroupUIThemes,
@@ -203,6 +223,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, getCurrentTime)
import Data.Text.Encoding (encodeUtf8)
import Simplex.Chat.Badges (BadgeRow, badgeToRow, verifyBadge_)
import Simplex.Chat.Messages
import Simplex.Chat.Operators
import Simplex.Chat.Protocol hiding (Binary)
@@ -215,6 +236,8 @@ import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
import Simplex.Messaging.Agent.Protocol (ConfirmationId, ConnId, CreatedConnLink (..), InvitationId, OwnerAuth (..), SimplexNameInfo, UserId)
import Simplex.Messaging.Agent.Store.AgentStore (firstRow, fromOnlyBI, maybeFirstRow)
import qualified Simplex.FileTransfer.Description as FD
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
import Simplex.Messaging.Agent.Store.Entity (DBEntityId)
import qualified Simplex.Messaging.Agent.Store.DB as DB
@@ -232,12 +255,12 @@ import Database.SQLite.Simple (Only (..), Query, (:.) (..))
import Database.SQLite.Simple.QQ (sql)
#endif
type MaybeGroupMemberRow = (Maybe GroupMemberId, Maybe GroupId, Maybe Int64, Maybe MemberId, Maybe VersionChat, Maybe VersionChat, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe BoolInt, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId) :. (Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe LocalAlias, Maybe Preferences, Maybe Text) :. (Maybe UTCTime, Maybe UTCTime) :. (Maybe UTCTime, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime, Maybe C.PublicKeyEd25519, Maybe ShortLinkContact)
type MaybeGroupMemberRow = (Maybe GroupMemberId, Maybe GroupId, Maybe Int64, Maybe MemberId, Maybe VersionChat, Maybe VersionChat, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe BoolInt, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId) :. ((Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe LocalAlias, Maybe Preferences) :. BadgeRow :. Only (Maybe Text)) :. (Maybe UTCTime, Maybe UTCTime) :. (Maybe UTCTime, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime, Maybe C.PublicKeyEd25519, Maybe ShortLinkContact)
toMaybeGroupMember :: Int64 -> MaybeGroupMemberRow -> Maybe GroupMember
toMaybeGroupMember userContactId ((Just groupMemberId, Just groupId, Just indexInGroup, Just memberId, Just minVer, Just maxVer, Just memberRole, Just memberCategory, Just memberStatus, Just showMessages, memberBlocked') :. (invitedById, invitedByGroupMemberId, Just localDisplayName, memberContactId, Just memberContactProfileId) :. (Just profileId, Just displayName, Just fullName, shortDescr, image, contactLink, peerType, Just localAlias, contactPreferences, profileSimplexNameRaw) :. (Just createdAt, Just updatedAt) :. (supportChatTs, Just supportChatUnread, Just supportChatUnanswered, Just supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink)) =
Just $ toGroupMember userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages, memberBlocked') :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. (profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, contactPreferences, profileSimplexNameRaw) :. (createdAt, updatedAt) :. (supportChatTs, supportChatUnread, supportChatUnanswered, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink))
toMaybeGroupMember _ _ = Nothing
toMaybeGroupMember :: UTCTime -> Int64 -> MaybeGroupMemberRow -> Maybe GroupMember
toMaybeGroupMember now userContactId ((Just groupMemberId, Just groupId, Just indexInGroup, Just memberId, Just minVer, Just maxVer, Just memberRole, Just memberCategory, Just memberStatus, Just showMessages, memberBlocked') :. (invitedById, invitedByGroupMemberId, Just localDisplayName, memberContactId, Just memberContactProfileId) :. ((Just profileId, Just displayName, Just fullName, shortDescr, image, contactLink, peerType, Just localAlias, contactPreferences) :. badgeRow :. Only profileSimplexNameRaw) :. (Just createdAt, Just updatedAt) :. (supportChatTs, Just supportChatUnread, Just supportChatUnanswered, Just supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink)) =
Just $ toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages, memberBlocked') :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. ((profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, contactPreferences) :. badgeRow :. Only profileSimplexNameRaw) :. (createdAt, updatedAt) :. (supportChatTs, supportChatUnread, supportChatUnanswered, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink))
toMaybeGroupMember _ _ _ = Nothing
createGroupLink :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> ConnId -> CreatedLinkContact -> GroupLinkId -> GroupMemberRole -> SubscriptionMode -> ExceptT StoreError IO GroupLink
createGroupLink db gVar user@User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId (CCLink cReq shortLink) groupLinkId memberRole subMode = do
@@ -358,6 +381,7 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
Just PublicGroupProfile {groupType, groupLink, publicGroupId} -> (Just groupType, Just groupLink, Just publicGroupId)
Nothing -> (Nothing, Nothing, Nothing)
fullGroupPreferences = mergeGroupPreferences groupPreferences
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
@@ -388,11 +412,11 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
INSERT INTO groups
(use_relays, creating_in_progress, local_display_name, user_id, group_profile_id, enable_ntfs,
created_at, updated_at, chat_ts, user_member_profile_sent_at,
root_priv_key, root_pub_key, member_priv_key, public_member_count)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
root_priv_key, root_pub_key, member_priv_key, public_member_count, roster_version)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (BI useRelays, BI useRelays, ldn, userId, profileId, BI True, currentTs, currentTs, currentTs, currentTs)
:. (rootPrivKey_, rootPubKey_, memberPrivKey_, publicMemberCount_)
:. (rootPrivKey_, rootPubKey_, memberPrivKey_, publicMemberCount_, rosterVersion0)
)
insertedRowId db
let memberPubKey = C.publicKey . memberPrivKey <$> groupKeys
@@ -419,6 +443,7 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
chatItemTTL = Nothing,
uiThemes = Nothing,
groupSummary = GroupSummary {currentMembers = 1, publicMemberCount = publicMemberCount_},
rosterVersion = rosterVersion0,
customData = Nothing,
membersRequireAttention = 0,
viaGroupLinkUri = Nothing,
@@ -498,6 +523,7 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
chatItemTTL = Nothing,
uiThemes = Nothing,
groupSummary = GroupSummary {currentMembers = 2, publicMemberCount = Nothing},
rosterVersion = Nothing,
customData = Nothing,
membersRequireAttention = 0,
viaGroupLinkUri = Nothing,
@@ -645,7 +671,7 @@ createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile b
randHostId <- liftIO $ encodedRandomBytes gVar 12
let memberId = MemberId $ encodeUtf8 groupLDN <> "_unknown_host_" <> randHostId
hostProfile = profileFromName $ nameFromBS randHostId
(localDisplayName, profileId) <- createNewMemberProfile_ db user hostProfile currentTs
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user hostProfile currentTs
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
liftIO $ do
DB.execute
@@ -800,7 +826,7 @@ updatePreparedUserAndHostMembers'
|]
(memberId, memberRole, membershipStatus, currentTs, groupMemberId' membership)
updateHostMember currentTs = do
_ <- updateMemberProfile db user hostMember fromMemberProfile
_ <- updateMemberProfile db cxt user hostMember fromMemberProfile
let MemberIdRole memberId memberRole = fromMember
gmId = groupMemberId' hostMember
liftIO $
@@ -850,7 +876,7 @@ createGroupViaLink'
(,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user hostMemberId
where
insertHost_ currentTs groupId = do
(localDisplayName, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user fromMemberProfile currentTs
let MemberIdRole {memberId, memberRole} = fromMember
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
liftIO $ do
@@ -1016,7 +1042,8 @@ 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
map (toGroupInfo cxt userContactId [])
currentTs <- getCurrentTime
map (toGroupInfo currentTs cxt userContactId [])
<$> DB.query db (groupInfoQuery <> " " <> condition) (userId, userContactId, search, search, search, search)
where
condition =
@@ -1076,16 +1103,18 @@ getGroupIdBySimplexName db User {userId} ni =
DB.query db "SELECT group_id FROM groups WHERE user_id = ? AND simplex_name = ?" (userId, ni)
getGroupMember :: DB.Connection -> StoreCxt -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMember db cxt user@User {userId} groupId groupMemberId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFound groupMemberId) $
getGroupMember db cxt user@User {userId} groupId groupMemberId = do
currentTs <- liftIO getCurrentTime
ExceptT . firstRow (toContactMember currentTs cxt user) (SEGroupMemberNotFound groupMemberId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?")
(groupId, groupMemberId, userId)
getHostMember :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO GroupMember
getHostMember db cxt user groupId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupHostMemberNotFound groupId) $
getHostMember db cxt user groupId = do
currentTs <- liftIO getCurrentTime
ExceptT . firstRow (toContactMember currentTs cxt user) (SEGroupHostMemberNotFound groupId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.member_category = ?")
@@ -1125,40 +1154,45 @@ toMentionedMember (groupMemberId, memberId, memberRole, displayName, localAlias)
in CIMention {memberId, memberRef}
getGroupMemberById :: DB.Connection -> StoreCxt -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
getGroupMemberById db cxt user@User {userId} groupMemberId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFound groupMemberId) $
getGroupMemberById db cxt user@User {userId} groupMemberId = do
currentTs <- liftIO getCurrentTime
ExceptT . firstRow (toContactMember currentTs cxt user) (SEGroupMemberNotFound groupMemberId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ?")
(groupMemberId, userId)
getNonRemovedMemberById :: DB.Connection -> StoreCxt -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
getNonRemovedMemberById db cxt user@User {userId} groupMemberId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFound groupMemberId) $
getNonRemovedMemberById db cxt user@User {userId} groupMemberId = do
ts <- liftIO getCurrentTime
ExceptT . firstRow (toContactMember ts cxt user) (SEGroupMemberNotFound groupMemberId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ? AND m.member_status NOT IN (?,?,?,?)")
(groupMemberId, userId, GSMemRejected, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
getGroupMemberByIndex :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Int64 -> ExceptT StoreError IO GroupMember
getGroupMemberByIndex db cxt user GroupInfo {groupId} indexInGroup =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFoundByIndex indexInGroup) $
getGroupMemberByIndex db cxt user GroupInfo {groupId} indexInGroup = do
currentTs <- liftIO getCurrentTime
ExceptT . firstRow (toContactMember currentTs cxt user) (SEGroupMemberNotFoundByIndex indexInGroup) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group = ?")
(groupId, indexInGroup)
getSupportScopeMemberByIndex :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMemberId -> Int64 -> ExceptT StoreError IO GroupMember
getSupportScopeMemberByIndex db cxt user GroupInfo {groupId} scopeGMId indexInGroup =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFoundByIndex indexInGroup) $
getSupportScopeMemberByIndex db cxt user GroupInfo {groupId} scopeGMId indexInGroup = do
currentTs <- liftIO getCurrentTime
ExceptT . firstRow (toContactMember currentTs cxt user) (SEGroupMemberNotFoundByIndex indexInGroup) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group = ? AND (m.member_role IN (?,?,?) OR m.group_member_id = ?)")
(groupId, indexInGroup, GRModerator, GRAdmin, GROwner, scopeGMId)
getGroupMemberByMemberId :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberId -> ExceptT StoreError IO GroupMember
getGroupMemberByMemberId db cxt user GroupInfo {groupId} memberId =
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFoundByMemberId memberId) $
getGroupMemberByMemberId db cxt user GroupInfo {groupId} memberId = do
currentTs <- liftIO getCurrentTime
ExceptT . firstRow (toContactMember currentTs cxt user) (SEGroupMemberNotFoundByMemberId memberId) $
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ?")
@@ -1191,8 +1225,9 @@ getGroupMemberIdViaMemberId db User {userId} GroupInfo {groupId} memberId =
(userId, groupId, memberId)
getGroupMembers :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} =
map (toContactMember cxt user)
getGroupMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
currentTs <- getCurrentTime
map (toContactMember currentTs cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)")
@@ -1201,8 +1236,9 @@ getGroupMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} =
getGroupMembersByIndexes :: DB.Connection -> StoreCxt -> User -> GroupInfo -> [Int64] -> IO [GroupMember]
getGroupMembersByIndexes db cxt user gInfo indexesInGroup = do
#if defined(dbPostgres)
currentTs <- getCurrentTime
let GroupInfo {groupId} = gInfo
map (toContactMember cxt user) <$>
map (toContactMember currentTs cxt user) <$>
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group IN ?")
@@ -1214,8 +1250,9 @@ getGroupMembersByIndexes db cxt user gInfo indexesInGroup = do
getSupportScopeMembersByIndexes :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMemberId -> [Int64] -> IO [GroupMember]
getSupportScopeMembersByIndexes db cxt user gInfo scopeGMId indexesInGroup = do
#if defined(dbPostgres)
currentTs <- getCurrentTime
let GroupInfo {groupId} = gInfo
map (toContactMember cxt user) <$>
map (toContactMember currentTs cxt user) <$>
DB.query
db
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group IN ? AND (m.member_role IN (?,?,?) OR m.group_member_id = ?)")
@@ -1226,15 +1263,58 @@ getSupportScopeMembersByIndexes db cxt user gInfo scopeGMId indexesInGroup = do
getGroupModerators :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupModerators db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember cxt user)
currentTs <- getCurrentTime
map (toContactMember currentTs cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?,?)")
(userId, groupId, userContactId, GRModerator, GRAdmin, GROwner)
-- The full roster set - members, moderators and admins - excluding owners (link-anchored) and
-- left/removed members. For the privileged subset only use getGroupAdminsMods; for plain members
-- only use getGroupOnlyMembers.
getGroupRosterMembers :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupRosterMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
currentTs <- getCurrentTime
filter memberCurrent . map (toContactMember currentTs cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?,?)")
(userId, groupId, userContactId, GRMember, GRModerator, GRAdmin)
-- Moderators and admins only (excluding owners and plain members) - the set introduced to a
-- joiner; plain members are learned from the roster blob, not via introductions.
getGroupAdminsMods :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupAdminsMods db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
currentTs <- getCurrentTime
filter memberCurrent . map (toContactMember currentTs cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?)")
(userId, groupId, userContactId, GRModerator, GRAdmin)
getGroupOnlyMembers :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupOnlyMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
currentTs <- getCurrentTime
filter memberCurrent . map (toContactMember currentTs cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role = ?")
(userId, groupId, userContactId, GRMember)
getGroupOwners :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupOwners db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
currentTs <- getCurrentTime
filter memberCurrent . map (toContactMember currentTs cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role = ?")
(userId, groupId, userContactId, GROwner)
getGroupRelayMembers :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupRelayMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember cxt user)
currentTs <- getCurrentTime
map (toContactMember currentTs cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND m.contact_id IS DISTINCT FROM ? AND m.member_role = ?")
@@ -1242,7 +1322,8 @@ getGroupRelayMembers db cxt user@User {userId, userContactId} GroupInfo {groupId
getGroupMembersForExpiration :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
getGroupMembersForExpiration db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
map (toContactMember cxt user)
currentTs <- getCurrentTime
map (toContactMember currentTs cxt user)
<$> DB.query
db
( groupMemberQuery
@@ -1258,8 +1339,9 @@ getGroupMembersForExpiration db cxt user@User {userId, userContactId} GroupInfo
(groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown)
getRemovedMembersToCleanup :: DB.Connection -> StoreCxt -> User -> UTCTime -> IO [GroupMember]
getRemovedMembersToCleanup db cxt user@User {userId} cutoffTs =
map (toContactMember cxt user)
getRemovedMembersToCleanup db cxt user@User {userId} cutoffTs = do
ts <- getCurrentTime
map (toContactMember ts cxt user)
<$> DB.query
db
(groupMemberQuery <> " WHERE m.user_id = ? AND m.removed_at < ?")
@@ -1378,21 +1460,30 @@ getGroupRelays db GroupInfo {groupId} =
(groupRelayQuery <> " WHERE gr.group_id = ?")
(Only groupId)
getConnectedGroupRelays :: DB.Connection -> GroupInfo -> IO [GroupRelay]
getConnectedGroupRelays db GroupInfo {groupId} =
map toGroupRelay
<$> DB.query
db
( groupRelayQuery
<> " "
<> [sql|
JOIN group_members m ON m.group_member_id = gr.group_member_id
WHERE gr.group_id = ?
AND m.member_status = ?
AND gr.relay_status IN (?,?)
|]
)
(groupId, GSMemConnected, RSAccepted, RSActive)
-- Relays whose link is published to subscribers: acked relays (RSAcknowledgedRoster/RSActive) plus
-- pre-roster relays at RSAccepted (below groupRosterVersion, they can't ack a roster), gated by the
-- relay's negotiated version read from its member connection.
getPublishableGroupRelays :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupRelay]
getPublishableGroupRelays db cxt user gInfo@GroupInfo {groupId} = do
relays <-
map toGroupRelay
<$> DB.query
db
( groupRelayQuery
<> " "
<> [sql|
JOIN group_members m ON m.group_member_id = gr.group_member_id
WHERE gr.group_id = ?
AND m.member_status = ?
AND gr.relay_status IN (?,?,?)
|]
)
(groupId, GSMemConnected, RSAccepted, RSAcknowledgedRoster, RSActive)
members <- getGroupRelayMembers db cxt user gInfo
pure [gr | gr@GroupRelay {groupMemberId} <- relays, m <- members, groupMemberId' m == groupMemberId, publishable gr m]
where
publishable GroupRelay {relayStatus} m =
relayStatus /= RSAccepted || not (m `supportsVersion` groupRosterVersion)
groupRelayQuery :: Query
groupRelayQuery =
@@ -1410,11 +1501,154 @@ toGroupRelay ((groupRelayId, groupMemberId, chatRelayId, address, displayName, f
relayCap = RelayCapabilities {webDomain}
in GroupRelay {groupRelayId, groupMemberId, userChatRelay, relayStatus, relayLink, relayCap}
setGroupRosterVersion :: DB.Connection -> GroupInfo -> VersionRoster -> IO ()
setGroupRosterVersion db GroupInfo {groupId} v = do
currentTs <- getCurrentTime
DB.execute db "UPDATE groups SET roster_version = ?, updated_at = ? WHERE group_id = ?" (v, currentTs, groupId)
-- Persisted roster version (the gate baseline; the in-memory gInfo copy is batch-constant and stale on reorder).
getGroupRosterVersion :: DB.Connection -> GroupInfo -> IO (Maybe VersionRoster)
getGroupRosterVersion db GroupInfo {groupId} =
fmap join . maybeFirstRow fromOnly $
DB.query db "SELECT roster_version FROM groups WHERE group_id = ?" (Only groupId)
-- The live roster header a relay re-serves to joiners, with the completed blob served alongside it
-- (both are written together at completion, so the blob is present whenever the header is).
getGroupRoster :: DB.Connection -> GroupInfo -> IO (Maybe (GroupMemberId, UTCTime, SignedMsg, Maybe ByteString))
getGroupRoster db GroupInfo {groupId} =
(>>= toRoster)
<$> maybeFirstRow
id
( DB.query
db
"SELECT roster_sending_owner_gm_id, roster_broker_ts, roster_msg_chat_binding, roster_msg_signatures, roster_msg_body, roster_blob FROM groups WHERE group_id = ?"
(Only groupId)
)
where
toRoster (Just ownerGMId, Just brokerTs, Just cb, Just (Binary sigsBs), Just (Binary body), blob_) =
(\sigs -> (ownerGMId, brokerTs, SignedMsg cb sigs body, (\(Binary b) -> b) <$> blob_)) <$> eitherToMaybe (smpDecode sigsBs)
toRoster _ = Nothing
-- A per-source in-flight roster transfer, keyed (group_id, from_member_id): replaces the single
-- roster_pending_* slot, so two relays serving one member can't share a chunk stream. The signed-header
-- columns are relay-only (NULL on members), promoted to the live roster_msg_* on groups at completion.
createRosterTransfer :: DB.Connection -> GroupInfo -> GroupMemberId -> VersionRoster -> FD.FileDigest -> GroupMemberId -> UTCTime -> Maybe SignedMsg -> IO Int64
createRosterTransfer db GroupInfo {groupId} fromMemberId v digest ownerGMId brokerTs sm_ = do
-- one in-flight transfer per (group, source): drop any prior row from this source so the INSERT can't hit
-- the UNIQUE constraint even if the caller's fs/handle cleanup was skipped (the scratch file would then leak
-- until group delete, but the transfer never gets stuck). Normally cleanupRosterTransfer ran first.
DB.execute db "DELETE FROM rcv_roster_transfers WHERE group_id = ? AND from_member_id = ?" (groupId, fromMemberId)
DB.execute
db
[sql|
INSERT INTO rcv_roster_transfers
(group_id, from_member_id, roster_version, roster_digest, sending_owner_gm_id, broker_ts,
roster_msg_chat_binding, roster_msg_signatures, roster_msg_body)
VALUES (?,?,?,?,?,?,?,?,?)
|]
( (groupId, fromMemberId, v, Binary (FD.unFileDigest digest), ownerGMId, brokerTs)
:. ((\SignedMsg {chatBinding} -> chatBinding) <$> sm_, (\SignedMsg {signatures} -> Binary (smpEncode signatures)) <$> sm_, (\SignedMsg {signedBody} -> Binary signedBody) <$> sm_)
)
insertedRowId db
getRosterTransferVersion :: DB.Connection -> GroupInfo -> GroupMemberId -> IO (Maybe VersionRoster)
getRosterTransferVersion db GroupInfo {groupId} fromMemberId =
maybeFirstRow fromOnly $
DB.query db "SELECT roster_version FROM rcv_roster_transfers WHERE group_id = ? AND from_member_id = ?" (groupId, fromMemberId)
getRosterTransferId :: DB.Connection -> GroupInfo -> GroupMemberId -> IO (Maybe Int64)
getRosterTransferId db GroupInfo {groupId} fromMemberId =
maybeFirstRow fromOnly $
DB.query db "SELECT roster_transfer_id FROM rcv_roster_transfers WHERE group_id = ? AND from_member_id = ?" (groupId, fromMemberId)
-- An in-flight received roster transfer (a rcv_roster_transfers row joined to its scratch file), read at
-- completion. The header is the relay's re-serve SignedMsg -- present only on a serving relay (NULL on a
-- member, whose live roster_msg_* stay NULL so it never re-serves).
data RcvRosterTransfer = RcvRosterTransfer
{ rosterTransferId :: Int64,
rosterTransferVersion :: VersionRoster,
rosterTransferDigest :: FD.FileDigest,
rosterTransferOwnerGMId :: GroupMemberId,
rosterTransferBrokerTs :: UTCTime,
rosterTransferHeader :: Maybe SignedMsg
}
deriving (Show)
-- The in-flight transfer for a received roster file (joined via files.roster_transfer_id), with its
-- relay-only signed header. Read at completion to apply, promote into the live roster, and ack.
getRosterTransfer :: DB.Connection -> Int64 -> IO (Maybe RcvRosterTransfer)
getRosterTransfer db fileId =
(>>= toTransfer)
<$> maybeFirstRow
id
( DB.query
db
[sql|
SELECT t.roster_transfer_id, t.roster_version, t.roster_digest, t.sending_owner_gm_id, t.broker_ts,
t.roster_msg_chat_binding, t.roster_msg_signatures, t.roster_msg_body
FROM rcv_roster_transfers t
JOIN files f ON f.roster_transfer_id = t.roster_transfer_id
WHERE f.file_id = ?
|]
(Only fileId)
)
where
toTransfer (tId, v, Binary d, ownerGMId, brokerTs, cb_, sigs_, body_) =
Just
RcvRosterTransfer
{ rosterTransferId = tId,
rosterTransferVersion = v,
rosterTransferDigest = FD.FileDigest d,
rosterTransferOwnerGMId = ownerGMId,
rosterTransferBrokerTs = brokerTs,
rosterTransferHeader = sm_
}
where
sm_ = case (cb_, sigs_, body_) of
(Just cb, Just (Binary sigsBs), Just (Binary body)) ->
(\sigs -> SignedMsg cb sigs body) <$> eitherToMaybe (smpDecode sigsBs)
_ -> Nothing
-- Write the single live roster on groups from a completed transfer's values (header NULL on a member,
-- so its live roster_msg_* stay NULL and it never re-serves; only relays re-serve).
setGroupLiveRoster :: DB.Connection -> GroupInfo -> VersionRoster -> GroupMemberId -> UTCTime -> Maybe SignedMsg -> ByteString -> IO ()
setGroupLiveRoster db GroupInfo {groupId} v ownerGMId brokerTs sm_ blob = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
UPDATE groups SET
roster_version = ?, roster_blob = ?,
roster_sending_owner_gm_id = ?, roster_broker_ts = ?,
roster_msg_chat_binding = ?, roster_msg_signatures = ?, roster_msg_body = ?,
updated_at = ?
WHERE group_id = ?
|]
( (v, Binary blob, ownerGMId, brokerTs)
:. ((\SignedMsg {chatBinding} -> chatBinding) <$> sm_, (\SignedMsg {signatures} -> Binary (smpEncode signatures)) <$> sm_, (\SignedMsg {signedBody} -> Binary signedBody) <$> sm_, currentTs, groupId)
)
-- Delete one in-flight transfer row (its files/rcv_files/rcv_file_chunks are removed separately, with
-- the on-disk file). Caller removes the fs file + cached handle first.
deleteRosterTransfer :: DB.Connection -> Int64 -> IO ()
deleteRosterTransfer db transferId =
DB.execute db "DELETE FROM rcv_roster_transfers WHERE roster_transfer_id = ?" (Only transferId)
-- All in-flight transfers for a group (group delete).
deleteGroupRosterTransfers :: DB.Connection -> Int64 -> IO ()
deleteGroupRosterTransfers db groupId =
DB.execute db "DELETE FROM rcv_roster_transfers WHERE group_id = ?" (Only groupId)
setGroupMemberKeyRole :: DB.Connection -> GroupMember -> C.PublicKeyEd25519 -> GroupMemberRole -> IO ()
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)
createRelayForOwner :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> UserChatRelay -> ExceptT StoreError IO GroupMember
createRelayForOwner db cxt gVar user@User {userId, userContactId} GroupInfo {groupId, membership} UserChatRelay {relayProfile = RelayProfile {displayName}} = do
currentTs <- liftIO getCurrentTime
let relayProfile = profileFromName displayName
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user relayProfile currentTs
(localDisplayName, memProfileId, _) <- createNewMemberProfile_ db cxt user relayProfile currentTs
groupMemberId <- createWithRandomId' db gVar $ \memId -> runExceptT $ do
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
liftIO $
@@ -1433,11 +1667,12 @@ createRelayForOwner db cxt gVar user@User {userId, userContactId} GroupInfo {gro
getGroupMemberById db cxt user groupMemberId
getCreateRelayForMember :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> ShortLinkContact -> ExceptT StoreError IO GroupMember
getCreateRelayForMember db cxt gVar user@User {userId, userContactId} GroupInfo {groupId, localDisplayName = groupLDN} relayLink =
liftIO getGroupMemberByRelayLink >>= maybe createRelayMember pure
getCreateRelayForMember db cxt gVar user@User {userId, userContactId} GroupInfo {groupId, localDisplayName = groupLDN} relayLink = do
currentTs <- liftIO getCurrentTime
liftIO (getGroupMemberByRelayLink currentTs) >>= maybe createRelayMember pure
where
getGroupMemberByRelayLink =
maybeFirstRow (toContactMember cxt user) $
getGroupMemberByRelayLink currentTs =
maybeFirstRow (toContactMember currentTs cxt user) $
DB.query
db
#if defined(dbPostgres)
@@ -1452,7 +1687,7 @@ getCreateRelayForMember db cxt gVar user@User {userId, userContactId} GroupInfo
randRelayId <- liftIO $ encodedRandomBytes gVar 12
let memberId = MemberId $ encodeUtf8 groupLDN <> "_unknown_relay_" <> randRelayId
relayProfile = profileFromName $ nameFromBS randRelayId
(localDisplayName, profileId) <- createNewMemberProfile_ db user relayProfile currentTs
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user relayProfile currentTs
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
groupMemberId <- liftIO $ do
DB.execute
@@ -1525,7 +1760,7 @@ setRelayLinkAccepted db cxt user m (MemberKey relayKey) profile = do
WHERE group_member_id = ?
|]
(relayKey, currentTs, gmId)
void $ updateMemberProfile db user m profile
void $ updateMemberProfile db cxt user m profile
(,) <$> getGroupMemberById db cxt user gmId <*> getGroupRelayByGMId db gmId
setRelayLinkConfId :: DB.Connection -> GroupMember -> ConfirmationId -> ShortLinkContact -> IO ()
@@ -1572,8 +1807,8 @@ getRelayConfId db m =
|]
(Only (groupMemberId' m))
updateRelayMemberData :: DB.Connection -> User -> GroupMember -> MemberId -> MemberKey -> Profile -> ExceptT StoreError IO ()
updateRelayMemberData db user m memberId (MemberKey relayKey) profile = do
updateRelayMemberData :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberId -> MemberKey -> Profile -> ExceptT StoreError IO ()
updateRelayMemberData db cxt user m memberId (MemberKey relayKey) profile = do
currentTs <- liftIO getCurrentTime
liftIO $
DB.execute
@@ -1584,7 +1819,7 @@ updateRelayMemberData db user m memberId (MemberKey relayKey) profile = do
WHERE group_member_id = ?
|]
(memberId, relayKey, currentTs, groupMemberId' m)
void $ updateMemberProfile db user m profile
void $ updateMemberProfile db cxt user m profile
setGroupInProgressDone :: DB.Connection -> GroupInfo -> IO ()
setGroupInProgressDone db GroupInfo {groupId} = do
@@ -1638,7 +1873,7 @@ createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMemb
insertOwner_ currentTs groupId = do
let MemberIdRole {memberId, memberRole} = fromMember
VersionRange minV maxV = reqChatVRange
(localDisplayName, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user fromMemberProfile currentTs
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
liftIO $ do
DB.execute
@@ -1668,6 +1903,14 @@ updateRelayOwnStatus_ db GroupInfo {groupId} relayStatus = do
let inactiveAt_ = if relayStatus == RSInactive then Just currentTs else Nothing
DB.execute db "UPDATE groups SET relay_own_status = ?, relay_inactive_at = ?, updated_at = ? WHERE group_id = ?" (relayStatus, inactiveAt_, currentTs, groupId)
getRelaySentWebDomain :: DB.Connection -> GroupInfo -> IO (Maybe Text)
getRelaySentWebDomain db GroupInfo {groupId} =
join <$> maybeFirstRow fromOnly (DB.query db "SELECT relay_sent_web_domain FROM groups WHERE group_id = ?" (Only groupId))
updateRelaySentWebDomain :: DB.Connection -> GroupInfo -> Maybe Text -> IO ()
updateRelaySentWebDomain db GroupInfo {groupId} webDomain_ =
DB.execute db "UPDATE groups SET relay_sent_web_domain = ? WHERE group_id = ?" (webDomain_, groupId)
-- Flip every RSRejected row sharing the targeted group's relay_request_group_link
-- to RSInactive in one statement; returns the refreshed GroupInfo for the targeted groupId.
allowRelayGroup :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO GroupInfo
@@ -1705,18 +1948,38 @@ isRelayGroupRejected db User {userId} groupLink =
getRelayServedGroups :: DB.Connection -> StoreCxt -> User -> IO [GroupInfo]
getRelayServedGroups db cxt User {userId, userContactId} = do
map (toGroupInfo cxt userContactId [])
currentTs <- getCurrentTime
map (toGroupInfo currentTs cxt userContactId [])
<$> DB.query
db
( groupInfoQuery
<> " WHERE g.user_id = ? AND mu.contact_id = ? AND g.relay_own_status IN (?, ?)"
<> " WHERE g.user_id = ? AND mu.contact_id = ? AND g.relay_own_status IN (?, ?, ?)"
)
(userId, userContactId, RSAccepted, RSActive)
(userId, userContactId, RSAccepted, RSAcknowledgedRoster, RSActive)
getRelayPublishableGroups :: DB.Connection -> User -> IO [(Int64, B64UrlByteString, Maybe PublicGroupAccess)]
getRelayPublishableGroups db User {userId, userContactId} =
map toRow <$>
DB.query
db
[sql|
SELECT g.group_id, gp.public_group_id,
gp.group_web_page, gp.group_domain, gp.domain_web_page, gp.allow_embedding
FROM groups g
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
JOIN group_members mu ON mu.group_id = g.group_id AND mu.contact_id = ?
WHERE g.user_id = ? AND g.relay_own_status IN (?, ?)
AND gp.public_group_id IS NOT NULL
|]
(userContactId, userId, RSAccepted, RSActive)
where
toRow ((gId, pgId) :. accessRow) = (gId, pgId, toPublicGroupAccess accessRow)
getRelayInactiveGroups :: DB.Connection -> StoreCxt -> User -> NominalDiffTime -> IO [GroupInfo]
getRelayInactiveGroups db cxt User {userId, userContactId} ttl = do
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
map (toGroupInfo cxt userContactId [])
currentTs <- getCurrentTime
let cutoffTs = addUTCTime (- ttl) currentTs
map (toGroupInfo currentTs cxt userContactId [])
<$> DB.query
db
( groupInfoQuery
@@ -1751,14 +2014,15 @@ createNewContactMemberAsync db gVar user@User {userId, userContactId} GroupInfo
:. (minV, maxV)
)
createJoiningMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupMemberRole -> GroupMemberStatus -> Maybe MemberKey -> ExceptT StoreError IO (GroupMemberId, MemberId)
createJoiningMember :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupMemberRole -> GroupMemberStatus -> Maybe MemberKey -> ExceptT StoreError IO (GroupMemberId, MemberId)
createJoiningMember
db
cxt
gVar
User {userId, userContactId}
GroupInfo {groupId, membership}
cReqChatVRange
Profile {displayName, fullName, shortDescr, image, contactLink, preferences}
Profile {displayName, fullName, shortDescr, image, contactLink, badge, preferences}
cReqXContactId_
cReqMemberId_
welcomeMsgId_
@@ -1766,12 +2030,13 @@ createJoiningMember
memberStatus
memberKey_ = do
currentTs <- liftIO getCurrentTime
badgeVerified <- liftIO $ verifyBadge_ (badgeKeys cxt) badge
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
liftIO $
DB.execute
db
"INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(displayName, fullName, shortDescr, image, contactLink, userId, preferences, currentTs, currentTs)
"INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature, badge_key_idx) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
((displayName, fullName, shortDescr, image, contactLink, userId, preferences, currentTs, currentTs) :. badgeToRow badge badgeVerified)
profileId <- liftIO $ insertedRowId db
case cReqMemberId_ of
Just memberId -> do
@@ -2119,10 +2384,10 @@ increaseGroupMembersRequireAttention db User {userId} g@GroupInfo {groupId, memb
pure g {membersRequireAttention = membersRequireAttention + 1}
-- | add new member with profile
createNewGroupMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
createNewGroupMember db user gInfo invitingMember memInfo@MemberInfo {profile} memCategory memStatus = do
createNewGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
createNewGroupMember db cxt user gInfo invitingMember memInfo@MemberInfo {profile} memCategory memStatus = do
currentTs <- liftIO getCurrentTime
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user profile currentTs
(localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user profile currentTs
let newMember =
NewGroupMember
{ memInfo,
@@ -2135,19 +2400,20 @@ createNewGroupMember db user gInfo invitingMember memInfo@MemberInfo {profile} m
memContactId = Nothing,
memProfileId
}
createNewMember_ db user gInfo newMember currentTs
createNewMember_ db user gInfo newMember badgeVerified currentTs
createNewMemberProfile_ :: DB.Connection -> User -> Profile -> UTCTime -> ExceptT StoreError IO (Text, ProfileId)
createNewMemberProfile_ db User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, preferences} createdAt =
createNewMemberProfile_ :: DB.Connection -> StoreCxt -> User -> Profile -> UTCTime -> ExceptT StoreError IO (Text, ProfileId, Maybe Bool)
createNewMemberProfile_ db cxt User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, badge, preferences} createdAt =
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
badgeVerified <- verifyBadge_ (badgeKeys cxt) badge
DB.execute
db
"INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(displayName, fullName, shortDescr, image, contactLink, userId, preferences, createdAt, createdAt)
"INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, user_id, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature, badge_key_idx) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
((displayName, fullName, shortDescr, image, contactLink, userId, preferences, createdAt, createdAt) :. badgeToRow badge badgeVerified)
profileId <- insertedRowId db
pure $ Right (ldn, profileId)
pure $ Right (ldn, profileId, badgeVerified)
createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> UTCTime -> ExceptT StoreError IO GroupMember
createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> Maybe Bool -> UTCTime -> ExceptT StoreError IO GroupMember
createNewMember_
db
User {userId, userContactId}
@@ -2163,6 +2429,7 @@ createNewMember_
memContactId = memberContactId,
memProfileId = memberContactProfileId
}
badgeVerified
createdAt = do
let invitedById = fromInvitedBy userContactId invitedBy
activeConn = Nothing
@@ -2200,7 +2467,7 @@ createNewMember_
invitedBy,
invitedByGroupMemberId = memInvitedByGroupMemberId,
localDisplayName,
memberProfile = toLocalProfile memberContactProfileId memberProfile "",
memberProfile = toLocalProfile memberContactProfileId memberProfile "" createdAt badgeVerified,
memberContactId,
memberContactProfileId,
activeConn,
@@ -2314,18 +2581,19 @@ getMemberRelationsVector db GroupMember {groupMemberId} =
"SELECT member_relations_vector FROM group_members WHERE group_member_id = ?"
(Only groupMemberId)
createIntroReMember :: DB.Connection -> User -> GroupInfo -> MemberInfo -> Maybe MemberRestrictions -> ExceptT StoreError IO GroupMember
createIntroReMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberInfo -> Maybe MemberRestrictions -> ExceptT StoreError IO GroupMember
createIntroReMember
db
cxt
user
gInfo
memInfo@(MemberInfo _ _ _ memberProfile _)
memRestrictions_ = do
currentTs <- liftIO getCurrentTime
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user memberProfile currentTs
(localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user memberProfile currentTs
let memRestriction = restriction <$> memRestrictions_
newMember = NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId}
createNewMember_ db user gInfo newMember currentTs
createNewMember_ db user gInfo newMember badgeVerified currentTs
createIntroReMemberConn :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionChat -> MemberInfo -> (CommandId, ConnId) -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createIntroReMemberConn
@@ -3113,50 +3381,54 @@ setMemberContactStartedConnection db Contact {contactId} = do
-- | Updates the member profile, also clearing the simplex_name on any other
-- contact_profiles row in the same user that already holds the same
-- (user_id, simplex_name) — newer-claim-wins, required by the partial UNIQUE index.
updateMemberProfile :: DB.Connection -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember
updateMemberProfile db user@User {userId} m p'
| displayName == newName = liftIO $ do
currentTs <- getCurrentTime
clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
updateMemberContactProfileReset_' db userId profileId p' currentTs
pure m {memberProfile = profile}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
updateMemberContactProfileReset_' db userId profileId p' currentTs
DB.execute
db
"UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?"
(ldn, currentTs, userId, groupMemberId)
safeDeleteLDN db user localDisplayName
pure $ Right m {localDisplayName = ldn, memberProfile = profile}
updateMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Profile -> ExceptT StoreError IO GroupMember
updateMemberProfile db cxt user@User {userId} m p' = do
currentTs <- liftIO getCurrentTime
badgeVerified <- liftIO $ profileBadgeVerified (badgeKeys cxt) (memberProfile m) p'
let memberProfile = toLocalProfile profileId p' localAlias currentTs badgeVerified
updateMemberProfile' currentTs badgeVerified memberProfile
where
GroupMember {groupMemberId, localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m
Profile {displayName = newName, simplexName = profileSimplexName} = p'
profile = toLocalProfile profileId p' localAlias
updateMemberProfile' currentTs badgeVerified memberProfile
| displayName == newName = do
liftIO $ clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
liftIO $ updateMemberContactProfileReset_' db userId profileId p' badgeVerified currentTs
pure m {memberProfile}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
updateMemberContactProfileReset_' db userId profileId p' badgeVerified currentTs
DB.execute
db
"UPDATE group_members SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_member_id = ?"
(ldn, currentTs, userId, groupMemberId)
safeDeleteLDN db user localDisplayName
pure $ Right m {localDisplayName = ldn, memberProfile}
-- | Updates the member's contact profile, also clearing the simplex_name on any
-- other contact_profiles row in the same user that already holds the same
-- (user_id, simplex_name) — newer-claim-wins, required by the partial UNIQUE index.
updateContactMemberProfile :: DB.Connection -> User -> GroupMember -> Contact -> Profile -> ExceptT StoreError IO (GroupMember, Contact)
updateContactMemberProfile db user@User {userId} m ct@Contact {contactId} p'
| displayName == newName = liftIO $ do
currentTs <- getCurrentTime
clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
updateMemberContactProfile_' db userId profileId p' currentTs
pure (m {memberProfile = profile}, ct {profile} :: Contact)
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
updateMemberContactProfile_' db userId profileId p' currentTs
updateContactLDN_ db user contactId localDisplayName ldn currentTs
pure $ Right (m {localDisplayName = ldn, memberProfile = profile}, ct {localDisplayName = ldn, profile} :: Contact)
updateContactMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Contact -> Profile -> ExceptT StoreError IO (GroupMember, Contact)
updateContactMemberProfile db cxt user@User {userId} m ct@Contact {contactId} p' = do
currentTs <- liftIO getCurrentTime
badgeVerified <- liftIO $ profileBadgeVerified (badgeKeys cxt) (memberProfile m) p'
let profile = toLocalProfile profileId p' localAlias currentTs badgeVerified
updateContactMemberProfile' currentTs badgeVerified profile
where
GroupMember {localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m
Profile {displayName = newName, simplexName = profileSimplexName} = p'
profile = toLocalProfile profileId p' localAlias
updateContactMemberProfile' currentTs badgeVerified profile
| displayName == newName = do
liftIO $ clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
liftIO $ updateMemberContactProfile_' db userId profileId p' badgeVerified currentTs
pure (m {memberProfile = profile}, ct {profile} :: Contact)
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
clearConflictingContactProfileSimplexName_ db userId (Just profileId) profileSimplexName
updateMemberContactProfile_' db userId profileId p' badgeVerified currentTs
updateContactLDN_ db user contactId localDisplayName ldn currentTs
pure $ Right (m {localDisplayName = ldn, memberProfile = profile}, ct {localDisplayName = ldn, profile} :: Contact)
getXGrpLinkMemReceived :: DB.Connection -> GroupMemberId -> ExceptT StoreError IO Bool
getXGrpLinkMemReceived db mId =
@@ -3175,7 +3447,7 @@ createNewUnknownGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo ->
createNewUnknownGroupMember db cxt user@User {userId, userContactId} GroupInfo {groupId} memberId memberName unknownMemberRole = do
currentTs <- liftIO getCurrentTime
let memberProfile = profileFromName memberName
(localDisplayName, profileId) <- createNewMemberProfile_ db user memberProfile currentTs
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user memberProfile currentTs
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
liftIO $
DB.execute
@@ -3200,7 +3472,7 @@ createLinkOwnerMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe
createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupId} contactId_ memberId ownerKey = do
currentTs <- liftIO getCurrentTime
let memberProfile = profileFromName $ nameFromMemberId memberId
(localDisplayName, profileId) <- createNewMemberProfile_ db user memberProfile currentTs
(localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user memberProfile currentTs
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
liftIO $
DB.execute
@@ -3221,33 +3493,32 @@ createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupI
where
VersionRange minV maxV = vr cxt
-- member_pub_key is not updated here — introduced members are owners
-- whose keys are loaded from link data (trusted out-of-band).
-- Updating from an in-band message would allow a compromised relay to substitute keys.
-- Intro refreshes only profile / status / peer version. Role and key stay owner-authoritative
-- (the owner-signed roster for members/moderators/admins, link data for owners), so taking either from
-- an in-band relayed intro would let a compromised relay substitute them.
updatePreparedChannelMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberInfo -> ExceptT StoreError IO GroupMember
updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile} = do
_ <- updateMemberProfile db user member profile
updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} = do
_ <- updateMemberProfile db cxt user member profile
currentTs <- liftIO getCurrentTime
liftIO $
DB.execute
db
[sql|
UPDATE group_members
SET member_role = ?,
member_status = ?,
SET member_status = ?,
peer_chat_min_version = ?,
peer_chat_max_version = ?,
updated_at = ?
WHERE user_id = ? AND group_member_id = ?
|]
(memberRole, GSMemIntroduced, minV, maxV, currentTs, userId, groupMemberId)
(GSMemIntroduced, minV, maxV, currentTs, userId, groupMemberId)
getGroupMemberById db cxt user groupMemberId
where
VersionRange minV maxV = maybe memberChatVRange fromChatVRange v
updateUnknownMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile, memberKey} status = do
_ <- updateMemberProfile db user unknownMember profile
_ <- updateMemberProfile db cxt user unknownMember profile
currentTs <- liftIO getCurrentTime
liftIO $
DB.execute
@@ -3272,6 +3543,30 @@ updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMem
VersionRange minV maxV = maybe memberChatVRange fromChatVRange v
memberPubKey_ = (\(MemberKey k) -> k) <$> memberKey
-- Like updateUnknownMemberAnnounced but preserves member_role and member_pub_key
-- (roster-established for moderators/admins; the dissemination carries only the profile).
updateRosterMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
updateRosterMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} status = do
_ <- updateMemberProfile db cxt user unknownMember profile
currentTs <- liftIO getCurrentTime
liftIO $
DB.execute
db
[sql|
UPDATE group_members
SET member_category = ?,
member_status = ?,
invited_by_group_member_id = ?,
peer_chat_min_version = ?,
peer_chat_max_version = ?,
updated_at = ?
WHERE user_id = ? AND group_member_id = ?
|]
((GCPostMember, status, groupMemberId' invitingMember) :. (minV, maxV, currentTs, userId, groupMemberId))
getGroupMemberById db cxt user groupMemberId
where
VersionRange minV maxV = maybe memberChatVRange fromChatVRange v
updateUserMemberProfileSentAt :: DB.Connection -> User -> GroupInfo -> UTCTime -> IO ()
updateUserMemberProfileSentAt db User {userId} GroupInfo {groupId} sentTs =
DB.execute
src/Simplex/Chat/Store/Messages.hs
+55 -31
View File
@@ -137,6 +137,7 @@ module Simplex.Chat.Store.Messages
getGroupSndStatuses,
getGroupSndStatusCounts,
getGroupHistoryItems,
getGroupWebPreviewItems,
)
where
@@ -237,10 +238,7 @@ createNewSndMessage db gVar connOrGroupId chatMsgEvent msgSigning_ encodeMessage
case encodeMessage (SharedMsgId sharedMsgId) of
ECMLarge -> pure $ Left SELargeMsg
ECMEncoded msgBody -> do
let signedMsg_ = signBody <$> msgSigning_
signBody MsgSigning {bindingTag, bindingData, keyRef, privKey} =
let sig = C.ASignature C.SEd25519 $ C.sign' privKey (encodeChatBinding bindingTag bindingData <> msgBody)
in SignedMsg {chatBinding = bindingTag, signatures = MsgSignature keyRef sig :| [], signedBody = msgBody}
let signedMsg_ = (`signChatMsgBody` msgBody) <$> msgSigning_
createdAt <- getCurrentTime
DB.execute
db
@@ -583,9 +581,9 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgS
CDChannelRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ ->
(Just $ Just userMemberId == memberId, memberId)
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink itemTs =
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing Nothing
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> Maybe MsgSigStatus -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink msgSigned itemTs =
createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing msgSigned
where
quoteRow :: NewQuoteRow
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
@@ -662,7 +660,8 @@ insertChatItemMessage_ :: DB.Connection -> ChatItemId -> MessageId -> UTCTime ->
insertChatItemMessage_ db ciId msgId ts = DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, ts, ts)
getChatItemQuote_ :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c)
getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} =
getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} = do
currentTs <- getCurrentTime
case chatDirection of
CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent)
CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} _s sender@GroupMember {groupMemberId = senderGMId, memberId = senderMemberId} ->
@@ -670,13 +669,13 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
Just mId
| mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId
| mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId senderGMId
| otherwise -> getGroupChatItemQuote_ groupId mId
| otherwise -> getGroupChatItemQuote_ currentTs groupId mId
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing
CDChannelRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} _s ->
case memberId of
Just mId
| mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId
| otherwise -> getGroupChatItemQuote_ groupId mId
| otherwise -> getGroupChatItemQuote_ currentTs groupId mId
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing
where
ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c
@@ -705,8 +704,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
db
"SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND item_sent = ? AND group_member_id = ?"
(userId, groupId, msgId, MDRcv, groupMemberId)
getGroupChatItemQuote_ :: Int64 -> MemberId -> IO (CIQuote 'CTGroup)
getGroupChatItemQuote_ groupId mId = do
getGroupChatItemQuote_ :: UTCTime -> Int64 -> MemberId -> IO (CIQuote 'CTGroup)
getGroupChatItemQuote_ currentTs groupId mId = do
ciQuoteGroup
<$> DB.query
db
@@ -715,7 +714,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
-- GroupMember
m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category,
m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, p.simplex_name,
p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences,
p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.simplex_name,
m.created_at, m.updated_at,
m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link
FROM group_members m
@@ -731,7 +731,7 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
where
ciQuoteGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> CIQuote 'CTGroup
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember currentTs userContactId memberRow
getChatPreviews :: DB.Connection -> StoreCxt -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
getChatPreviews db cxt user withPCC pagination query = do
@@ -1121,22 +1121,25 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
getContactRequestChatPreviews_ :: DB.Connection -> User -> PaginationByTime -> ChatListQuery -> IO [AChatPreviewData]
getContactRequestChatPreviews_ db User {userId} pagination clq = case clq of
CLQFilters {favorite = False, unread = False} -> map toPreview <$> getPreviews ""
CLQFilters {favorite = True, unread = False} -> pure []
CLQFilters {favorite = False, unread = True} -> map toPreview <$> getPreviews ""
CLQFilters {favorite = True, unread = True} -> map toPreview <$> getPreviews ""
CLQSearch {search} -> map toPreview <$> getPreviews search
getContactRequestChatPreviews_ db User {userId} pagination clq = do
currentTs <- getCurrentTime
case clq of
CLQFilters {favorite = False, unread = False} -> map (toPreview currentTs) <$> getPreviews ""
CLQFilters {favorite = True, unread = False} -> pure []
CLQFilters {favorite = False, unread = True} -> map (toPreview currentTs) <$> getPreviews ""
CLQFilters {favorite = True, unread = True} -> map (toPreview currentTs) <$> getPreviews ""
CLQSearch {search} -> map (toPreview currentTs) <$> getPreviews search
where
query =
[sql|
SELECT
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id,
cr.contact_id, cr.business_group_id, cr.user_contact_link_id,
cr.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, cr.xcontact_id,
cr.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, cr.xcontact_id,
cr.pq_support, cr.welcome_shared_msg_id, cr.request_shared_msg_id, p.preferences,
cr.created_at, cr.updated_at,
cr.peer_chat_min_version, cr.peer_chat_max_version
cr.peer_chat_min_version, cr.peer_chat_max_version,
p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.simplex_name
FROM contact_requests cr
JOIN contact_profiles p ON p.contact_profile_id = cr.contact_profile_id
JOIN user_contact_links uc ON uc.user_contact_link_id = cr.user_contact_link_id
@@ -1158,9 +1161,9 @@ getContactRequestChatPreviews_ db User {userId} pagination clq = case clq of
PTLast count -> DB.query db (query <> " ORDER BY cr.updated_at DESC LIMIT ?") (params search :. Only count)
PTAfter ts count -> DB.query db (query <> " AND cr.updated_at > ? ORDER BY cr.updated_at ASC LIMIT ?") (params search :. (ts, count))
PTBefore ts count -> DB.query db (query <> " AND cr.updated_at < ? ORDER BY cr.updated_at DESC LIMIT ?") (params search :. (ts, count))
toPreview :: ContactRequestRow -> AChatPreviewData
toPreview cReqRow =
let cReq@UserContactRequest {updatedAt} = toContactRequest cReqRow
toPreview :: UTCTime -> ContactRequestRow -> AChatPreviewData
toPreview now cReqRow =
let cReq@UserContactRequest {updatedAt} = toContactRequest now cReqRow
aChat = AChat SCTContactRequest $ Chat (ContactRequest cReq) [] emptyChatStats
in ACPD SCTContactRequest $ ContactRequestPD updatedAt aChat
@@ -2368,9 +2371,9 @@ toGroupChatItem
) = do
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
member_ = toMaybeGroupMember userContactId memberRow_
quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_
member_ = toMaybeGroupMember currentTs userContactId memberRow_
quotedMember_ = toMaybeGroupMember currentTs userContactId quotedMemberRow_
deletedByGroupMember_ = toMaybeGroupMember currentTs userContactId deletedByGroupMemberRow_
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
chatItem itemContent = case (itemContent, itemStatus, member_, fileStatus_) of
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) ->
@@ -3066,7 +3069,8 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
-- GroupMember
m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category,
m.member_status, m.show_messages, m.member_restriction, m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, p.simplex_name,
p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences,
p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.simplex_name,
m.created_at, m.updated_at,
m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link,
-- quoted ChatItem
@@ -3074,13 +3078,15 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
-- quoted GroupMember
rm.group_member_id, rm.group_id, rm.index_in_group, rm.member_id, rm.peer_chat_min_version, rm.peer_chat_max_version, rm.member_role, rm.member_category,
rm.member_status, rm.show_messages, rm.member_restriction, rm.invited_by, rm.invited_by_group_member_id, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
rp.display_name, rp.full_name, rp.short_descr, rp.image, rp.contact_link, rp.chat_peer_type, rp.local_alias, rp.preferences, rp.simplex_name,
rp.display_name, rp.full_name, rp.short_descr, rp.image, rp.contact_link, rp.chat_peer_type, rp.local_alias, rp.preferences,
rp.badge_proof, rp.badge_pres_header, rp.badge_expiry, rp.badge_type, rp.badge_verified, rp.badge_extra, rp.badge_master_key, rp.badge_signature, rp.badge_key_idx, rp.simplex_name,
rm.created_at, rm.updated_at,
rm.support_chat_ts, rm.support_chat_items_unread, rm.support_chat_items_member_attention, rm.support_chat_items_mentions, rm.support_chat_last_msg_from_member_ts, rm.member_pub_key, rm.relay_link,
-- deleted by GroupMember
dbm.group_member_id, dbm.group_id, dbm.index_in_group, dbm.member_id, dbm.peer_chat_min_version, dbm.peer_chat_max_version, dbm.member_role, dbm.member_category,
dbm.member_status, dbm.show_messages, dbm.member_restriction, dbm.invited_by, dbm.invited_by_group_member_id, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
dbp.display_name, dbp.full_name, dbp.short_descr, dbp.image, dbp.contact_link, dbp.chat_peer_type, dbp.local_alias, dbp.preferences, dbp.simplex_name,
dbp.display_name, dbp.full_name, dbp.short_descr, dbp.image, dbp.contact_link, dbp.chat_peer_type, dbp.local_alias, dbp.preferences,
dbp.badge_proof, dbp.badge_pres_header, dbp.badge_expiry, dbp.badge_type, dbp.badge_verified, dbp.badge_extra, dbp.badge_master_key, dbp.badge_signature, dbp.badge_key_idx, dbp.simplex_name,
dbm.created_at, dbm.updated_at,
dbm.support_chat_ts, dbm.support_chat_items_unread, dbm.support_chat_items_member_attention, dbm.support_chat_items_mentions, dbm.support_chat_last_msg_from_member_ts, dbm.member_pub_key, dbm.relay_link
FROM chat_items i
@@ -3708,3 +3714,21 @@ getGroupHistoryItems db user@User {userId} g@GroupInfo {groupId} m count = do
LIMIT ?
|]
(groupMemberId' m, userId, groupId, count)
getGroupWebPreviewItems :: DB.Connection -> User -> GroupInfo -> Int -> IO [Either StoreError (CChatItem 'CTGroup)]
getGroupWebPreviewItems db user@User {userId} g@GroupInfo {groupId} count = do
ciIds <-
map fromOnly
<$> DB.query
db
[sql|
SELECT i.chat_item_id
FROM chat_items i
WHERE i.user_id = ? AND i.group_id = ?
AND i.include_in_history = 1
AND i.item_deleted = 0
ORDER BY i.item_ts DESC, i.chat_item_id DESC
LIMIT ?
|]
(userId, groupId, count)
reverse <$> mapM (runExceptT . getGroupCIWithReactions db user g) ciIds
src/Simplex/Chat/Store/Postgres/Migrations.hs
+6
View File
@@ -32,9 +32,12 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260429_relay_request_retries
import Simplex.Chat.Store.Postgres.Migrations.M20260507_relay_inactive_at
import Simplex.Chat.Store.Postgres.Migrations.M20260514_relay_request_group_link_index
import Simplex.Chat.Store.Postgres.Migrations.M20260515_public_group_access
import Simplex.Chat.Store.Postgres.Migrations.M20260516_supporter_badges
import Simplex.Chat.Store.Postgres.Migrations.M20260529_delivery_job_senders
import Simplex.Chat.Store.Postgres.Migrations.M20260530_client_services
import Simplex.Chat.Store.Postgres.Migrations.M20260531_member_removed_at
import Simplex.Chat.Store.Postgres.Migrations.M20260601_relay_sent_web_domain
import Simplex.Chat.Store.Postgres.Migrations.M20260602_group_roster
import Simplex.Chat.Store.Postgres.Migrations.M20260603_simplex_name
import Simplex.Chat.Store.Postgres.Migrations.M20260604_simplex_name_profiles
import Simplex.Chat.Store.Postgres.Migrations.M20260606_simplex_name_verified
@@ -71,9 +74,12 @@ schemaMigrations =
("20260507_relay_inactive_at", m20260507_relay_inactive_at, Just down_m20260507_relay_inactive_at),
("20260514_relay_request_group_link_index", m20260514_relay_request_group_link_index, Just down_m20260514_relay_request_group_link_index),
("20260515_public_group_access", m20260515_public_group_access, Just down_m20260515_public_group_access),
("20260516_supporter_badges", m20260516_supporter_badges, Just down_m20260516_supporter_badges),
("20260529_delivery_job_senders", m20260529_delivery_job_senders, Just down_m20260529_delivery_job_senders),
("20260530_client_services", m20260530_client_services, Just down_m20260530_client_services),
("20260531_member_removed_at", m20260531_member_removed_at, Just down_m20260531_member_removed_at),
("20260601_relay_sent_web_domain", m20260601_relay_sent_web_domain, Just down_m20260601_relay_sent_web_domain),
("20260602_group_roster", m20260602_group_roster, Just down_m20260602_group_roster),
("20260603_simplex_name", m20260603_simplex_name, Just down_m20260603_simplex_name),
("20260604_simplex_name_profiles", m20260604_simplex_name_profiles, Just down_m20260604_simplex_name_profiles),
("20260606_simplex_name_verified", m20260606_simplex_name_verified, Just down_m20260606_simplex_name_verified),
src/Simplex/Chat/Store/Postgres/Migrations/M20260516_supporter_badges.hs
+35
View File
@@ -0,0 +1,35 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.Postgres.Migrations.M20260516_supporter_badges where
import Data.Text (Text)
import Text.RawString.QQ (r)
m20260516_supporter_badges :: Text
m20260516_supporter_badges =
[r|
ALTER TABLE contact_profiles ADD COLUMN badge_proof BYTEA;
ALTER TABLE contact_profiles ADD COLUMN badge_pres_header BYTEA;
ALTER TABLE contact_profiles ADD COLUMN badge_expiry TIMESTAMPTZ;
ALTER TABLE contact_profiles ADD COLUMN badge_type TEXT;
ALTER TABLE contact_profiles ADD COLUMN badge_verified SMALLINT;
ALTER TABLE contact_profiles ADD COLUMN badge_extra TEXT;
ALTER TABLE contact_profiles ADD COLUMN badge_master_key BYTEA;
ALTER TABLE contact_profiles ADD COLUMN badge_signature BYTEA;
ALTER TABLE contact_profiles ADD COLUMN badge_key_idx BIGINT;
|]
down_m20260516_supporter_badges :: Text
down_m20260516_supporter_badges =
[r|
ALTER TABLE contact_profiles DROP COLUMN badge_key_idx;
ALTER TABLE contact_profiles DROP COLUMN badge_signature;
ALTER TABLE contact_profiles DROP COLUMN badge_master_key;
ALTER TABLE contact_profiles DROP COLUMN badge_extra;
ALTER TABLE contact_profiles DROP COLUMN badge_verified;
ALTER TABLE contact_profiles DROP COLUMN badge_type;
ALTER TABLE contact_profiles DROP COLUMN badge_proof;
ALTER TABLE contact_profiles DROP COLUMN badge_pres_header;
ALTER TABLE contact_profiles DROP COLUMN badge_expiry;
|]
src/Simplex/Chat/Store/Postgres/Migrations/M20260601_relay_sent_web_domain.hs
+19
View File
@@ -0,0 +1,19 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.Postgres.Migrations.M20260601_relay_sent_web_domain where
import Data.Text (Text)
import Text.RawString.QQ (r)
m20260601_relay_sent_web_domain :: Text
m20260601_relay_sent_web_domain =
[r|
ALTER TABLE groups ADD COLUMN relay_sent_web_domain TEXT;
|]
down_m20260601_relay_sent_web_domain :: Text
down_m20260601_relay_sent_web_domain =
[r|
ALTER TABLE groups DROP COLUMN relay_sent_web_domain;
|]
src/Simplex/Chat/Store/Postgres/Migrations/M20260602_group_roster.hs
+64
View File
@@ -0,0 +1,64 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.Postgres.Migrations.M20260602_group_roster where
import Data.Text (Text)
import Text.RawString.QQ (r)
m20260602_group_roster :: Text
m20260602_group_roster =
[r|
ALTER TABLE groups ADD COLUMN roster_version BIGINT;
ALTER TABLE groups ADD COLUMN roster_msg_body BYTEA;
ALTER TABLE groups ADD COLUMN roster_msg_chat_binding TEXT;
ALTER TABLE groups ADD COLUMN roster_msg_signatures BYTEA;
ALTER TABLE groups ADD COLUMN roster_sending_owner_gm_id BIGINT;
ALTER TABLE groups ADD COLUMN roster_broker_ts TIMESTAMPTZ;
ALTER TABLE groups ADD COLUMN roster_blob BYTEA;
CREATE TABLE rcv_roster_transfers(
roster_transfer_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
group_id BIGINT NOT NULL REFERENCES groups ON DELETE CASCADE,
from_member_id BIGINT NOT NULL REFERENCES group_members ON DELETE CASCADE,
roster_version BIGINT NOT NULL,
roster_digest BYTEA NOT NULL,
sending_owner_gm_id BIGINT NOT NULL,
broker_ts TIMESTAMPTZ NOT NULL,
roster_msg_body BYTEA,
roster_msg_chat_binding TEXT,
roster_msg_signatures BYTEA,
created_at TEXT NOT NULL DEFAULT (now()),
updated_at TEXT NOT NULL DEFAULT (now())
);
CREATE UNIQUE INDEX idx_rcv_roster_transfers_group_id_from_member_id ON rcv_roster_transfers(group_id, from_member_id);
CREATE INDEX idx_rcv_roster_transfers_from_member_id ON rcv_roster_transfers(from_member_id);
ALTER TABLE files ADD COLUMN shared_msg_id BYTEA;
ALTER TABLE files ADD COLUMN file_type TEXT NOT NULL DEFAULT 'normal';
ALTER TABLE files ADD COLUMN roster_transfer_id BIGINT;
CREATE INDEX idx_files_group_id_shared_msg_id ON files(group_id, shared_msg_id);
CREATE INDEX idx_files_roster_transfer_id ON files(roster_transfer_id);
|]
down_m20260602_group_roster :: Text
down_m20260602_group_roster =
[r|
DROP INDEX idx_files_roster_transfer_id;
DROP INDEX idx_files_group_id_shared_msg_id;
ALTER TABLE files DROP COLUMN roster_transfer_id;
ALTER TABLE files DROP COLUMN file_type;
ALTER TABLE files DROP COLUMN shared_msg_id;
DROP INDEX idx_rcv_roster_transfers_from_member_id;
DROP INDEX idx_rcv_roster_transfers_group_id_from_member_id;
DROP TABLE rcv_roster_transfers;
ALTER TABLE groups DROP COLUMN roster_blob;
ALTER TABLE groups DROP COLUMN roster_broker_ts;
ALTER TABLE groups DROP COLUMN roster_sending_owner_gm_id;
ALTER TABLE groups DROP COLUMN roster_msg_signatures;
ALTER TABLE groups DROP COLUMN roster_msg_chat_binding;
ALTER TABLE groups DROP COLUMN roster_msg_body;
ALTER TABLE groups DROP COLUMN roster_version;
|]
src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql
+85 -4
View File
@@ -533,6 +533,15 @@ CREATE TABLE test_chat_schema.contact_profiles (
contact_link bytea,
short_descr text,
chat_peer_type text,
badge_proof bytea,
badge_pres_header bytea,
badge_expiry timestamp with time zone,
badge_type text,
badge_verified smallint,
badge_extra text,
badge_master_key bytea,
badge_signature bytea,
badge_key_idx bigint,
simplex_name text
);
@@ -615,7 +624,8 @@ CREATE TABLE test_chat_schema.contacts (
grp_direct_inv_from_group_member_id bigint,
grp_direct_inv_from_member_conn_id bigint,
grp_direct_inv_started_connection smallint DEFAULT 0 NOT NULL,
simplex_name text
simplex_name text,
simplex_name_verified_at timestamp with time zone
);
@@ -746,7 +756,10 @@ CREATE TABLE test_chat_schema.files (
file_crypto_key bytea,
file_crypto_nonce bytea,
note_folder_id bigint,
redirect_file_id bigint
redirect_file_id bigint,
shared_msg_id bytea,
file_type text DEFAULT 'normal'::text NOT NULL,
roster_transfer_id bigint
);
@@ -972,9 +985,18 @@ 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,
simplex_name text
relay_sent_web_domain text,
roster_version bigint,
roster_msg_body bytea,
roster_msg_chat_binding text,
roster_msg_signatures bytea,
roster_sending_owner_gm_id bigint,
roster_broker_ts timestamp with time zone,
roster_blob bytea,
simplex_name text,
simplex_name_verified_at timestamp with time zone
);
@@ -1201,6 +1223,34 @@ CREATE TABLE test_chat_schema.rcv_files (
CREATE TABLE test_chat_schema.rcv_roster_transfers (
roster_transfer_id bigint NOT NULL,
group_id bigint NOT NULL,
from_member_id bigint NOT NULL,
roster_version bigint NOT NULL,
roster_digest bytea NOT NULL,
sending_owner_gm_id bigint NOT NULL,
broker_ts timestamp with time zone NOT NULL,
roster_msg_body bytea,
roster_msg_chat_binding text,
roster_msg_signatures bytea,
created_at text DEFAULT now() NOT NULL,
updated_at text DEFAULT now() NOT NULL
);
ALTER TABLE test_chat_schema.rcv_roster_transfers ALTER COLUMN roster_transfer_id ADD GENERATED ALWAYS AS IDENTITY (
SEQUENCE NAME test_chat_schema.rcv_roster_transfers_roster_transfer_id_seq
START WITH 1
INCREMENT BY 1
NO MINVALUE
NO MAXVALUE
CACHE 1
);
CREATE TABLE test_chat_schema.received_probes (
received_probe_id bigint NOT NULL,
contact_id bigint,
@@ -1735,6 +1785,11 @@ ALTER TABLE ONLY test_chat_schema.rcv_files
ALTER TABLE ONLY test_chat_schema.rcv_roster_transfers
ADD CONSTRAINT rcv_roster_transfers_pkey PRIMARY KEY (roster_transfer_id);
ALTER TABLE ONLY test_chat_schema.received_probes
ADD CONSTRAINT received_probes_pkey PRIMARY KEY (received_probe_id);
@@ -2276,10 +2331,18 @@ CREATE INDEX idx_files_group_id ON test_chat_schema.files USING btree (group_id)
CREATE INDEX idx_files_group_id_shared_msg_id ON test_chat_schema.files USING btree (group_id, shared_msg_id);
CREATE INDEX idx_files_redirect_file_id ON test_chat_schema.files USING btree (redirect_file_id);
CREATE INDEX idx_files_roster_transfer_id ON test_chat_schema.files USING btree (roster_transfer_id);
CREATE INDEX idx_files_user_id ON test_chat_schema.files USING btree (user_id);
@@ -2460,6 +2523,14 @@ CREATE INDEX idx_rcv_files_group_member_id ON test_chat_schema.rcv_files USING b
CREATE INDEX idx_rcv_roster_transfers_from_member_id ON test_chat_schema.rcv_roster_transfers USING btree (from_member_id);
CREATE UNIQUE INDEX idx_rcv_roster_transfers_group_id_from_member_id ON test_chat_schema.rcv_roster_transfers USING btree (group_id, from_member_id);
CREATE INDEX idx_received_probes_contact_id ON test_chat_schema.received_probes USING btree (contact_id);
@@ -3145,6 +3216,16 @@ ALTER TABLE ONLY test_chat_schema.rcv_files
ALTER TABLE ONLY test_chat_schema.rcv_roster_transfers
ADD CONSTRAINT rcv_roster_transfers_from_member_id_fkey FOREIGN KEY (from_member_id) REFERENCES test_chat_schema.group_members(group_member_id) ON DELETE CASCADE;
ALTER TABLE ONLY test_chat_schema.rcv_roster_transfers
ADD CONSTRAINT rcv_roster_transfers_group_id_fkey FOREIGN KEY (group_id) REFERENCES test_chat_schema.groups(group_id) ON DELETE CASCADE;
ALTER TABLE ONLY test_chat_schema.received_probes
ADD CONSTRAINT received_probes_contact_id_fkey FOREIGN KEY (contact_id) REFERENCES test_chat_schema.contacts(contact_id) ON DELETE CASCADE;
src/Simplex/Chat/Store/Profiles.hs
+71 -34
View File
@@ -43,6 +43,7 @@ module Simplex.Chat.Store.Profiles
updateUserGroupReceipts,
updateUserAutoAcceptMemberContacts,
updateUserProfile,
setUserBadge,
setUserProfileContactLink,
getUserContactProfiles,
createUserContactLink,
@@ -97,6 +98,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Simplex.Chat.Badges (LocalBadge, localBadgeToRow)
import Simplex.Chat.Call
import Simplex.Chat.Messages
import Simplex.Chat.Operators
@@ -159,7 +161,7 @@ createUserRecordAt db (AgentUserId auId) userChatRelay clientService Profile {di
(profileId, displayName, userId, BI True, currentTs, currentTs, currentTs)
contactId <- insertedRowId db
DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId)
pure $ toUser $ (userId, auId, contactId, profileId, BI activeUser, order) :. (displayName, fullName, shortDescr, image, Nothing, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, Nothing, Nothing, Nothing, BI userChatRelay, BI clientService, Nothing, Nothing)
pure $ toUser currentTs $ (userId, auId, contactId, profileId, BI activeUser, order) :. (displayName, fullName, shortDescr, image, Nothing, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, Nothing, Nothing, Nothing, BI userChatRelay, BI clientService, Nothing) :. localBadgeToRow Nothing :. Only Nothing
-- TODO [mentions]
getUsersInfo :: DB.Connection -> IO [UserInfo]
@@ -193,8 +195,9 @@ getUsersInfo db = getUsers db >>= mapM getUserInfo
pure UserInfo {user, unreadCount = fromMaybe 0 ctCount + fromMaybe 0 gCount}
getUsers :: DB.Connection -> IO [User]
getUsers db =
map toUser <$> DB.query_ db userQuery
getUsers db = do
now <- getCurrentTime
map (toUser now) <$> DB.query_ db userQuery
setActiveUser :: DB.Connection -> User -> IO User
setActiveUser db user@User {userId} = do
@@ -211,13 +214,15 @@ getNextActiveOrder db = do
else pure $ order + 1
getUser :: DB.Connection -> UserId -> ExceptT StoreError IO User
getUser db userId =
ExceptT . firstRow toUser (SEUserNotFound userId) $
getUser db userId = do
now <- liftIO getCurrentTime
ExceptT . firstRow (toUser now) (SEUserNotFound userId) $
DB.query db (userQuery <> " WHERE u.user_id = ?") (Only userId)
getRelayUser :: DB.Connection -> ExceptT StoreError IO User
getRelayUser db =
ExceptT . firstRow toUser SERelayUserNotFound $
getRelayUser db = do
now <- liftIO getCurrentTime
ExceptT . firstRow (toUser now) SERelayUserNotFound $
DB.query_ db (userQuery <> " WHERE u.is_user_chat_relay = 1")
getUserIdByName :: DB.Connection -> UserName -> ExceptT StoreError IO Int64
@@ -226,38 +231,45 @@ getUserIdByName db uName =
DB.query db "SELECT user_id FROM users WHERE local_display_name = ?" (Only uName)
getUserByAConnId :: DB.Connection -> AgentConnId -> IO (Maybe User)
getUserByAConnId db agentConnId =
maybeFirstRow toUser $
getUserByAConnId db agentConnId = do
now <- getCurrentTime
maybeFirstRow (toUser now) $
DB.query db (userQuery <> " JOIN connections c ON c.user_id = u.user_id WHERE c.agent_conn_id = ?") (Only agentConnId)
getUserByASndFileId :: DB.Connection -> AgentSndFileId -> IO (Maybe User)
getUserByASndFileId db aSndFileId =
maybeFirstRow toUser $
getUserByASndFileId db aSndFileId = do
now <- getCurrentTime
maybeFirstRow (toUser now) $
DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.agent_snd_file_id = ?") (Only aSndFileId)
getUserByARcvFileId :: DB.Connection -> AgentRcvFileId -> IO (Maybe User)
getUserByARcvFileId db aRcvFileId =
maybeFirstRow toUser $
getUserByARcvFileId db aRcvFileId = do
now <- getCurrentTime
maybeFirstRow (toUser now) $
DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id JOIN rcv_files r ON r.file_id = f.file_id WHERE r.agent_rcv_file_id = ?") (Only aRcvFileId)
getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User
getUserByContactId db contactId =
ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $
getUserByContactId db contactId = do
now <- liftIO getCurrentTime
ExceptT . firstRow (toUser now) (SEUserNotFoundByContactId contactId) $
DB.query db (userQuery <> " JOIN contacts ct ON ct.user_id = u.user_id WHERE ct.contact_id = ? AND ct.deleted = 0") (Only contactId)
getUserByGroupId :: DB.Connection -> GroupId -> ExceptT StoreError IO User
getUserByGroupId db groupId =
ExceptT . firstRow toUser (SEUserNotFoundByGroupId groupId) $
getUserByGroupId db groupId = do
now <- liftIO getCurrentTime
ExceptT . firstRow (toUser now) (SEUserNotFoundByGroupId groupId) $
DB.query db (userQuery <> " JOIN groups g ON g.user_id = u.user_id WHERE g.group_id = ?") (Only groupId)
getUserByNoteFolderId :: DB.Connection -> NoteFolderId -> ExceptT StoreError IO User
getUserByNoteFolderId db contactId =
ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $
getUserByNoteFolderId db contactId = do
now <- liftIO getCurrentTime
ExceptT . firstRow (toUser now) (SEUserNotFoundByContactId contactId) $
DB.query db (userQuery <> " JOIN note_folders nf ON nf.user_id = u.user_id WHERE nf.note_folder_id = ?") (Only contactId)
getUserByFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO User
getUserByFileId db fileId =
ExceptT . firstRow toUser (SEUserNotFoundByFileId fileId) $
getUserByFileId db fileId = do
now <- liftIO getCurrentTime
ExceptT . firstRow (toUser now) (SEUserNotFoundByFileId fileId) $
DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.file_id = ?") (Only fileId)
getUserFileInfo :: DB.Connection -> User -> IO [CIFileInfo]
@@ -317,10 +329,10 @@ updateUserAutoAcceptMemberContacts db User {userId} autoAccept =
updateUserProfile :: DB.Connection -> User -> Profile -> ExceptT StoreError IO User
updateUserProfile db user p'
| displayName == newName = liftIO $ do
updateContactProfile_ db userId profileId pNoSimplexName
currentTs <- getCurrentTime
updateUserProfileFields_' db userId profileId p' currentTs
userMemberProfileUpdatedAt' <- updateUserMemberProfileUpdatedAt_ currentTs
pure user {profile, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
pure user {profile = (toLocalProfile profileId p' localAlias currentTs (Just False)) {localBadge}, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
| otherwise =
checkConstraint SEDuplicateName . liftIO $ do
currentTs <- getCurrentTime
@@ -330,9 +342,9 @@ updateUserProfile db user p'
db
"INSERT INTO display_names (local_display_name, ldn_base, user_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(newName, newName, userId, currentTs, currentTs)
updateContactProfile_' db userId profileId pNoSimplexName currentTs
updateUserProfileFields_' db userId profileId p' currentTs
updateContactLDN_ db user userContactId localDisplayName newName currentTs
pure user {localDisplayName = newName, profile, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
pure user {localDisplayName = newName, profile = (toLocalProfile profileId p' localAlias currentTs (Just False)) {localBadge}, fullPreferences, userMemberProfileUpdatedAt = userMemberProfileUpdatedAt'}
where
updateUserMemberProfileUpdatedAt_ currentTs
| userMemberProfileChanged = do
@@ -340,17 +352,42 @@ updateUserProfile db user p'
pure $ Just currentTs
| otherwise = pure userMemberProfileUpdatedAt
userMemberProfileChanged = newName /= displayName || fn' /= fullName || d' /= shortDescr || img' /= image
User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, localAlias}, userMemberProfileUpdatedAt} = user
User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, localBadge, localAlias}, userMemberProfileUpdatedAt} = user
Profile {displayName = newName, fullName = fn', shortDescr = d', image = img', preferences} = p'
-- contact_profiles.simplex_name is reserved for peer claims received via XInfo.
-- The user's own broadcastable simplex_name lives on contacts.simplex_name
-- (loaded by toUser into User.profile.simplexName via uct.simplex_name);
-- writing it here would (a) collide with peer claims on the partial UNIQUE
-- index, and (b) make a subsequent peer claim displace the user's own row.
pNoSimplexName = (p' :: Profile) {simplexName = Nothing}
profile = toLocalProfile profileId p' localAlias
-- contact_profiles.simplex_name is reserved for peer claims received via XInfo;
-- updateUserProfileFields_' deliberately does not write it. The user's own
-- broadcastable simplex_name lives on contacts.simplex_name (loaded by toUser
-- into User.profile.simplexName via uct.simplex_name).
fullPreferences = fullPreferences' preferences
-- own profile field update; leaves the badge columns alone (the credential is owned by setUserBadge/addUserBadge)
updateUserProfileFields_' :: DB.Connection -> UserId -> ProfileId -> Profile -> UTCTime -> IO ()
updateUserProfileFields_' db userId profileId Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType} updatedAt =
DB.execute
db
[sql|
UPDATE contact_profiles
SET display_name = ?, full_name = ?, short_descr = ?, image = ?, contact_link = ?, preferences = ?, chat_peer_type = ?, updated_at = ?
WHERE user_id = ? AND contact_profile_id = ?
|]
((displayName, fullName, shortDescr, image, contactLink, preferences, peerType, updatedAt) :. (userId, profileId))
-- 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}
setUserProfileContactLink :: DB.Connection -> User -> Maybe UserContactLink -> IO User
setUserProfileContactLink db user@User {userId, profile = p@LocalProfile {profileId}} ucl_ = do
ts <- getCurrentTime
@@ -380,7 +417,7 @@ getUserContactProfiles db User {userId} =
(Only userId)
where
toContactProfile :: (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Text, Maybe Preferences) -> Profile
toContactProfile (displayName, fullName, shortDescr, image, contactLink, peerType, simplexNameRaw, preferences) = Profile {displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName simplexNameRaw, peerType, preferences}
toContactProfile (displayName, fullName, shortDescr, image, contactLink, peerType, simplexNameRaw, preferences) = Profile {displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName simplexNameRaw, peerType, preferences, badge = Nothing}
createUserContactLink :: DB.Connection -> User -> ConnId -> CreatedLinkContact -> SubscriptionMode -> ExceptT StoreError IO ()
createUserContactLink db User {userId} agentConnId (CCLink cReq shortLink) subMode =
src/Simplex/Chat/Store/SQLite/Migrations.hs
+6
View File
@@ -155,9 +155,12 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260429_relay_request_retries
import Simplex.Chat.Store.SQLite.Migrations.M20260507_relay_inactive_at
import Simplex.Chat.Store.SQLite.Migrations.M20260514_relay_request_group_link_index
import Simplex.Chat.Store.SQLite.Migrations.M20260515_public_group_access
import Simplex.Chat.Store.SQLite.Migrations.M20260516_supporter_badges
import Simplex.Chat.Store.SQLite.Migrations.M20260529_delivery_job_senders
import Simplex.Chat.Store.SQLite.Migrations.M20260530_client_services
import Simplex.Chat.Store.SQLite.Migrations.M20260531_member_removed_at
import Simplex.Chat.Store.SQLite.Migrations.M20260601_relay_sent_web_domain
import Simplex.Chat.Store.SQLite.Migrations.M20260602_group_roster
import Simplex.Chat.Store.SQLite.Migrations.M20260603_simplex_name
import Simplex.Chat.Store.SQLite.Migrations.M20260604_simplex_name_profiles
import Simplex.Chat.Store.SQLite.Migrations.M20260606_simplex_name_verified
@@ -317,9 +320,12 @@ schemaMigrations =
("20260507_relay_inactive_at", m20260507_relay_inactive_at, Just down_m20260507_relay_inactive_at),
("20260514_relay_request_group_link_index", m20260514_relay_request_group_link_index, Just down_m20260514_relay_request_group_link_index),
("20260515_public_group_access", m20260515_public_group_access, Just down_m20260515_public_group_access),
("20260516_supporter_badges", m20260516_supporter_badges, Just down_m20260516_supporter_badges),
("20260529_delivery_job_senders", m20260529_delivery_job_senders, Just down_m20260529_delivery_job_senders),
("20260530_client_services", m20260530_client_services, Just down_m20260530_client_services),
("20260531_member_removed_at", m20260531_member_removed_at, Just down_m20260531_member_removed_at),
("20260601_relay_sent_web_domain", m20260601_relay_sent_web_domain, Just down_m20260601_relay_sent_web_domain),
("20260602_group_roster", m20260602_group_roster, Just down_m20260602_group_roster),
("20260603_simplex_name", m20260603_simplex_name, Just down_m20260603_simplex_name),
("20260604_simplex_name_profiles", m20260604_simplex_name_profiles, Just down_m20260604_simplex_name_profiles),
("20260606_simplex_name_verified", m20260606_simplex_name_verified, Just down_m20260606_simplex_name_verified),
src/Simplex/Chat/Store/SQLite/Migrations/M20260516_supporter_badges.hs
+34
View File
@@ -0,0 +1,34 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.SQLite.Migrations.M20260516_supporter_badges where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20260516_supporter_badges :: Query
m20260516_supporter_badges =
[sql|
ALTER TABLE contact_profiles ADD COLUMN badge_proof BLOB;
ALTER TABLE contact_profiles ADD COLUMN badge_pres_header BLOB;
ALTER TABLE contact_profiles ADD COLUMN badge_expiry TEXT;
ALTER TABLE contact_profiles ADD COLUMN badge_type TEXT;
ALTER TABLE contact_profiles ADD COLUMN badge_verified INTEGER;
ALTER TABLE contact_profiles ADD COLUMN badge_extra TEXT;
ALTER TABLE contact_profiles ADD COLUMN badge_master_key BLOB;
ALTER TABLE contact_profiles ADD COLUMN badge_signature BLOB;
ALTER TABLE contact_profiles ADD COLUMN badge_key_idx INTEGER;
|]
down_m20260516_supporter_badges :: Query
down_m20260516_supporter_badges =
[sql|
ALTER TABLE contact_profiles DROP COLUMN badge_key_idx;
ALTER TABLE contact_profiles DROP COLUMN badge_signature;
ALTER TABLE contact_profiles DROP COLUMN badge_master_key;
ALTER TABLE contact_profiles DROP COLUMN badge_extra;
ALTER TABLE contact_profiles DROP COLUMN badge_verified;
ALTER TABLE contact_profiles DROP COLUMN badge_type;
ALTER TABLE contact_profiles DROP COLUMN badge_expiry;
ALTER TABLE contact_profiles DROP COLUMN badge_proof;
ALTER TABLE contact_profiles DROP COLUMN badge_pres_header;
|]
src/Simplex/Chat/Store/SQLite/Migrations/M20260601_relay_sent_web_domain.hs
+18
View File
@@ -0,0 +1,18 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.SQLite.Migrations.M20260601_relay_sent_web_domain where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20260601_relay_sent_web_domain :: Query
m20260601_relay_sent_web_domain =
[sql|
ALTER TABLE groups ADD COLUMN relay_sent_web_domain TEXT;
|]
down_m20260601_relay_sent_web_domain :: Query
down_m20260601_relay_sent_web_domain =
[sql|
ALTER TABLE groups DROP COLUMN relay_sent_web_domain;
|]
src/Simplex/Chat/Store/SQLite/Migrations/M20260602_group_roster.hs
+63
View File
@@ -0,0 +1,63 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.SQLite.Migrations.M20260602_group_roster where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20260602_group_roster :: Query
m20260602_group_roster =
[sql|
ALTER TABLE groups ADD COLUMN roster_version INTEGER;
ALTER TABLE groups ADD COLUMN roster_msg_body BLOB;
ALTER TABLE groups ADD COLUMN roster_msg_chat_binding TEXT;
ALTER TABLE groups ADD COLUMN roster_msg_signatures BLOB;
ALTER TABLE groups ADD COLUMN roster_sending_owner_gm_id INTEGER;
ALTER TABLE groups ADD COLUMN roster_broker_ts TEXT;
ALTER TABLE groups ADD COLUMN roster_blob BLOB;
CREATE TABLE rcv_roster_transfers(
roster_transfer_id INTEGER PRIMARY KEY,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE,
from_member_id INTEGER NOT NULL REFERENCES group_members ON DELETE CASCADE,
roster_version INTEGER NOT NULL,
roster_digest BLOB NOT NULL,
sending_owner_gm_id INTEGER NOT NULL,
broker_ts TEXT NOT NULL,
roster_msg_body BLOB,
roster_msg_chat_binding TEXT,
roster_msg_signatures BLOB,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
) STRICT;
CREATE UNIQUE INDEX idx_rcv_roster_transfers_group_id_from_member_id ON rcv_roster_transfers(group_id, from_member_id);
CREATE INDEX idx_rcv_roster_transfers_from_member_id ON rcv_roster_transfers(from_member_id);
ALTER TABLE files ADD COLUMN shared_msg_id BLOB;
ALTER TABLE files ADD COLUMN file_type TEXT NOT NULL DEFAULT 'normal';
ALTER TABLE files ADD COLUMN roster_transfer_id INTEGER;
CREATE INDEX idx_files_group_id_shared_msg_id ON files(group_id, shared_msg_id);
CREATE INDEX idx_files_roster_transfer_id ON files(roster_transfer_id);
|]
down_m20260602_group_roster :: Query
down_m20260602_group_roster =
[sql|
DROP INDEX idx_files_roster_transfer_id;
DROP INDEX idx_files_group_id_shared_msg_id;
ALTER TABLE files DROP COLUMN roster_transfer_id;
ALTER TABLE files DROP COLUMN file_type;
ALTER TABLE files DROP COLUMN shared_msg_id;
DROP INDEX idx_rcv_roster_transfers_from_member_id;
DROP INDEX idx_rcv_roster_transfers_group_id_from_member_id;
DROP TABLE rcv_roster_transfers;
ALTER TABLE groups DROP COLUMN roster_blob;
ALTER TABLE groups DROP COLUMN roster_broker_ts;
ALTER TABLE groups DROP COLUMN roster_sending_owner_gm_id;
ALTER TABLE groups DROP COLUMN roster_msg_signatures;
ALTER TABLE groups DROP COLUMN roster_msg_chat_binding;
ALTER TABLE groups DROP COLUMN roster_msg_body;
ALTER TABLE groups DROP COLUMN roster_version;
|]
src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt
-9
View File
@@ -548,15 +548,6 @@ Plan:
SEARCH s USING PRIMARY KEY (conn_id=? AND internal_snd_id=?)
SEARCH m USING PRIMARY KEY (conn_id=? AND internal_id=?)
Query:
UPDATE rcv_messages
SET receive_attempts = receive_attempts + 1
WHERE conn_id = ? AND internal_id = ?
RETURNING receive_attempts
Plan:
SEARCH rcv_messages USING COVERING INDEX idx_rcv_messages_conn_id_internal_id (conn_id=? AND internal_id=?)
Query:
DELETE FROM conn_confirmations
WHERE conn_id = ?
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+445 -108
View File
File diff suppressed because it is too large Load Diff
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+47 -1
View File
@@ -20,6 +20,15 @@ CREATE TABLE contact_profiles(
contact_link BLOB,
short_descr TEXT,
chat_peer_type TEXT,
badge_proof BLOB,
badge_pres_header BLOB,
badge_expiry TEXT,
badge_type TEXT,
badge_verified INTEGER,
badge_extra TEXT,
badge_master_key BLOB,
badge_signature BLOB,
badge_key_idx INTEGER,
simplex_name TEXT
) STRICT;
CREATE TABLE users(
@@ -187,6 +196,14 @@ CREATE TABLE groups(
relay_request_delay INTEGER NOT NULL DEFAULT 0,
relay_request_execute_at TEXT NOT NULL DEFAULT '1970-01-01 00:00:00',
relay_inactive_at TEXT,
relay_sent_web_domain TEXT,
roster_version INTEGER,
roster_msg_body BLOB,
roster_msg_chat_binding TEXT,
roster_msg_signatures BLOB,
roster_sending_owner_gm_id INTEGER,
roster_broker_ts TEXT,
roster_blob BLOB,
simplex_name TEXT,
simplex_name_verified_at TEXT, -- received
FOREIGN KEY(user_id, local_display_name)
@@ -274,7 +291,10 @@ CREATE TABLE files(
file_crypto_key BLOB,
file_crypto_nonce BLOB,
note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE,
redirect_file_id INTEGER REFERENCES files ON DELETE CASCADE
redirect_file_id INTEGER REFERENCES files ON DELETE CASCADE,
shared_msg_id BLOB,
file_type TEXT NOT NULL DEFAULT 'normal',
roster_transfer_id INTEGER
) STRICT;
CREATE TABLE snd_files(
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
@@ -797,6 +817,20 @@ CREATE TABLE group_relays(
,
base_web_url TEXT
) STRICT;
CREATE TABLE rcv_roster_transfers(
roster_transfer_id INTEGER PRIMARY KEY,
group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE,
from_member_id INTEGER NOT NULL REFERENCES group_members ON DELETE CASCADE,
roster_version INTEGER NOT NULL,
roster_digest BLOB NOT NULL,
sending_owner_gm_id INTEGER NOT NULL,
broker_ts TEXT NOT NULL,
roster_msg_body BLOB,
roster_msg_chat_binding TEXT,
roster_msg_signatures BLOB,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
) STRICT;
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@@ -1316,6 +1350,18 @@ ON groups(
relay_request_group_link
)
WHERE relay_request_group_link IS NOT NULL;
CREATE UNIQUE INDEX idx_rcv_roster_transfers_group_id_from_member_id ON rcv_roster_transfers(
group_id,
from_member_id
);
CREATE INDEX idx_rcv_roster_transfers_from_member_id ON rcv_roster_transfers(
from_member_id
);
CREATE INDEX idx_files_group_id_shared_msg_id ON files(
group_id,
shared_msg_id
);
CREATE INDEX idx_files_roster_transfer_id ON files(roster_transfer_id);
CREATE UNIQUE INDEX idx_contacts_simplex_name
ON contacts(
user_id,
src/Simplex/Chat/Store/Shared.hs
+49 -41
View File
@@ -33,6 +33,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Data.Type.Equality
import Simplex.Chat.Badges (BadgeRow, badgeToRow, rowToBadge, verifyBadge_)
import Simplex.Chat.Messages
import Simplex.Chat.Remote.Types
import Simplex.Chat.Types
@@ -425,10 +426,10 @@ setCommandConnId db User {userId} cmdId connId = do
|]
(connId, updatedAt, userId, cmdId)
createContact :: DB.Connection -> User -> Profile -> ExceptT StoreError IO ()
createContact db user profile = do
createContact :: DB.Connection -> StoreCxt -> User -> Profile -> ExceptT StoreError IO ()
createContact db cxt user profile = do
currentTs <- liftIO getCurrentTime
void $ createContact_ db user profile emptyChatPrefs Nothing "" currentTs Nothing
void $ createContact_ db cxt user profile emptyChatPrefs Nothing "" currentTs Nothing
-- | Clears simplex_name on any other contact_profiles row that holds the same
-- (user_id, simplex_name) so a subsequent UPDATE/INSERT setting that value
@@ -467,17 +468,18 @@ clearConflictingContactProfileSimplexName_ db userId (Just profileId) (Just simp
-- peer-claimed Profile.simplexName that collides with an existing row (the
-- partial UNIQUE index on contact_profiles.(user_id, simplex_name)) displaces
-- the prior holder's name — newer-claim-wins.
createContact_ :: DB.Connection -> User -> Profile -> Preferences -> Maybe (ACreatedConnLink, Maybe SharedMsgId) -> LocalAlias -> UTCTime -> Maybe SimplexNameInfo -> ExceptT StoreError IO ContactId
createContact_ db User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, simplexName = profileSimplexName, peerType, preferences} ctUserPreferences prepared localAlias currentTs simplexName =
createContact_ :: DB.Connection -> StoreCxt -> User -> Profile -> Preferences -> Maybe (ACreatedConnLink, Maybe SharedMsgId) -> LocalAlias -> UTCTime -> Maybe SimplexNameInfo -> ExceptT StoreError IO ContactId
createContact_ db cxt User {userId} Profile {displayName, fullName, shortDescr, image, contactLink, simplexName = profileSimplexName, peerType, badge, preferences} ctUserPreferences prepared localAlias currentTs simplexName =
ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do
-- Clear any existing peer claim on the same simplex_name before INSERT
-- so the partial UNIQUE index doesn't reject the new row. Pass Nothing
-- as the excluded profileId — there's no self-row yet.
clearConflictingContactProfileSimplexName_ db userId Nothing profileSimplexName
badgeVerified <- verifyBadge_ (badgeKeys cxt) badge
DB.execute
db
"INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, chat_peer_type, user_id, local_alias, preferences, simplex_name, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
((displayName, fullName, shortDescr, image, contactLink, peerType) :. (userId, localAlias, preferences, profileSimplexName, currentTs, currentTs))
"INSERT INTO contact_profiles (display_name, full_name, short_descr, image, contact_link, chat_peer_type, user_id, local_alias, preferences, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature, badge_key_idx, simplex_name) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
((displayName, fullName, shortDescr, image, contactLink, peerType) :. (userId, localAlias, preferences, currentTs, currentTs) :. badgeToRow badge badgeVerified :. Only profileSimplexName)
profileId <- insertedRowId db
DB.execute
db
@@ -544,16 +546,16 @@ type PreparedContactRow = (Maybe AConnectionRequestUri, Maybe AConnShortLink, Ma
type GroupDirectInvitationRow = (Maybe ConnReqInvitation, Maybe GroupId, Maybe GroupMemberId, Maybe Int64, BoolInt)
type ContactRow' = (ProfileId, ContactName, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, BoolInt, ContactStatus) :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) :. PreparedContactRow :. (Maybe Int64, Maybe GroupMemberId, BoolInt) :. GroupDirectInvitationRow :. (Maybe UIThemeEntityOverrides, BoolInt, Maybe CustomData, Maybe Int64, Maybe Text, Maybe Text, Maybe UTCTime)
type ContactRow' = (ProfileId, ContactName, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, BoolInt, ContactStatus) :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime) :. PreparedContactRow :. (Maybe Int64, Maybe GroupMemberId, BoolInt) :. GroupDirectInvitationRow :. (Maybe UIThemeEntityOverrides, BoolInt, Maybe CustomData, Maybe Int64) :. BadgeRow :. (Maybe Text, Maybe Text, Maybe UTCTime)
type ContactRow = Only ContactId :. ContactRow'
-- ct.simplex_name -> Contact.simplexName (user's locally-known label)
-- cp.simplex_name -> LocalProfile.simplexName (peer's broadcast claim)
toContact :: StoreCxt -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
toContact cxt user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL, ctSimplexNameRaw, cpSimplexNameRaw, simplexNameVerifiedAt)) :. connRow) =
toContact :: UTCTime -> StoreCxt -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
toContact now cxt user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL) :. badgeRow :. (ctSimplexNameRaw, cpSimplexNameRaw, simplexNameVerifiedAt)) :. connRow) =
let simplexName = decodeSimplexName ctSimplexNameRaw
profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName cpSimplexNameRaw, peerType, preferences, localAlias}
profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName cpSimplexNameRaw, peerType, localBadge = rowToBadge now badgeRow, preferences, localAlias}
activeConn = toMaybeConnection cxt connRow
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
incognito = maybe False connIncognito activeConn
@@ -579,22 +581,24 @@ toGroupDirectInvitation (Just groupDirectInvLink, fromGroupId_, fromGroupMemberI
Just $ GroupDirectInvitation {groupDirectInvLink, fromGroupId_, fromGroupMemberId_, fromGroupMemberConnId_, groupDirectInvStartedConnection}
getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile
getProfileById db userId profileId =
ExceptT . firstRow rowToLocalProfile (SEProfileNotFound profileId) $
getProfileById db userId profileId = do
currentTs <- liftIO getCurrentTime
ExceptT . firstRow (rowToLocalProfile currentTs) (SEProfileNotFound profileId) $
DB.query
db
[sql|
SELECT cp.contact_profile_id, cp.display_name, cp.full_name, cp.short_descr, cp.image, cp.contact_link, cp.chat_peer_type, cp.local_alias, cp.preferences, cp.simplex_name -- , ct.user_preferences
SELECT cp.contact_profile_id, cp.display_name, cp.full_name, cp.short_descr, cp.image, cp.contact_link, cp.chat_peer_type, cp.local_alias, cp.preferences, -- , ct.user_preferences
cp.badge_proof, cp.badge_pres_header, cp.badge_expiry, cp.badge_type, cp.badge_verified, cp.badge_extra, cp.badge_master_key, cp.badge_signature, cp.badge_key_idx, cp.simplex_name
FROM contact_profiles cp
WHERE cp.user_id = ? AND cp.contact_profile_id = ?
|]
(userId, profileId)
type ContactRequestRow = (Int64, ContactName, AgentInvId, Maybe ContactId, Maybe GroupId, Maybe Int64) :. (Int64, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Text) :. (Maybe XContactId, PQSupport, Maybe SharedMsgId, Maybe SharedMsgId, Maybe Preferences, UTCTime, UTCTime, VersionChat, VersionChat)
type ContactRequestRow = (Int64, ContactName, AgentInvId, Maybe ContactId, Maybe GroupId, Maybe Int64) :. (Int64, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias) :. (Maybe XContactId, PQSupport, Maybe SharedMsgId, Maybe SharedMsgId, Maybe Preferences, UTCTime, UTCTime, VersionChat, VersionChat) :. BadgeRow :. Only (Maybe Text)
toContactRequest :: ContactRequestRow -> UserContactRequest
toContactRequest ((contactRequestId, localDisplayName, agentInvitationId, contactId_, businessGroupId_, userContactLinkId_) :. (profileId, displayName, fullName, shortDescr, image, contactLink, peerType, simplexNameRaw) :. (xContactId, pqSupport, welcomeSharedMsgId, requestSharedMsgId, preferences, createdAt, updatedAt, minVer, maxVer)) = do
let profile = Profile {displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName simplexNameRaw, peerType, preferences}
toContactRequest :: UTCTime -> ContactRequestRow -> UserContactRequest
toContactRequest now ((contactRequestId, localDisplayName, agentInvitationId, contactId_, businessGroupId_, userContactLinkId_) :. (profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias) :. (xContactId, pqSupport, welcomeSharedMsgId, requestSharedMsgId, preferences, createdAt, updatedAt, minVer, maxVer) :. badgeRow :. Only simplexNameRaw) = do
let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName simplexNameRaw, peerType, preferences, localBadge = rowToBadge now badgeRow, localAlias}
cReqChatVRange = fromMaybe (versionToRange maxVer) $ safeVersionRange minVer maxVer
in UserContactRequest {contactRequestId, agentInvitationId, contactId_, businessGroupId_, userContactLinkId_, cReqChatVRange, localDisplayName, profileId, profile, xContactId, pqSupport, welcomeSharedMsgId, requestSharedMsgId, createdAt, updatedAt}
@@ -602,17 +606,18 @@ userQuery :: Query
userQuery =
[sql|
SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences,
u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes, uct.simplex_name
u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes,
ucp.badge_proof, ucp.badge_pres_header, ucp.badge_expiry, ucp.badge_type, ucp.badge_verified, ucp.badge_extra, ucp.badge_master_key, ucp.badge_signature, ucp.badge_key_idx, uct.simplex_name
FROM users u
JOIN contacts uct ON uct.contact_id = u.contact_id
JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id
|]
toUser :: (UserId, UserId, ContactId, ProfileId, BoolInt, Int64) :. (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime, BoolInt, BoolInt, Maybe UIThemeEntityOverrides, Maybe Text) -> User
toUser ((userId, auId, userContactId, profileId, BI activeUser, activeOrder) :. (displayName, fullName, shortDescr, image, contactLink, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, BI userChatRelay, BI clientService, uiThemes, simplexNameRaw)) =
toUser :: UTCTime -> (UserId, UserId, ContactId, ProfileId, BoolInt, Int64) :. (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime, BoolInt, BoolInt, Maybe UIThemeEntityOverrides) :. BadgeRow :. Only (Maybe Text) -> User
toUser now ((userId, auId, userContactId, profileId, BI activeUser, activeOrder) :. (displayName, fullName, shortDescr, image, contactLink, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, BI userChatRelay, BI clientService, uiThemes) :. badgeRow :. Only simplexNameRaw) =
User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, activeOrder, fullPreferences, showNtfs, sendRcptsContacts, sendRcptsSmallGroups, autoAcceptMemberContacts, viewPwdHash, userMemberProfileUpdatedAt, userChatRelay = BoolDef userChatRelay, clientService = BoolDef clientService, uiThemes}
where
profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName simplexNameRaw, peerType, preferences = userPreferences, localAlias = ""}
profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName simplexNameRaw, peerType, localBadge = rowToBadge now badgeRow, preferences = userPreferences, localAlias = ""}
fullPreferences = fullPreferences' userPreferences
viewPwdHash = UserPwdHash <$> viewPwdHash_ <*> viewPwdSalt_
@@ -728,17 +733,17 @@ type BusinessChatInfoRow = (Maybe BusinessChatType, Maybe MemberId, Maybe Member
type GroupKeysRow = (Maybe C.PrivateKeyEd25519, Maybe C.PublicKeyEd25519, Maybe C.PrivateKeyEd25519)
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Text, Maybe Text, Maybe ImageData, Maybe GroupType, Maybe ShortLinkContact, Maybe B64UrlByteString) :. PublicGroupAccessRow :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe GroupPreferences, Maybe GroupMemberAdmission) :. (UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime) :. PreparedGroupRow :. BusinessChatInfoRow :. (BoolInt, Maybe RelayStatus, Maybe UIThemeEntityOverrides, Int64, Maybe Int64, Maybe CustomData, Maybe Int64, Int, Maybe ConnReqContact) :. GroupKeysRow :. (Maybe Text, Maybe Text, Maybe UTCTime) :. GroupMemberRow
type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Text, Maybe Text, Maybe ImageData, Maybe GroupType, Maybe ShortLinkContact, Maybe B64UrlByteString) :. PublicGroupAccessRow :. (Maybe MsgFilter, Maybe BoolInt, BoolInt, Maybe GroupPreferences, Maybe GroupMemberAdmission) :. (UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime) :. PreparedGroupRow :. BusinessChatInfoRow :. (BoolInt, Maybe RelayStatus, Maybe UIThemeEntityOverrides, Int64, Maybe Int64, Maybe VersionRoster, Maybe CustomData, Maybe Int64, Int, Maybe ConnReqContact) :. GroupKeysRow :. (Maybe Text, Maybe Text, Maybe UTCTime) :. GroupMemberRow
type PublicGroupAccessRow = (Maybe Text, Maybe Text, Maybe BoolInt, Maybe BoolInt)
type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, VersionChat, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, BoolInt, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId) :. ProfileRow :. (UTCTime, UTCTime) :. (Maybe UTCTime, Int64, Int64, Int64, Maybe UTCTime, Maybe C.PublicKeyEd25519, Maybe ShortLinkContact)
type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Preferences, Maybe Text)
type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Preferences) :. BadgeRow :. Only (Maybe Text)
toGroupInfo :: StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
toGroupInfo 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, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri) :. groupKeysRow :. (gSimplexNameRaw, gpSimplexNameRaw, simplexNameVerifiedAt) :. userMemberRow) =
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr cxt}
toGroupInfo :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
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) :. groupKeysRow :. (gSimplexNameRaw, gpSimplexNameRaw, simplexNameVerifiedAt) :. 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)
@@ -752,7 +757,7 @@ toGroupInfo cxt userContactId chatTags ((groupId, localDisplayName, displayName,
businessChat = toBusinessChatInfo 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, customData, membersRequireAttention, viaGroupLinkUri, groupKeys, simplexName, simplexNameVerifiedAt}
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, simplexName, simplexNameVerifiedAt}
toPreparedGroup :: PreparedGroupRow -> Maybe PreparedGroup
toPreparedGroup = \case
@@ -786,9 +791,9 @@ toGroupKeys (Just publicGroupId) (rootPrivKey_, rootPubKey_, Just memberPrivKey)
<$> (GRKPrivate <$> rootPrivKey_ <|> GRKPublic <$> rootPubKey_)
toGroupKeys _ _ = Nothing
toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
toGroupMember 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)) =
let memberProfile = rowToLocalProfile profileRow
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)) =
let memberProfile = rowToLocalProfile now profileRow
memberSettings = GroupMemberSettings {showMessages}
blockedByAdmin = maybe False mrsBlocked memberRestriction_
invitedBy = toInvitedBy userContactId invitedById
@@ -812,7 +817,8 @@ groupMemberQuery =
[sql|
SELECT
m.group_member_id, m.group_id, m.index_in_group, m.member_id, m.peer_chat_min_version, m.peer_chat_max_version, m.member_role, m.member_category, m.member_status, m.show_messages, m.member_restriction,
m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences, p.simplex_name,
m.invited_by, m.invited_by_group_member_id, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.short_descr, p.image, p.contact_link, p.chat_peer_type, p.local_alias, p.preferences,
p.badge_proof, p.badge_pres_header, p.badge_expiry, p.badge_type, p.badge_verified, p.badge_extra, p.badge_master_key, p.badge_signature, p.badge_key_idx, p.simplex_name,
m.created_at, m.updated_at,
m.support_chat_ts, m.support_chat_items_unread, m.support_chat_items_member_attention, m.support_chat_items_mentions, m.support_chat_last_msg_from_member_ts, m.member_pub_key, m.relay_link,
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,
@@ -824,13 +830,13 @@ groupMemberQuery =
LEFT JOIN connections c ON c.group_member_id = m.group_member_id
|]
toContactMember :: StoreCxt -> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
toContactMember cxt User {userContactId} (memberRow :. connRow) =
(toGroupMember userContactId memberRow) {activeConn = toMaybeConnection cxt connRow}
toContactMember :: UTCTime -> StoreCxt -> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
toContactMember now cxt User {userContactId} (memberRow :. connRow) =
(toGroupMember now userContactId memberRow) {activeConn = toMaybeConnection cxt connRow}
rowToLocalProfile :: ProfileRow -> LocalProfile
rowToLocalProfile (profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, preferences, simplexNameRaw) =
LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName simplexNameRaw, peerType, localAlias, preferences}
rowToLocalProfile :: UTCTime -> ProfileRow -> LocalProfile
rowToLocalProfile now ((profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, preferences) :. badgeRow :. Only simplexNameRaw) =
LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName = decodeSimplexName simplexNameRaw, peerType, localBadge = rowToBadge now badgeRow, localAlias, preferences}
toBusinessChatInfo :: BusinessChatInfoRow -> Maybe BusinessChatInfo
toBusinessChatInfo (Just chatType, Just businessId, Just customerId) = Just BusinessChatInfo {chatType, businessId, customerId}
@@ -852,13 +858,14 @@ groupInfoQueryFields =
g.conn_full_link_to_connect, g.conn_short_link_to_connect, g.conn_link_prepared_connection, g.conn_link_started_connection, g.welcome_shared_msg_id, g.request_shared_msg_id,
g.business_chat, g.business_member_id, g.customer_member_id,
g.use_relays, g.relay_own_status,
g.ui_themes, g.summary_current_members_count, g.public_member_count, g.custom_data, g.chat_item_ttl, g.members_require_attention, g.via_group_link_uri,
g.ui_themes, g.summary_current_members_count, g.public_member_count, g.roster_version, g.custom_data, g.chat_item_ttl, g.members_require_attention, g.via_group_link_uri,
g.root_priv_key, g.root_pub_key, g.member_priv_key,
g.simplex_name, gp.simplex_name, g.simplex_name_verified_at,
-- GroupMember - membership
mu.group_member_id, mu.group_id, mu.index_in_group, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category,
mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id,
pu.display_name, pu.full_name, pu.short_descr, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences, pu.simplex_name,
pu.display_name, pu.full_name, pu.short_descr, pu.image, pu.contact_link, pu.chat_peer_type, pu.local_alias, pu.preferences,
pu.badge_proof, pu.badge_pres_header, pu.badge_expiry, pu.badge_type, pu.badge_verified, pu.badge_extra, pu.badge_master_key, pu.badge_signature, pu.badge_key_idx, pu.simplex_name,
mu.created_at, mu.updated_at,
mu.support_chat_ts, mu.support_chat_items_unread, mu.support_chat_items_member_attention, mu.support_chat_items_mentions, mu.support_chat_last_msg_from_member_ts, mu.member_pub_key, mu.relay_link
|]
@@ -947,8 +954,9 @@ addGroupChatTags db g@GroupInfo {groupId} = do
getGroupInfo :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db cxt User {userId, userContactId} groupId = ExceptT $ do
currentTs <- getCurrentTime
chatTags <- getGroupChatTags db groupId
firstRow (toGroupInfo cxt userContactId chatTags) (SEGroupNotFound groupId) $
firstRow (toGroupInfo currentTs cxt userContactId chatTags) (SEGroupNotFound groupId) $
DB.query
db
(groupInfoQuery <> " WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ?")
src/Simplex/Chat/Types.hs
+102 -14
View File
@@ -40,6 +40,7 @@ import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Functor (($>))
import Data.Int (Int64)
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
@@ -47,6 +48,8 @@ import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Typeable (Typeable)
import Data.Word (Word16)
import Simplex.Chat.Badges (BadgeInfo (..), BadgeProof (..), BadgeStatus (..), LocalBadge (..), localBadgeInfo, localBadgeStatus, mkBadgeStatus, verifyBadge)
import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Chat.Types.UITheme
@@ -375,7 +378,7 @@ data UserContactRequest = UserContactRequest
cReqChatVRange :: VersionRangeChat,
localDisplayName :: ContactName,
profileId :: Int64,
profile :: Profile,
profile :: LocalProfile,
createdAt :: UTCTime,
updatedAt :: UTCTime,
xContactId :: Maybe XContactId,
@@ -493,6 +496,7 @@ data GroupInfo = GroupInfo
uiThemes :: Maybe UIThemeEntityOverrides,
customData :: Maybe CustomData,
groupSummary :: GroupSummary,
rosterVersion :: Maybe VersionRoster,
membersRequireAttention :: Int,
viaGroupLinkUri :: Maybe ConnReqContact,
groupKeys :: Maybe GroupKeys,
@@ -647,6 +651,12 @@ groupFeatureUserAllowed :: GroupFeatureRoleI f => SGroupFeature f -> GroupInfo -
groupFeatureUserAllowed feature GroupInfo {membership = GroupMember {memberRole}, fullGroupPreferences} =
groupFeatureMemberAllowed' feature memberRole fullGroupPreferences
-- A connection link in a profile description enables a direct connection, so a description
-- keeps its links only when both SimpleX links and direct messages are allowed.
groupUserAllowSimplexLinks :: GroupInfo -> Bool
groupUserAllowSimplexLinks g =
groupFeatureUserAllowed SGFSimplexLinks g && groupFeatureUserAllowed SGFDirectMessages g
mergeUserChatPrefs :: User -> Contact -> FullPreferences
mergeUserChatPrefs user ct = mergeUserChatPrefs' user (contactConnIncognito ct) (userPreferences ct)
@@ -696,9 +706,10 @@ data Profile = Profile
shortDescr :: Maybe Text, -- short description limited to 160 characters
image :: Maybe ImageData,
contactLink :: Maybe ConnLinkContact,
simplexName :: Maybe SimplexNameInfo,
preferences :: Maybe Preferences,
peerType :: Maybe ChatPeerType
peerType :: Maybe ChatPeerType,
badge :: Maybe BadgeProof,
simplexName :: Maybe SimplexNameInfo
-- fields that should not be read into this data type to prevent sending them as part of profile to contacts:
-- - contact_profile_id
-- - incognito
@@ -731,7 +742,7 @@ instance TextEncoding ChatPeerType where
profileFromName :: ContactName -> Profile
profileFromName displayName =
Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, simplexName = Nothing, preferences = Nothing, peerType = Nothing}
Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, preferences = Nothing, peerType = Nothing, badge = Nothing, simplexName = Nothing}
-- check if profiles match ignoring preferences
profilesMatch :: LocalProfile -> LocalProfile -> Bool
@@ -740,6 +751,15 @@ profilesMatch
LocalProfile {displayName = n2, fullName = fn2, image = i2} =
n1 == n2 && fn1 == fn2 && i1 == i2
-- equal for profile-update detection: badge proofs are re-generated for every presentation,
-- so compare badges by disclosed info (not proof bytes) - a re-presentation of the same badge is a no-op
sameProfileContent :: Profile -> Profile -> Bool
sameProfileContent p@Profile {badge = b} p'@Profile {badge = b'} =
p {badge = Nothing} == p' {badge = Nothing} && (proofInfo <$> b) == (proofInfo <$> b')
where
proofInfo :: BadgeProof -> BadgeInfo
proofInfo (BadgeProof _ _ _ info) = info
data IncognitoProfile = NewIncognito Profile | ExistingIncognito LocalProfile
fromIncognitoProfile :: IncognitoProfile -> Profile
@@ -769,23 +789,48 @@ data LocalProfile = LocalProfile
shortDescr :: Maybe Text,
image :: Maybe ImageData,
contactLink :: Maybe ConnLinkContact,
simplexName :: Maybe SimplexNameInfo,
preferences :: Maybe Preferences,
peerType :: Maybe ChatPeerType,
localAlias :: LocalAlias
localBadge :: Maybe LocalBadge,
localAlias :: LocalAlias,
simplexName :: Maybe SimplexNameInfo
}
deriving (Eq, Show)
localProfileId :: LocalProfile -> ProfileId
localProfileId LocalProfile {profileId} = profileId
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> LocalProfile
toLocalProfile profileId Profile {displayName, fullName, shortDescr, image, contactLink, simplexName, preferences, peerType} localAlias =
LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, simplexName, preferences, peerType, localAlias}
toLocalProfile :: ProfileId -> Profile -> LocalAlias -> UTCTime -> Maybe Bool -> LocalProfile
toLocalProfile profileId Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge, simplexName} localAlias now verified =
LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, preferences, peerType, localBadge, localAlias, simplexName}
where
localBadge = (\b@(BadgeProof _ _ _ info) -> PeerBadge b (mkBadgeStatus now verified info)) <$> badge
fromLocalProfile :: LocalProfile -> Profile
fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contactLink, simplexName, preferences, peerType} =
Profile {displayName, fullName, shortDescr, image, contactLink, simplexName, preferences, peerType}
fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, localBadge, simplexName} =
Profile {displayName, fullName, shortDescr, image, contactLink, preferences, peerType, badge = localBadge >>= wireBadge, simplexName}
where
-- any stored peer proof rides the wire (receivers verify independently); the own credential is presented fresh, and a display-only badge never sends
wireBadge :: LocalBadge -> Maybe BadgeProof
wireBadge = \case
PeerBadge b _ -> Just b
OwnBadge _ _ -> Nothing
ShownBadge _ _ -> Nothing
profileBadgeVerified :: Map Int BBSPublicKey -> LocalProfile -> Profile -> IO (Maybe Bool)
profileBadgeVerified keys LocalProfile {localBadge} Profile {badge = newBadge} =
case (localBadge, newBadge) of
(_, Nothing) -> pure (Just False)
-- an unchanged badge that verified before stays verified; failed or unknown-key badges
-- are re-verified, so an unknown key heals once an app update adds it
(Just lb, Just (BadgeProof _ _ _ newInfo))
| localBadgeInfo lb == newInfo && localBadgeStatus lb `notElem` [BSFailed, BSUnknownKey] -> pure (Just True)
(_, Just newB) -> verifyBadge keys newB
-- a failed or unknown-key badge is re-verified on the next profile update even when its disclosed content
-- is unchanged, so it heals once an app update adds the issuer key
badgeNeedsReverify :: LocalProfile -> Bool
badgeNeedsReverify LocalProfile {localBadge} = maybe False ((`elem` [BSFailed, BSUnknownKey]) . localBadgeStatus) localBadge
data GroupType
= GTChannel
@@ -856,8 +901,13 @@ instance FromJSON ImageData where
parseJSON = fmap ImageData . J.parseJSON
instance ToJSON ImageData where
toJSON (ImageData t) = J.toJSON t
toEncoding (ImageData t) = J.toEncoding t
toJSON (ImageData t) = J.toJSON $ safeImageData t
toEncoding (ImageData t) = J.toEncoding $ safeImageData t
safeImageData :: Text -> Text
safeImageData t
| "data:" `T.isPrefixOf` t = t
| otherwise = ""
instance ToField ImageData where toField (ImageData t) = toField t
@@ -985,6 +1035,11 @@ newtype MemberKey = MemberKey C.PublicKeyEd25519
deriving (Eq, Show)
deriving newtype (StrEncoding)
-- Binary encoding for the roster blob; delegates to the Ed25519 key.
instance Encoding MemberKey where
smpEncode (MemberKey k) = smpEncode k
smpP = MemberKey <$> smpP
instance FromJSON MemberKey where
parseJSON = strParseJSON "MemberKey"
@@ -1506,11 +1561,38 @@ instance ToJSON InlineFileMode where
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
-- Discriminates ordinary chat files from the roster blob file, so the receive
-- completion / cancel paths branch on the type rather than on chat_item_id (note
-- folders and redirects also lack a chat item).
data FileType = FTNormal | FTRoster
deriving (Eq, Show)
instance TextEncoding FileType where
textEncode = \case
FTNormal -> "normal"
FTRoster -> "roster"
textDecode = \case
"normal" -> Just FTNormal
"roster" -> Just FTRoster
_ -> Nothing
instance FromField FileType where fromField = fromTextField_ textDecode
instance ToField FileType where toField = toField . textEncode
instance FromJSON FileType where
parseJSON = textParseJSON "FileType"
instance ToJSON FileType where
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
data RcvFileTransfer = RcvFileTransfer
{ fileId :: FileTransferId,
xftpRcvFile :: Maybe XFTPRcvFile,
fileInvitation :: FileInvitation,
fileStatus :: RcvFileStatus,
fileType :: FileType,
rcvFileInline :: Maybe InlineFileMode,
senderDisplayName :: ContactName,
chunkSize :: Integer,
@@ -2051,11 +2133,17 @@ 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.
newtype StoreCxt = StoreCxt {vr :: VersionRangeChat}
data StoreCxt = StoreCxt {vr :: VersionRangeChat, badgeKeys :: Map Int BBSPublicKey}
pattern VersionChat :: Word16 -> VersionChat
pattern VersionChat v = Version v
-- A monotonic per-change counter, not a negotiated protocol version: Int64 rather than the Word16 of
-- Version, so a long-lived high-churn channel cannot wrap and be permanently rejected by relays (v >= cur).
newtype VersionRoster = VersionRoster Int64
deriving (Eq, Ord, Show)
deriving newtype (FromJSON, ToJSON, FromField, ToField)
-- this newtype exists to have a concise JSON encoding of version ranges in chat protocol messages in the form of "1-2" or just "1"
newtype ChatVersionRange = ChatVersionRange {fromChatVRange :: VersionRangeChat} deriving (Eq, Show)
src/Simplex/Chat/Types/Shared.hs
+11
View File
@@ -11,6 +11,7 @@ import qualified Data.ByteString.Char8 as B
import Data.Text (Text)
import Simplex.Chat.Options.DB (FromField (..), ToField (..))
import Simplex.Messaging.Agent.Store.DB (fromTextField_)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
import Simplex.Messaging.Util ((<$?>))
@@ -57,6 +58,12 @@ instance ToJSON GroupMemberRole where
toJSON = textToJSON
toEncoding = textToEncoding
-- Binary encoding for the roster blob; delegates to the canonical TextEncoding
-- (same member/moderator/admin form JSON and the DB use). GRUnknown round-trips.
instance Encoding GroupMemberRole where
smpEncode = smpEncode . textEncode
smpP = maybe (fail "bad GroupMemberRole") pure . textDecode =<< smpP
data GroupAcceptance = GAAccepted | GAPendingApproval | GAPendingReview deriving (Eq, Show)
instance StrEncoding GroupAcceptance where
@@ -82,6 +89,7 @@ data RelayStatus
= RSNew -- only for owner
| RSInvited
| RSAccepted
| RSAcknowledgedRoster
| RSActive
| RSInactive
| RSRejected
@@ -92,6 +100,7 @@ relayStatusText = \case
RSNew -> "new"
RSInvited -> "invited"
RSAccepted -> "accepted"
RSAcknowledgedRoster -> "acknowledged_roster"
RSActive -> "active"
RSInactive -> "inactive"
RSRejected -> "rejected"
@@ -101,6 +110,7 @@ instance TextEncoding RelayStatus where
RSNew -> "new"
RSInvited -> "invited"
RSAccepted -> "accepted"
RSAcknowledgedRoster -> "acknowledged_roster"
RSActive -> "active"
RSInactive -> "inactive"
RSRejected -> "rejected"
@@ -108,6 +118,7 @@ instance TextEncoding RelayStatus where
"new" -> Just RSNew
"invited" -> Just RSInvited
"accepted" -> Just RSAccepted
"acknowledged_roster" -> Just RSAcknowledgedRoster
"active" -> Just RSActive
"inactive" -> Just RSInactive
"rejected" -> Just RSRejected
src/Simplex/Chat/View.hs
+84 -18
View File
@@ -43,6 +43,7 @@ import Simplex.Chat.Controller
import Simplex.Chat.Help
import Simplex.Chat.Library.Commands (maxImageSize)
import Simplex.Chat.Markdown
import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus)
import Simplex.Chat.Messages hiding (NewChatItem (..))
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Operators
@@ -111,7 +112,7 @@ chatErrorToView isCmd ChatConfig {logLevel, testView} = viewChatError isCmd logL
chatResponseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString]
chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveItems ts tz outputRH = \case
CRActiveUser User {profile, uiThemes} -> viewUserProfile (fromLocalProfile profile) <> viewUITheme uiThemes
CRActiveUser User {profile = p@LocalProfile {localBadge}, uiThemes} -> viewUserProfile localBadge (fromLocalProfile p) <> viewUITheme uiThemes
CRUsersList users -> viewUsersList users
CRChatStarted -> ["chat started"]
CRChatRunning -> ["chat is running"]
@@ -194,7 +195,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
CRSentGroupInvitation u g c _ -> ttyUser u $ viewSentGroupInvitation g c
CRFileTransferStatus u ftStatus -> ttyUser u $ viewFileTransferStatus ftStatus
CRFileTransferStatusXFTP u ci -> ttyUser u $ viewFileTransferStatusXFTP ci
CRUserProfile u p -> ttyUser u $ viewUserProfile p
CRUserProfile u@User {profile = LocalProfile {localBadge}} p -> ttyUser u $ viewUserProfile localBadge p
CRUserProfileNoChange u -> ttyUser u ["user profile did not change"]
CRUserPrivacy u u' -> ttyUserPrefix hu outputRH u $ viewUserPrivacy u u'
CRVersionInfo info _ _ -> viewVersionInfo logLevel info
@@ -453,7 +454,7 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
CEvtRcvFileProgressXFTP {} -> []
CEvtContactUpdated {user = u, fromContact = c, toContact = c'} -> ttyUser u $ viewContactUpdated c c' <> viewContactPrefsUpdated u c c'
CEvtGroupMemberUpdated {} -> []
CEvtReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} _chat -> ttyUser u $ viewReceivedContactRequest c profile
CEvtReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} _chat -> ttyUser u $ viewReceivedContactRequest c (fromLocalProfile profile)
CEvtRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci
CEvtRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci
CEvtRcvStandaloneFileComplete u _ ft -> ttyUser u $ receivingFileStandalone "completed" ft
@@ -620,8 +621,8 @@ viewUsersList us =
in if null ss then ["no users"] else ss
where
ldn (UserInfo User {localDisplayName = n} _) = T.toLower n
userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName, shortDescr, peerType}, activeUser, showNtfs, viewPwdHash, clientService} count)
| activeUser || isNothing viewPwdHash = Just $ ttyFullName n fullName shortDescr <> infoStr <> bot
userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName, shortDescr, peerType, localBadge}, activeUser, showNtfs, viewPwdHash, clientService} count)
| activeUser || isNothing viewPwdHash = Just $ ttyFullNameBadge n fullName shortDescr localBadge <> infoStr <> bot
| otherwise = Nothing
where
infoStr = if null info then "" else " (" <> mconcat (intersperse ", " info) <> ")"
@@ -1214,8 +1215,8 @@ viewReceivedContactRequest c Profile {fullName, shortDescr} =
]
showRelay :: GroupRelay -> StyledString
showRelay GroupRelay {groupRelayId, relayStatus} =
" - relay id " <> sShow groupRelayId <> ": " <> plain (relayStatusText relayStatus)
showRelay GroupRelay {groupRelayId, relayStatus, relayCap = RelayCapabilities {webDomain}} =
" - relay id " <> sShow groupRelayId <> ": " <> plain (relayStatusText relayStatus) <> maybe "" (\d -> ", web: " <> plain d) webDomain
viewGroupRelays :: GroupInfo -> [GroupRelay] -> [StyledString]
viewGroupRelays g relays =
@@ -1517,9 +1518,9 @@ viewContactAndMemberAssociated ct g m ct' =
"use " <> ttyToContact' ct' <> highlight' "<message>" <> " to send messages"
]
viewUserProfile :: Profile -> [StyledString]
viewUserProfile Profile {displayName, fullName, shortDescr, peerType, preferences} =
[ "user profile: " <> ttyFullName displayName fullName shortDescr <> bot,
viewUserProfile :: Maybe LocalBadge -> Profile -> [StyledString]
viewUserProfile localBadge Profile {displayName, fullName, shortDescr, peerType, preferences} =
[ "user profile: " <> ttyFullNameBadge displayName fullName shortDescr localBadge <> bot,
"use " <> highlight' "/p <name> [<bio>]" <> " to change it"
]
++ viewCommands
@@ -1772,9 +1773,22 @@ smpProxyModeStr :: SMPProxyMode -> SMPProxyFallback -> String
smpProxyModeStr SPMNever _ = "private message routing disabled."
smpProxyModeStr mode fallback = T.unpack $ safeDecodeUtf8 $ "private message routing mode: " <> strEncode mode <> ", fallback: " <> strEncode fallback
viewContactBadge :: Maybe LocalBadge -> [StyledString]
viewContactBadge = maybe [] $ \lb ->
let BadgeInfo {badgeType, badgeExpiry} = localBadgeInfo lb
st = case localBadgeStatus lb of
BSActive -> "active"
BSExpired -> "expired"
BSExpiredOld -> "expired (old)"
BSFailed -> "verification failed"
BSUnknownKey -> "unknown key"
expiry = maybe "no expiry" (("expires " <>) . T.pack . formatTime defaultTimeLocale "%Y-%m-%d") badgeExpiry
in [plain (textEncode badgeType <> " badge - " <> st), plain expiry]
viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString]
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn, uiThemes, customData, simplexName} stats incognitoProfile =
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink, localBadge}, activeConn, uiThemes, customData, simplexName} stats incognitoProfile =
["contact ID: " <> sShow contactId]
<> viewContactBadge localBadge
<> maybe [] viewConnectionStats stats
<> maybe [] (\l -> ["contact address: " <> plain (shareLinkStr simplexName (strEncode (simplexChatContact' l)))]) contactLink
<> maybe
@@ -1807,10 +1821,11 @@ viewCustomData :: Maybe CustomData -> [StyledString]
viewCustomData = maybe [] (\(CustomData v) -> ["custom data: " <> viewJSON (J.Object v)])
viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString]
viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias, contactLink}, activeConn} stats =
viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias, contactLink, localBadge}, activeConn} stats =
[ "group ID: " <> sShow groupId,
"member ID: " <> sShow groupMemberId
]
<> viewContactBadge localBadge
<> maybe ["member not connected"] viewConnectionStats stats
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact' l)]) contactLink
<> ["alias: " <> plain localAlias | localAlias /= ""]
@@ -1975,10 +1990,10 @@ countactUserPrefText cup = case cup of
viewGroupUpdated :: GroupInfo -> GroupInfo -> Maybe GroupMember -> Maybe MsgSigStatus -> [StyledString]
viewGroupUpdated
GroupInfo {localDisplayName = n, groupProfile = GroupProfile {fullName, shortDescr, description, image, groupPreferences = gps, memberAdmission = ma}}
g'@GroupInfo {localDisplayName = n', groupProfile = GroupProfile {fullName = fullName', shortDescr = shortDescr', description = description', image = image', groupPreferences = gps', memberAdmission = ma'}}
GroupInfo {localDisplayName = n, groupProfile = GroupProfile {fullName, shortDescr, description, image, groupPreferences = gps, memberAdmission = ma, publicGroup = pg}}
g'@GroupInfo {localDisplayName = n', groupProfile = GroupProfile {fullName = fullName', shortDescr = shortDescr', description = description', image = image', groupPreferences = gps', memberAdmission = ma', publicGroup = pg'}}
m signed = do
let update = groupProfileUpdated <> groupPrefsUpdated <> memberAdmissionUpdated
let update = groupProfileUpdated <> groupPrefsUpdated <> memberAdmissionUpdated <> publicGroupAccessUpdated
if null update
then []
else memberUpdated <> update
@@ -2003,6 +2018,18 @@ viewGroupUpdated
memberAdmissionUpdated
| ma == ma' = []
| otherwise = ["changed member admission rules"]
publicGroupAccessUpdated
| access == access' = []
| otherwise = ["updated public group access:" <> viewAccess access']
where
access = pg >>= publicGroupAccess
access' = pg' >>= publicGroupAccess
viewAccess Nothing = " removed"
viewAccess (Just PublicGroupAccess {groupWebPage, groupDomain, domainWebPage, allowEmbedding}) =
maybe "" (\u -> " web=" <> plain u) groupWebPage
<> maybe "" (\d -> " domain=" <> plain d) groupDomain
<> (if domainWebPage then " domain_page=on" else "")
<> (if allowEmbedding then " embed=on" else "")
viewGroupProfile :: GroupInfo -> [StyledString]
viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {shortDescr, description, image, groupPreferences = gps}} =
@@ -2808,9 +2835,47 @@ ttyContact = styled (colored Green) . viewName
ttyContact' :: Contact -> StyledString
ttyContact' Contact {localDisplayName = c} = ttyContact c
-- Supporter badge: a colored star marks an active badge (only the star is colored).
-- supporter cyan, legend blue, investor yellow, unknown cyan; business has no star.
badgeStarColor :: BadgeType -> Maybe Color
badgeStarColor = \case
BTSupporter -> Just Cyan
BTLegend -> Just Blue
BTInvestor -> Just Yellow
BTUnknown _ -> Just Cyan
-- (star color, type word) for an active, colorable badge
activeBadge :: Maybe LocalBadge -> Maybe (Color, Text)
activeBadge lb_ = do
lb <- lb_
case localBadgeStatus lb of
BSActive -> let BadgeInfo {badgeType} = localBadgeInfo lb in (\col -> (col, textEncode badgeType)) <$> badgeStarColor badgeType
_ -> Nothing
badgeStar :: Color -> StyledString
badgeStar col = styled (colored col) ("*" :: Text)
-- " *" (space + colored star) for sender prefixes, "" if no active badge
badgeStarSep :: Maybe LocalBadge -> StyledString
badgeStarSep lb_ = maybe "" (\(c, _) -> " " <> badgeStar c) (activeBadge lb_)
-- name + badge for full-name contexts: "alice (Alice, * supporter)" / "alice (* supporter)" / "alice (Alice)" / "alice"
ttyFullNameBadge :: ContactName -> Text -> Maybe Text -> Maybe LocalBadge -> StyledString
ttyFullNameBadge c fullName shortDescr lb_ = ttyContact c <> optFullNameBadge c fullName shortDescr lb_
optFullNameBadge :: ContactName -> Text -> Maybe Text -> Maybe LocalBadge -> StyledString
optFullNameBadge c fullName shortDescr lb_ = case activeBadge lb_ of
Nothing -> optFullName c fullName shortDescr
Just (color, typeWord) -> " (" <> nameInner <> badgeStar color <> plain (" " <> typeWord) <> ")"
where
nameInner = maybe "" (\t -> plain (t <> ", ")) innerName
innerName
| T.null fullName || c == fullName = shortDescr
| otherwise = Just fullName
ttyFullContact :: Contact -> StyledString
ttyFullContact Contact {localDisplayName, profile = LocalProfile {fullName, shortDescr}} =
ttyFullName localDisplayName fullName shortDescr
ttyFullContact Contact {localDisplayName, profile = LocalProfile {fullName, shortDescr, localBadge}} =
ttyFullNameBadge localDisplayName fullName shortDescr localBadge
ttyMember :: GroupMember -> StyledString
ttyMember GroupMember {localDisplayName} = ttyContact localDisplayName
@@ -2839,7 +2904,8 @@ ttyQuotedMember (Just GroupMember {localDisplayName = c}) = "> " <> ttyFrom (vie
ttyQuotedMember Nothing = ">"
ttyFromContact :: Contact -> StyledString
ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> ")
ttyFromContact ct@Contact {localDisplayName = c, profile = LocalProfile {localBadge}} =
ctIncognito ct <> ttyFrom (viewName c) <> badgeStarSep localBadge <> ttyFrom "> "
ttyFromContactEdited :: Contact -> StyledString
ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> [edited] ")
src/Simplex/Chat/Web.hs
+435
View File
@@ -0,0 +1,435 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
module Simplex.Chat.Web
( WebChannelPreview (..),
WebMessage (..),
WebMemberProfile (..),
WebFileInfo (..),
webPreviewWorker,
writeCorsConfig,
removeStaleFiles,
channelContentChanged,
channelProfileUpdated,
channelRemoved,
extractOrigin,
)
where
import Control.Concurrent.STM (check, flushTQueue)
import Control.Exception (SomeException, catch)
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except (runExceptT)
import Data.Either (rights)
import Data.Int (Int64)
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Maybe (isJust, mapMaybe, maybeToList)
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.Markdown (FormattedText (..), MarkdownList, parseMaybeMarkdownList)
import Simplex.Chat.Messages
( CChatItem (..),
CIDirection (..),
CIFile (..),
CIMeta (..),
CIQDirection (..),
CIQuote (..),
CIReactionCount,
ChatItem (..),
ChatType (..),
)
import Simplex.Chat.Messages.CIContent (ciMsgContent)
import Simplex.Chat.Protocol (MsgContent, MsgRef (..), QuotedMsg (..), isReport)
import Simplex.Chat.Store.Groups (getGroupOwners, getRelayPublishableGroups, updatePublicMemberCount)
import Simplex.Chat.Store.Messages (getGroupWebPreviewItems)
import Simplex.Chat.Store.Shared (getGroupInfo)
import Simplex.Chat.Types
( B64UrlByteString,
GroupInfo (..),
GroupMember (..),
GroupProfile (..),
GroupSummary (..),
ImageData,
LocalProfile (..),
MemberId,
PublicGroupAccess (..),
PublicGroupProfile (..),
User (..),
)
import Simplex.Messaging.Agent.Store.Common (withTransaction)
import Simplex.Messaging.Encoding.String (strEncode)
import Simplex.Messaging.Util (catchOwn, eitherToMaybe, safeDecodeUtf8, tshow)
import Simplex.Messaging.Parsers (defaultJSON)
import System.Directory (createDirectoryIfMissing, listDirectory, removeFile, renameFile)
import System.FilePath (dropExtension, takeExtension, (</>))
import qualified URI.ByteString as U
import UnliftIO.STM
data WebFileInfo = WebFileInfo
{ fileName :: String,
fileSize :: Integer
}
deriving (Show)
data WebMemberProfile = WebMemberProfile
{ memberId :: MemberId,
displayName :: Text,
image :: Maybe ImageData
}
deriving (Show)
data WebMessage = WebMessage
{ sender :: Maybe MemberId,
ts :: UTCTime,
content :: MsgContent,
formattedText :: Maybe MarkdownList,
file :: Maybe WebFileInfo,
quote :: Maybe QuotedMsg,
reactions :: [CIReactionCount],
forward :: Maybe Bool,
edited :: Bool
}
deriving (Show)
data WebChannelPreview = WebChannelPreview
{ channel :: GroupProfile,
shortDescription :: Maybe MarkdownList,
welcomeMessage :: Maybe MarkdownList,
members :: [WebMemberProfile],
subscribers :: Maybe Int64,
messages :: [WebMessage],
updatedAt :: UTCTime
}
deriving (Show)
$(JQ.deriveJSON defaultJSON ''WebFileInfo)
$(JQ.deriveJSON defaultJSON ''WebMemberProfile)
$(JQ.deriveJSON defaultJSON ''WebMessage)
$(JQ.deriveJSON defaultJSON ''WebChannelPreview)
webPreviewWorker :: WebPreviewConfig -> ChatController -> [User] -> IO ()
webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterval} cc users =
forM_ (webPreviewState cc) $ \wps -> do
createDirectoryIfMissing True webJsonDir
initPublishableGroups wps
cleanStaleFiles wps
regenerateCors wps
seedRoutinePending wps
forever $ workerLoop wps `catchOwn` \e -> logError ("web preview worker error: " <> tshow e)
where
cxt = mkStoreCxt (config cc)
workerLoop wps@WebPreviewState {priorityRender, filesToRemove, corsNeeded, routinePending, wakeSignal} = do
drainRemovals
drainPriority
handleCors
renderRoutine
noRoutine <- atomically $ S.null <$> readTVar routinePending
when noRoutine waitRefresh
where
drainRemovals = atomically (tryReadTQueue filesToRemove) >>= \case
Nothing -> pure ()
Just f -> do
removeFile (webJsonDir </> f) `catch` \(_ :: SomeException) -> pure ()
drainRemovals
-- flush the whole queue and render each group once: a burst of changes in one
-- channel enqueues its id many times, but only needs a single render
drainPriority = do
gIds <- atomically $ flushTQueue priorityRender
forM_ (S.fromList gIds) $ renderOneGroup wps
handleCors = do
needed <- atomically $ swapTVar corsNeeded False
when needed $ regenerateCors wps
-- render a single routine item; the main loop calls this once per iteration
renderRoutine = do
mGId <- atomically $ do
pending <- readTVar routinePending
case S.minView pending of
Nothing -> pure Nothing
Just (gId, rest) -> writeTVar routinePending rest >> pure (Just gId)
forM_ mGId $ renderOneGroup wps
-- routine list drained: wait for the refresh timer or a change signal; only the timer
-- seeds the next full sweep, a change just returns to let the main loop service it
waitRefresh = do
delay <- registerDelay (webUpdateInterval * 1000000)
timerFired <- atomically $
(True <$ (readTVar delay >>= check)) `orElse` (False <$ takeTMVar wakeSignal)
when timerFired $ seedRoutinePending wps
initPublishableGroups WebPreviewState {publishableGroupIds} = do
rows <- withTransaction (chatStore cc) $ \db ->
concat <$> mapM (getRelayPublishableGroups db) users
let gIds = M.fromList [(gId, toPublishableGroup pgId access) | (gId, pgId, access) <- rows]
atomically $ writeTVar publishableGroupIds gIds
cleanStaleFiles WebPreviewState {publishableGroupIds} = do
ids <- readTVarIO publishableGroupIds
let activeFiles = S.fromList $ map pgFileName $ M.elems ids
removeStaleFiles webJsonDir activeFiles
regenerateCors WebPreviewState {publishableGroupIds} = do
ids <- readTVarIO publishableGroupIds
let entries = mapMaybe pgCorsEntry $ M.elems ids
forM_ webCorsFile $ writeCorsConfig entries
seedRoutinePending WebPreviewState {publishableGroupIds, routinePending} =
atomically $ M.keysSet <$> readTVar publishableGroupIds >>= writeTVar routinePending
renderOneGroup WebPreviewState {publishableGroupIds} gId = do
publishable <- atomically $ M.member gId <$> readTVar publishableGroupIds
when publishable $
renderOrRemoveStale `catch` \(e :: SomeException) ->
logError $ "web preview: error rendering group " <> T.pack (show gId) <> ": " <> T.pack (show e)
where
renderOrRemoveStale = do
r <- withTransaction (chatStore cc) $ \db ->
findUser $ \u -> fmap (\g -> (u, g)) <$> runExceptT (getGroupInfo db cxt u gId)
case r of
Just (u, gInfo) | hasPublicGroup gInfo ->
void $ renderGroupPreview cfg cc u gInfo
_ -> do
fName <- atomically $ do
pg <- M.lookup gId <$> readTVar publishableGroupIds
modifyTVar' publishableGroupIds (M.delete gId)
pure $ pgFileName <$> pg
forM_ fName $ \f ->
removeFile (webJsonDir </> f) `catch` \(_ :: SomeException) -> pure ()
logInfo $ "web preview: group " <> T.pack (show gId) <> " no longer publishable"
findUser f = go users
where
go [] = pure Nothing
go (u : us) = f u >>= \case
Right a -> pure (Just a)
Left _ -> go us
renderGroupPreview :: WebPreviewConfig -> ChatController -> User -> GroupInfo -> IO (Maybe (Text, CorsOrigin))
renderGroupPreview WebPreviewConfig {webJsonDir, webPreviewItemCount} cc user gInfo@GroupInfo {groupProfile = gp@GroupProfile {shortDescr = sd, description = wd, publicGroup}, groupSummary = GroupSummary {publicMemberCount}} =
case publicGroup of
Just PublicGroupProfile {publicGroupId, publicGroupAccess} -> do
let fName = publicGroupIdFileName publicGroupId <> ".json"
-- backfill the subscriber count for channels created before it was tracked
subscribers <- case publicMemberCount of
Just _ -> pure publicMemberCount
Nothing -> do
g_ <- withTransaction (chatStore cc) (\db -> runExceptT $ updatePublicMemberCount db cxt user gInfo)
pure $ eitherToMaybe g_ >>= \GroupInfo {groupSummary = GroupSummary {publicMemberCount = pmc}} -> pmc
(items, owners) <- withTransaction (chatStore cc) $ \db -> do
is <- getGroupWebPreviewItems db user gInfo webPreviewItemCount
os <- getGroupOwners db cxt user gInfo
pure (is, os)
ts <- getCurrentTime
let rendered = mapMaybe toRenderedItem $ rights items
msgs = map fst rendered
senders = collectSenders $ map memberToProfile owners <> concatMap snd rendered
preview = WebChannelPreview
{ channel = gp,
shortDescription = toFormattedText =<< sd,
welcomeMessage = toFormattedText =<< wd,
members = senders,
subscribers,
messages = msgs,
updatedAt = ts
}
let destPath = webJsonDir </> fName
tmpPath = destPath <> ".tmp"
LB.writeFile tmpPath (J.encode preview)
renameFile tmpPath destPath
pure $ corsEntry publicGroupId <$> publicGroupAccess
Nothing -> pure Nothing
where
cxt = mkStoreCxt (config cc)
channelContentChanged :: ChatController -> Int64 -> STM ()
channelContentChanged cc gId =
forM_ (webPreviewState cc) $ \WebPreviewState {publishableGroupIds, priorityRender, routinePending, wakeSignal} -> do
ids <- readTVar publishableGroupIds
when (M.member gId ids) $ do
writeTQueue priorityRender gId
modifyTVar' routinePending (S.delete gId)
void $ tryPutTMVar wakeSignal ()
channelProfileUpdated :: ChatController -> Int64 -> GroupProfile -> STM ()
channelProfileUpdated cc gId GroupProfile {publicGroup} =
forM_ (webPreviewState cc) $ \WebPreviewState {publishableGroupIds, priorityRender, filesToRemove, corsNeeded, routinePending, wakeSignal} ->
case publicGroup of
Just PublicGroupProfile {publicGroupId, publicGroupAccess} -> do
let pg = PublishableGroup
{ pgFileName = publicGroupIdFileName publicGroupId <> ".json",
pgCorsEntry = corsEntry publicGroupId <$> publicGroupAccess
}
modifyTVar' publishableGroupIds (M.insert gId pg)
writeTQueue priorityRender gId
modifyTVar' routinePending (S.delete gId)
writeTVar corsNeeded True
void $ tryPutTMVar wakeSignal ()
Nothing -> do
ids <- readTVar publishableGroupIds
forM_ (pgFileName <$> M.lookup gId ids) $ writeTQueue filesToRemove
modifyTVar' publishableGroupIds (M.delete gId)
modifyTVar' routinePending (S.delete gId)
writeTVar corsNeeded True
void $ tryPutTMVar wakeSignal ()
channelRemoved :: ChatController -> Int64 -> STM ()
channelRemoved cc gId =
forM_ (webPreviewState cc) $ \WebPreviewState {publishableGroupIds, filesToRemove, corsNeeded, routinePending, wakeSignal} -> do
ids <- readTVar publishableGroupIds
forM_ (pgFileName <$> M.lookup gId ids) $ writeTQueue filesToRemove
modifyTVar' publishableGroupIds (M.delete gId)
modifyTVar' routinePending (S.delete gId)
writeTVar corsNeeded True
void $ tryPutTMVar wakeSignal ()
toRenderedItem :: CChatItem 'CTGroup -> Maybe (WebMessage, [WebMemberProfile])
toRenderedItem (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemTs, itemTimed, itemForwarded, itemEdited}, content, formattedText, quotedItem, reactions, file})
| isJust itemTimed = Nothing
| otherwise = case ciMsgContent content of
Just mc | not (isReport mc) ->
let (sender, senderProfile) = case chatDir of
CIGroupRcv m@GroupMember {memberId} -> (Just memberId, [memberToProfile m])
_ -> (Nothing, [])
quotedProfile = case quotedItem of
Just CIQuote {chatDir = CIQGroupRcv (Just m)} -> [memberToProfile m]
_ -> []
in Just
( WebMessage
{ sender,
ts = itemTs,
content = mc,
formattedText,
file = webFileInfo <$> file,
quote = quotedItem >>= ciQuoteToQuotedMsg,
reactions,
forward = if isJust itemForwarded then Just True else Nothing,
edited = itemEdited
},
senderProfile <> quotedProfile
)
_ -> Nothing
ciQuoteToQuotedMsg :: CIQuote c -> Maybe QuotedMsg
ciQuoteToQuotedMsg CIQuote {chatDir = qDir, sharedMsgId, sentAt, content = qContent} =
Just QuotedMsg
{ msgRef = MsgRef
{ msgId = sharedMsgId,
sentAt,
sent = case qDir of
CIQDirectSnd -> True
CIQGroupSnd -> True
_ -> False,
memberId = case qDir of
CIQGroupRcv (Just GroupMember {memberId}) -> Just memberId
_ -> Nothing
},
content = qContent
}
webFileInfo :: CIFile d -> WebFileInfo
webFileInfo CIFile {fileName, fileSize} = WebFileInfo {fileName, fileSize}
collectSenders :: [WebMemberProfile] -> [WebMemberProfile]
collectSenders = M.elems . M.fromList . map (\p@WebMemberProfile {memberId} -> (memberId, p))
memberToProfile :: GroupMember -> WebMemberProfile
memberToProfile GroupMember {memberId, memberProfile = LocalProfile {displayName, image}} =
WebMemberProfile {memberId, displayName, image}
toPublishableGroup :: B64UrlByteString -> Maybe PublicGroupAccess -> PublishableGroup
toPublishableGroup pgId access =
PublishableGroup
{ pgFileName = publicGroupIdFileName pgId <> ".json",
pgCorsEntry = corsEntry pgId <$> access
}
corsEntry :: B64UrlByteString -> PublicGroupAccess -> (Text, CorsOrigin)
corsEntry publicGroupId PublicGroupAccess {groupWebPage, allowEmbedding} =
let fName = T.pack $ publicGroupIdFileName publicGroupId <> ".json"
origin
| allowEmbedding = CorsAny
| otherwise = CorsOrigins $ mapMaybe extractOrigin $ maybeToList groupWebPage
in (fName, origin)
extractOrigin :: Text -> Maybe Text
extractOrigin url =
case U.parseURI U.laxURIParserOptions (encodeUtf8 url) of
Right uri@U.URI {uriScheme = U.Scheme sch, uriAuthority = Just _}
| sch == "https" || sch == "http" ->
let originUri = uri {U.uriPath = "", U.uriQuery = U.Query [], U.uriFragment = Nothing}
origin = safeDecodeUtf8 $ U.serializeURIRef' originUri
in if T.all safeOriginChar origin then Just origin else Nothing
_ -> Nothing
where
-- percent-encoded bytes in the host (e.g. %22, %0a) are decoded by serializeURIRef',
-- so reject any origin with characters that could break out of the Caddy CORS config or header
safeOriginChar c =
(c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c `elem` (".-:/[]" :: [Char])
channelPath :: Text
channelPath = "/channel/"
writeCorsConfig :: [(Text, CorsOrigin)] -> FilePath -> IO ()
writeCorsConfig entries path =
TIO.writeFile path $ T.unlines $
["map {path} {cors_origin} {"]
<> map corsLine entries
<> [ " default \"\"",
"}",
"header " <> channelPath <> "*.json Access-Control-Allow-Origin {cors_origin}",
"header " <> channelPath <> "*.json Access-Control-Allow-Methods \"GET, OPTIONS\""
]
where
corsLine (fName, origin) = case origin of
CorsAny -> " " <> channelPath <> fName <> " \"*\""
CorsOrigins origins -> case origins of
[] -> " # " <> fName <> " (no origin configured)"
(o : _) -> " " <> channelPath <> fName <> " \"" <> o <> "\""
removeStaleFiles :: FilePath -> S.Set FilePath -> IO ()
removeStaleFiles dir activeFiles = do
let -- matches "<base64url>.json" and leftover "<base64url>.json.tmp" from an interrupted write
isPreviewFile f =
let f' = if takeExtension f == ".tmp" then dropExtension f else f
base = dropExtension f'
in takeExtension f' == ".json" && not (null base) && all isBase64Url base
isBase64Url c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') || (c >= '0' && c <= '9') || c == '-' || c == '_'
allFiles <- S.filter isPreviewFile . S.fromList <$> listDirectory dir
mapM_ (\f -> removeFile (dir </> f)) $ S.difference allFiles activeFiles
toFormattedText :: Text -> Maybe MarkdownList
toFormattedText t = case parseMaybeMarkdownList t of
Just fts | any hasFormat fts -> Just fts
_ -> Nothing
where
hasFormat (FormattedText fmt _) = isJust fmt
publicGroupIdFileName :: B64UrlByteString -> String
publicGroupIdFileName = B.unpack . strEncode
hasPublicGroup :: GroupInfo -> Bool
hasPublicGroup GroupInfo {groupProfile = GroupProfile {publicGroup}} = isJust publicGroup