dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-09-25 13:24:29 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into badges

Browse Source
This commit is contained in:
spaced4ndy
2026-09-14 17:13:58 +04:00
parent c2c70fa114 237409890e
commit bac8d187ba
83 changed files with 3718 additions and 998 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+5 -3
View File
@@ -28,7 +28,7 @@ import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime, nominalDay)
import Simplex.Chat.Badges (badgeServerCredential)
import Simplex.Chat.Badges (badgeServerCredential, defaultFileSizeLimits)
import Simplex.Chat.Controller
import Simplex.Chat.Library.Commands
import Simplex.Chat.Operators
@@ -105,10 +105,12 @@ defaultChatConfig =
shortLinkPresetServers = allPresetServers,
presetDomains = [".simplex.im", ".simplexonflux.com"],
tbqSize = 1024,
maxChats = 5000,
fileChunkSize = 15780, -- do not change
xftpDescrPartSize = 14000,
inlineFiles = defaultInlineFilesConfig,
autoAcceptFileSize = 0,
fileSizeLimits = defaultFileSizeLimits,
showReactions = False,
showFullLinks = False,
showReceipts = False,
@@ -149,11 +151,11 @@ newChatController
ChatDatabase {chatStore, agentStore}
user
cfg@ChatConfig {agentConfig = aCfg, presetServers, inlineFiles, deviceNameForRemote, confirmMigrations}
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, deviceName, webPreviewConfig, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, showFullLinks, allowInstantFiles, autoAcceptFileSize}
ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, simpleNetCfg, logLevel, logConnections, logServerHosts, logFile, tbqSize, maxChats, deviceName, webPreviewConfig, highlyAvailable, yesToUpMigrations}, optFilesFolder, optTempDirectory, showReactions, showFullLinks, allowInstantFiles, autoAcceptFileSize}
backgroundMode = do
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
config = cfg {logLevel, showReactions, showFullLinks, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, webPreviewConfig, highlyAvailable, confirmMigrations = confirmMigrations'}
config = cfg {logLevel, showReactions, showFullLinks, tbqSize, maxChats, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, webPreviewConfig, highlyAvailable, confirmMigrations = confirmMigrations'}
randomPresetServers <- chooseRandomServers presetServers'
let rndSrvs = L.toList randomPresetServers
operatorWithId (i, op) = (\o -> o {operatorId = DBEntityId i}) <$> pOperator op
src/Simplex/Chat/Badges.hs
+114 -9
View File
@@ -25,7 +25,11 @@ module Simplex.Chat.Badges
BBSPublicKeyStr (..),
localBadgeInfo,
localBadgeStatus,
FileSizeLimits (..),
defaultFileSizeLimits,
maxXFTPFileSize,
maxSndXFTPFileSize,
badgeSndGraceInterval,
badgeServerCredential,
maxFileSizeSupporter,
maxFileSizeLegend,
@@ -46,6 +50,10 @@ module Simplex.Chat.Badges
verifyBadge_,
mkBadgeStatus,
BadgeRow,
BadgeProofKind (..),
BadgeProofRow,
badgeProofToRow,
rowToBadgeProof,
badgeToRow,
localBadgeToRow,
rowToBadge,
@@ -66,11 +74,13 @@ import Data.String
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, nominalDay)
import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
import Simplex.FileTransfer.Description (gb, maxFileSize)
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), fromTextField_)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.BBS
import Simplex.Messaging.Crypto.Entitlement (Entitlement (Entitlement), EntitlementCredential (EntitlementCredential), MasterKey (MasterKey), entitlementBBSHeader)
import Simplex.Messaging.Encoding (Encoding (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
#if defined(dbPostgres)
@@ -114,6 +124,35 @@ instance FromJSON BadgeType where
data BadgeStatus = BSActive | BSExpired | BSExpiredOld | BSFailed | BSUnknownKey
deriving (Eq, Show)
instance TextEncoding BadgeStatus where
textEncode = \case
BSActive -> "active"
BSExpired -> "expired"
BSExpiredOld -> "expired_old"
BSFailed -> "failed"
BSUnknownKey -> "unknown_key"
textDecode = \case
"active" -> Just BSActive
"expired" -> Just BSExpired
"expired_old" -> Just BSExpiredOld
"failed" -> Just BSFailed
"unknown_key" -> Just BSUnknownKey
_ -> Nothing
-- Badge proof kind - a file has at most one proof of each kind
data BadgeProofKind = BPKInvitation | BPKDescription
deriving (Eq, Show)
instance TextEncoding BadgeProofKind where
textEncode = \case
BPKInvitation -> "inv"
BPKDescription -> "descr"
textDecode = \case
"inv" -> Just BPKInvitation
"descr" -> Just BPKDescription
_ -> Nothing
-- Disclosed badge content (BBS messages 1, 2, 3)
data BadgeInfo = BadgeInfo
@@ -186,10 +225,10 @@ localBadgeStatus = \case
ShownBadge _ st -> st
-- XFTP file size limit raised by an active badge: a legend badge to 5GB, any other to 2GB, otherwise the default.
maxFileSizeSupporter :: Int64
maxFileSizeSupporter :: Integer
maxFileSizeSupporter = gb 2
maxFileSizeLegend :: Int64
maxFileSizeLegend :: Integer
maxFileSizeLegend = gb 5
badgeServerCredential :: Maybe LocalBadge -> Maybe EntitlementCredential
@@ -198,31 +237,62 @@ badgeServerCredential = \case
Just $ EntitlementCredential (fromIntegral idx) (MasterKey mk) (Entitlement badgeExpiry (textEncode badgeType) badgeExtra) sig
_ -> Nothing
maxXFTPFileSize :: Maybe LocalBadge -> Int64
maxXFTPFileSize = \case
Just b | localBadgeStatus b == BSActive -> case badgeType (localBadgeInfo b) of
BTLegend -> maxFileSizeLegend
_ -> maxFileSizeSupporter
_ -> maxFileSize
data FileSizeLimits = FileSizeLimits
{ noBadge :: Integer,
supporter :: Integer,
legend :: Integer
}
deriving (Eq, Show)
defaultFileSizeLimits :: FileSizeLimits
defaultFileSizeLimits = FileSizeLimits {noBadge = toInteger maxFileSize, supporter = maxFileSizeSupporter, legend = maxFileSizeLegend}
-- a badge raises the size limit at send for this long after its expiry, shorter than badgeGraceInterval so the receiver still accepts the size
badgeSndGraceInterval :: NominalDiffTime
badgeSndGraceInterval = nominalDay
badgeFileSize :: FileSizeLimits -> LocalBadge -> Integer
badgeFileSize FileSizeLimits {supporter, legend} b = case badgeType (localBadgeInfo b) of
BTLegend -> legend
_ -> supporter
maxXFTPFileSize :: FileSizeLimits -> Maybe LocalBadge -> Integer
maxXFTPFileSize lims = \case
Just b | localBadgeStatus b == BSActive -> badgeFileSize lims b
_ -> noBadge lims
maxSndXFTPFileSize :: FileSizeLimits -> UTCTime -> Maybe LocalBadge -> Integer
maxSndXFTPFileSize lims now = \case
Just b | localBadgeStatus b == BSActive && addUTCTime badgeSndGraceInterval (badgeExpiry (localBadgeInfo b)) >= now -> badgeFileSize lims b
_ -> noBadge lims
-- Presentation header: a tag char + payload. PHTest is unbound - a fresh random nonce per
-- presentation, not bound to any context; the 'T' tag marks it so master rejects it.
-- PHUnknown is the forward-compat catch-all for tags this version does not interpret.
data ProofPresHeaderTag = PHTestTag | PHUnknownTag Char
data ProofPresHeaderTag = PHTestTag | PHChatTag | PHFileInvTag | PHFileDescrTag | PHUnknownTag Char
instance StrEncoding ProofPresHeaderTag where
strEncode = B.singleton . \case
PHTestTag -> 'T'
PHChatTag -> 'C'
PHFileInvTag -> 'F'
PHFileDescrTag -> 'D'
PHUnknownTag c -> c
strP = tag <$> A.anyChar
where
tag = \case
'T' -> PHTestTag
'C' -> PHChatTag
'F' -> PHFileInvTag
'D' -> PHFileDescrTag
c -> PHUnknownTag c
data ProofPresHeader
= PHTest ByteString
| PHChat ByteString
| PHFileInv {chatBinding :: ByteString, fileSize :: Int64}
| PHFileDescr {chatBinding :: ByteString, fileSize :: Int64, descrHash :: ByteString, fileExpires :: Maybe UTCTime}
| PHUnknown Char ByteString
deriving (Eq, Show)
deriving (ToJSON, FromJSON) via (StrJSON "ProofPresHeader" ProofPresHeader)
@@ -230,16 +300,31 @@ data ProofPresHeader
instance StrEncoding ProofPresHeader where
strEncode = \case
PHTest nonce -> strEncode PHTestTag <> nonce
PHChat binding -> strEncode PHChatTag <> binding
PHFileInv {chatBinding, fileSize} ->
strEncode PHFileInvTag <> smpEncode (chatBinding, fileSize)
PHFileDescr {chatBinding, fileSize, descrHash, fileExpires} ->
strEncode PHFileDescrTag <> smpEncode (chatBinding, fileSize, descrHash, utcToSystemTime <$> fileExpires)
PHUnknown c b -> strEncode (PHUnknownTag c) <> b
strP =
strP >>= \case
PHTestTag -> PHTest <$> A.takeByteString
PHChatTag -> PHChat <$> A.takeByteString
PHFileInvTag -> do
(chatBinding, fileSize) <- smpP
pure PHFileInv {chatBinding, fileSize}
PHFileDescrTag -> do
(chatBinding, fileSize, descrHash, expires_) <- smpP
pure PHFileDescr {chatBinding, fileSize, descrHash, fileExpires = systemToUTCTime <$> expires_}
PHUnknownTag c -> PHUnknown c <$> A.takeByteString
-- v6.5.x accepts both; v7 will reject PHTest/PHUnknown
proofPresHeaderAccepted :: ProofPresHeader -> Bool
proofPresHeaderAccepted = \case
PHTest _ -> True
PHChat _ -> True
PHFileInv {} -> True
PHFileDescr {} -> True
PHUnknown _ _ -> True
-- Payment proof
@@ -348,6 +433,26 @@ instance FromField BadgeType where fromField = fromTextField_ textDecode
instance ToField BadgeType where toField = toField . textEncode
instance FromField BadgeStatus where fromField = fromTextField_ textDecode
instance ToField BadgeStatus where toField = toField . textEncode
instance FromField BadgeProofKind where fromField = fromTextField_ textDecode
instance ToField BadgeProofKind where toField = toField . textEncode
-- (proof, pres_header, key_idx, type, expiry, extra) - the fields of BadgeProof as stored in file_badge_proofs
type BadgeProofRow = (Binary ByteString, Binary ByteString, Int, Text, UTCTime, Text)
badgeProofToRow :: BadgeProof -> BadgeProofRow
badgeProofToRow (BadgeProof idx (BBSPresHeader ph) (BBSProof p) BadgeInfo {badgeType, badgeExpiry, badgeExtra}) =
(Binary p, Binary ph, idx, textEncode badgeType, badgeExpiry, badgeExtra)
rowToBadgeProof :: BadgeProofRow -> Maybe BadgeProof
rowToBadgeProof (Binary p, Binary ph, idx, type_, badgeExpiry, badgeExtra) = do
badgeType <- textDecode type_
pure $ BadgeProof idx (BBSPresHeader ph) (BBSProof p) BadgeInfo {badgeType, badgeExpiry, badgeExtra}
-- (proof, pres_header, expiry, type, verified, extra, master_key, signature, key_idx) - binary columns wrapped in Binary (BLOB/bytea)
type BadgeRow = (Maybe (Binary ByteString), Maybe (Binary ByteString), Maybe UTCTime, Maybe Text, Maybe BoolInt, Maybe Text, Maybe (Binary ByteString), Maybe (Binary ByteString), Maybe Int)
src/Simplex/Chat/Controller.hs
+10 -8
View File
@@ -83,7 +83,7 @@ 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, LocalBadge)
import Simplex.Chat.Badges (BadgeCredential, FileSizeLimits, LocalBadge)
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeState (..))
import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
import Simplex.Messaging.Crypto.File (CryptoFile (..))
@@ -97,7 +97,7 @@ import Simplex.Messaging.Session (SessionVar)
import Simplex.Messaging.TMap (TMap)
import Simplex.Messaging.Transport (TLS, TransportPeer (..), simplexMQVersion)
import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost)
import Simplex.Messaging.Util (AnyError (..), catchAllErrors, (<$$>))
import Simplex.Messaging.Util (AnyError (..), catchAllErrors, catchOwn', (<$$>))
import Simplex.RemoteControl.Client
import Simplex.RemoteControl.Invitation (RCSignedInvitation, RCVerifiedInvitation)
import Simplex.RemoteControl.Types
@@ -156,10 +156,12 @@ data ChatConfig = ChatConfig
shortLinkPresetServers :: NonEmpty SMPServer,
presetDomains :: [HostName],
tbqSize :: Natural,
maxChats :: Int,
fileChunkSize :: Integer,
xftpDescrPartSize :: Int,
inlineFiles :: InlineFilesConfig,
autoAcceptFileSize :: Integer,
fileSizeLimits :: FileSizeLimits,
showReactions :: Bool,
showFullLinks :: Bool,
showReceipts :: Bool,
@@ -397,7 +399,7 @@ data ChatCommand
| APISaveAppSettings AppSettings
| APIGetAppSettings (Maybe AppSettings)
| APIGetChatTags UserId
| APIGetChats {userId :: UserId, pendingConnections :: Bool, pagination :: PaginationByTime, query :: ChatListQuery}
| APIGetChats {userId :: UserId, pendingConnections :: Bool, pagination :: Maybe PaginationByTime, query :: ChatListQuery}
| APIGetChat {chatRef :: ChatRef, contentTag :: Maybe MsgContentTag, chatPagination :: ChatPagination, search :: Maybe Text}
| APIGetChatContentTypes ChatRef
| APIGetChatItems {chatPagination :: ChatPagination, search :: Maybe Text}
@@ -677,10 +679,10 @@ data ChatCommand
| DeleteRemoteHost RemoteHostId -- Unregister remote host and remove its data
| StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath}
| GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile}
| ConnectRemoteCtrl RCSignedInvitation -- Connect new or existing controller via OOB data
| ConnectRemoteCtrl {remoteInvitation :: RCSignedInvitation} -- Connect new or existing controller via OOB data
| FindKnownRemoteCtrl -- Start listening for announcements from all existing controllers
| ConfirmRemoteCtrl RemoteCtrlId -- Confirm the connection with found controller
| VerifyRemoteCtrlSession Text -- Verify remote controller session
| VerifyRemoteCtrlSession {sessionCode :: Text} -- Verify remote controller session
| ListRemoteCtrls
| StopRemoteCtrl -- Stop listening for announcements or terminate an active session
| DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session
@@ -896,7 +898,7 @@ data ChatResponse
| CRAcceptingContactRequest {user :: User, contact :: Contact}
| CRContactAlreadyExists {user :: User, contact :: Contact}
| CRLeftMemberUser {user :: User, groupInfo :: GroupInfo}
| CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool}
| CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool, localDeletion :: Bool}
| CRForwardPlan {user :: User, itemsCount :: Int, chatItemIds :: [ChatItemId], forwardConfirmation :: Maybe ForwardConfirmation}
| CRChatMsgContent {user :: User, msgContent :: MsgContent}
| CRRcvFileAccepted {user :: User, chatItem :: AChatItem}
@@ -1779,12 +1781,12 @@ withFastStore = withStorePriority True
withStorePriority :: Bool -> (DB.Connection -> ExceptT StoreError IO a) -> CM a
withStorePriority priority action = do
ChatController {chatStore} <- ask
liftIOEither $ withTransactionPriority chatStore priority (runExceptT . withExceptT ChatErrorStore . action) `E.catch` handleDBErrors
liftIOEither $ withTransactionPriority chatStore priority (runExceptT . withExceptT ChatErrorStore . action) `catchOwn'` handleDBErrors
withStoreBatch :: Traversable t => (DB.Connection -> t (IO (Either ChatError a))) -> CM' (t (Either ChatError a))
withStoreBatch actions = do
ChatController {chatStore} <- ask
liftIO $ withTransaction chatStore $ mapM (`E.catch` handleDBErrors) . actions
liftIO $ withTransaction chatStore $ mapM (`catchOwn'` handleDBErrors) . actions
handleDBErrors :: E.SomeException -> IO (Either ChatError a)
handleDBErrors e = pure $ Left $ ChatErrorStore $ case E.fromException e of
src/Simplex/Chat/Library/Commands.hs
+71 -42
View File
@@ -59,7 +59,7 @@ import qualified Data.UUID.V4 as V4
import Simplex.Chat.Library.Subscriber
import Crypto.Random (ChaChaDRG)
import Simplex.Messaging.Session (SessionVar (..), withGetSessVar')
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), badgeServerCredential, maxXFTPFileSize, mkBadgeStatus, verifyCredential)
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential)
import qualified Simplex.Chat.Badges.Ledger as L
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeState (..))
import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
@@ -71,7 +71,7 @@ import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), Deliv
import Simplex.Chat.Files
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
import Simplex.Chat.Messages.Batch (encodeBatchElement)
import Simplex.Chat.Messages.Batch (BatchMode, encodeBatchElement)
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
import Simplex.Chat.Operators
@@ -132,23 +132,24 @@ import Simplex.RemoteControl.Types (RCCtrlAddress (..))
import System.Exit (ExitCode, exitSuccess)
import System.FilePath (takeExtension, takeFileName, (</>))
import System.IO (Handle, IOMode (..))
import System.Mem.Weak (deRefWeak)
import System.Random (randomRIO)
import System.Timeout (timeout)
import UnliftIO.Async
import UnliftIO.Concurrent (forkIO, threadDelay)
import UnliftIO.Concurrent (forkIO, killThread, threadDelay)
import UnliftIO.Directory
import qualified UnliftIO.Exception as E
import UnliftIO.IO (hClose)
import UnliftIO.STM
#if defined(dbPostgres)
import Data.Bifunctor (bimap, first, second)
import Simplex.Messaging.Agent.Client (SubInfo (..), getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, temporaryOrHostError)
import Simplex.Messaging.Agent.Client (SubInfo (..), cancelWorker, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, temporaryOrHostError)
#else
import Data.Bifunctor (bimap, first, second)
import qualified Data.ByteArray as BA
import qualified Database.SQLite.Simple as SQL
import Simplex.Chat.Archive
import Simplex.Messaging.Agent.Client (SubInfo (..), agentClientStore, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, temporaryOrHostError)
import Simplex.Messaging.Agent.Client (SubInfo (..), agentClientStore, cancelWorker, getAgentQueuesInfo, getAgentWorkersDetails, getAgentWorkersSummary, temporaryOrHostError)
import Simplex.Messaging.Agent.Store.Common (withConnection)
import Simplex.Messaging.Agent.Store.SQLite.DB (SlowQueryStats (..))
#endif
@@ -173,7 +174,7 @@ checkProfileImageSize = mapM_ $ \(ImageData t) ->
in when (size > maxProfileImageSize) $ throwCmdError $ "Profile image is too large " <> show size
checkProfileSize :: Profile -> CM ()
checkProfileSize p = checkInfoSize "Profile" (XInfo p)
checkProfileSize p = checkInfoSize "Profile" (XInfo p Nothing)
checkGroupProfileSize :: GroupProfile -> CM ()
checkGroupProfileSize p = checkInfoSize "Group profile" (XGrpInfo p)
@@ -356,12 +357,20 @@ restoreCalls = do
atomically $ writeTVar calls callsMap
stopChatController :: ChatController -> IO ()
stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, badgeWorkers} = do
stopBadgeWorkers badgeWorkers
stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, cleanupManagerAsync, relayGroupLinkChecksAsync, webPreviewState, expireCIThreads, timedItemThreads, deliveryTaskWorkers, deliveryJobWorkers, relayRequestWorkers, badgeWorkers} = do
readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd)
atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd)
disconnectAgentClient smpAgent
readTVarIO s >>= mapM_ (\(a1, a2) -> forkIO $ uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2)
readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2)
cancelAsync cleanupManagerAsync
cancelAsync relayGroupLinkChecksAsync
forM_ webPreviewState $ \WebPreviewState {webPreviewWorkerAsync} -> cancelAsync webPreviewWorkerAsync
clearMap expireCIThreads >>= mapM_ (mapM_ uninterruptibleCancel)
clearMap timedItemThreads >>= mapM_ (readTVarIO >=> mapM_ (deRefWeak >=> mapM_ killThread))
clearMap deliveryTaskWorkers >>= mapM_ cancelWorker
clearMap deliveryJobWorkers >>= mapM_ cancelWorker
clearMap relayRequestWorkers >>= mapM_ cancelWorker
stopBadgeWorkers badgeWorkers
closeFiles sndFiles
closeFiles rcvFiles
atomically $ do
@@ -369,6 +378,10 @@ stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles,
forM_ keys $ \k -> TM.insert k False expireCIFlags
writeTVar s Nothing
where
cancelAsync :: TVar (Maybe (Async ())) -> IO ()
cancelAsync a = atomically (swapTVar a Nothing) >>= mapM_ uninterruptibleCancel
clearMap :: TM.TMap k a -> IO (Map k a)
clearMap m = atomically $ swapTVar m M.empty
closeFiles :: TVar (Map Int64 Handle) -> IO ()
closeFiles files = do
fs <- readTVarIO files
@@ -664,7 +677,9 @@ processChatCommand cxt nm = \case
tags <- withFastStore' (`getUserChatTags` user)
pure $ CRChatTags user tags
APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do
(errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db cxt user pendingConnections pagination query)
ChatConfig {maxChats} <- asks config
let pagination' = fromMaybe (PTLast maxChats) pagination
(errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db cxt user pendingConnections pagination' query)
unless (null errs) $ toView $ CEvtChatErrors (map ChatErrorStore errs)
pure $ CRApiChats user previews
APIGetChat (ChatRef cType cId scope_) contentFilter pagination search -> withUser $ \user -> case cType of
@@ -1217,7 +1232,7 @@ processChatCommand cxt nm = \case
Nothing -> throwCmdError "not a public group"
Just PublicGroupProfile {groupLink} -> do
let signingKeys = case (memberRole, groupKeys) of
(GROwner, Just gk@GroupKeys {groupRootKey = GRKPrivate _}) -> Just gk
(GROwner, Just gk@GroupKeys {publicGroupKeys = Just PublicGroupKeys {groupRootKey = GRKPrivate _}}) -> Just gk
_ -> Nothing
ownerSig <-
pure signingKeys $>>= \GroupKeys {memberPrivKey} ->
@@ -1385,7 +1400,7 @@ processChatCommand cxt nm = \case
withFastStore' $ \db -> cleanupHostGroupLinkConn db user gInfo
withFastStore' $ \db -> deleteGroupMembers db user gInfo
withFastStore' $ \db -> deleteGroup db user gInfo
pure $ CRGroupDeletedUser user gInfo msgSigned
pure $ CRGroupDeletedUser user gInfo msgSigned (not doSendDel)
where
getRecipients gInfo
| useRelays' gInfo = do
@@ -2298,8 +2313,7 @@ processChatCommand cxt nm = \case
-- set group link info and incognito profile, generate and store membership keys
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
let cReqHash = contactCReqHash $ CRContactUri crData {crScheme = SSSimplex} e2e
gVar <- asks random
(_, memberPrivKey) <- liftIO $ atomically $ C.generateKeyPair gVar
(_, memberPrivKey) <- atomically . C.generateKeyPair =<< asks random
gInfo' <- withFastStore $ \db -> do
gInfo' <- updatePreparedRelayedGroup db cxt user gInfo mainCReq cReqHash incognitoProfile rootKey memberPrivKey publicMemberCount_
-- Pre-emptively create owner members with trusted keys from link data
@@ -2441,8 +2455,7 @@ processChatCommand cxt nm = \case
Left e -> throwError $ ChatErrorStore e
Right _ -> throwError $ ChatErrorStore SEDuplicateContactLink
subMode <- chatReadVar subscriptionMode
gVar <- asks random
rootKey@(rootPubKey, rootPrivKey) <- liftIO $ atomically $ C.generateKeyPair gVar
rootKey@(rootPubKey, rootPrivKey) <- atomically . C.generateKeyPair =<< asks random
let entityId = C.sha256Hash $ C.pubKeyBytes rootPubKey
-- TODO [address DR] remove this option and switch to IKUsePQ True
let (pqInitKeys, useDR) = case pqRatchet_ of
@@ -2685,7 +2698,8 @@ processChatCommand cxt nm = \case
APINewGroup userId incognito gProfile -> withUserId userId $ \user -> do
g <- asks random
memberId <- liftIO $ MemberId <$> encodedRandomBytes g 12
gInfo <- newGroup user incognito gProfile False memberId Nothing Nothing
(_, memberPrivKey) <- atomically $ C.generateKeyPair g
gInfo <- newGroup user incognito gProfile False memberId (Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey}) Nothing
createNewGroupItems user gInfo
pure $ CRGroupCreated user gInfo
NewGroup incognito gProfile -> withUser $ \User {userId} ->
@@ -2721,7 +2735,7 @@ processChatCommand cxt nm = \case
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
subMode <- chatReadVar subscriptionMode
-- generate root key pair; entity ID = sha256(rootPubKey) — see docs/rfcs/2026-03-28-group-identity-binding.md
rootKey@(rootPubKey, rootPrivKey) <- liftIO $ atomically $ C.generateKeyPair gVar
rootKey@(rootPubKey, rootPrivKey) <- atomically $ C.generateKeyPair gVar
let entityId = C.sha256Hash $ C.pubKeyBytes rootPubKey
crClientData = encodeJSON $ CRDataGroup groupLinkId
-- prepare link with entityId as linkEntityId (no server request)
@@ -2739,7 +2753,8 @@ processChatCommand cxt nm = \case
userLinkData = UserContactLinkData UserContactData {direct = False, owners = [ownerAuth], relays = [], userData, ratchetKeys = Nothing}
-- create connection with prepared link (single network call)
connId <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True ccLink preparedParams userLinkData subMode
let groupKeys = GroupKeys {publicGroupId = B64UrlByteString entityId, groupRootKey = GRKPrivate rootPrivKey, memberPrivKey}
let groupKeys = GroupKeys {publicGroupKeys, memberPrivKey}
publicGroupKeys = Just PublicGroupKeys {publicGroupId = B64UrlByteString entityId, groupRootKey = GRKPrivate rootPrivKey}
setupLink gInfo = do
-- TODO [relays] starting role should be communicated in protocol from owner to relays
subRole <- asks $ channelSubscriberRole . config
@@ -2828,7 +2843,7 @@ processChatCommand cxt nm = \case
case activeConn of
Just Connection {peerChatVRange} -> do
subMode <- chatReadVar subscriptionMode
dm <- encodeConnInfo $ XGrpAcpt membershipMemId
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (groupMemberKey g)
agentConnId <- case memberConn fromMember of
Nothing -> do
agentConnId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connRequest PQSupportOff
@@ -3393,7 +3408,7 @@ processChatCommand cxt nm = \case
joinPreparedConn subMode conn = do
-- [incognito] send membership incognito profile
p <- presentUserBadge user (incognitoMembershipProfile gInfo) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True
dm <- encodeConnInfo $ XInfo p
dm <- encodeConnInfo $ XInfo p Nothing
sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode
let newStatus = if sqSecured then ConnSndReady else ConnJoined
void $ withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared newStatus
@@ -3425,7 +3440,8 @@ processChatCommand cxt nm = \case
folderId <- withFastStore (`getUserNoteFolderId` user)
processChatCommand cxt nm $ APIClearChat (ChatRef CTLocal folderId Nothing)
LastChats count_ -> withUser' $ \user -> do
let count = fromMaybe 5000 count_
ChatConfig {maxChats} <- asks config
let count = fromMaybe maxChats count_
(errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db cxt user False (PTLast count) clqNoFilters)
unless (null errs) $ toView $ CEvtChatErrors (map ChatErrorStore errs)
pure $ CRChats previews
@@ -3632,7 +3648,7 @@ processChatCommand cxt nm = \case
fsFilePath <- lift $ toFSFilePath filePath
fileSize <- liftIO $ CF.getFileContentsSize file {filePath = fsFilePath}
when (fileSize > toInteger maxFileSizeHard) $ throwChatError $ CEFileSize filePath
(_, _, fileTransferMeta) <- xftpSndFileTransfer_ user file fileSize 1 Nothing
(_, _, fileTransferMeta) <- xftpSndFileTransfer_ user file fileSize 1 Nothing Nothing
pure CRSndStandaloneFileCreated {user, fileTransferMeta}
APIStandaloneFileInfo FileDescriptionURI {clientData} -> pure . CRStandaloneFileInfo $ clientData >>= J.decodeStrict . encodeUtf8
APIDownloadStandaloneFile userId uri file -> withUserId userId $ \user -> do
@@ -3808,7 +3824,7 @@ processChatCommand cxt nm = \case
joinPreparedConn conn incognitoProfile
joinPreparedConn conn incognitoProfile = do
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user incognitoProfile Nothing True
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend Nothing
sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup' subMode
let newStatus = if sqSecured then ConnSndReady else ConnJoined
conn' <- withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared newStatus
@@ -3961,10 +3977,15 @@ processChatCommand cxt nm = \case
Just gInfo_' -> userProfileInGroup' user gInfo_' 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 $ XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_
Just (Just gInfo)
| useRelays' gInfo -> case relayMemberId_ of
Just relayMemberId -> encodeXMemberConnInfo gInfo relayMemberId profileToSend
Nothing -> throwChatError $ CEInternalError "relay group join without target relay memberId"
| otherwise -> do
gInfo' <- createUserMemberKey gInfo
encodeConnInfoPQ pqSup $ XContact profileToSend (groupMemberKey gInfo') (Just xContactId) welcomeSharedMsgId msg_
_ ->
encodeConnInfoPQ pqSup $ XContact profileToSend Nothing (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
@@ -3977,7 +3998,9 @@ processChatCommand cxt nm = \case
fsFilePath <- lift $ toFSFilePath f
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs
when (fromInteger fileSize > maxXFTPFileSize sndBadge) $ throwChatError $ CEFileSize f
lims <- asks $ fileSizeLimits . config
now <- liftIO getCurrentTime
when (fileSize > maxSndXFTPFileSize lims now sndBadge) $ throwChatError $ CEFileSize f
pure fileSize
updateProfile :: User -> Profile -> CM ChatResponse
updateProfile user p' = updateProfile_ user p' True $ withFastStore $ \db -> updateUserProfile db user p'
@@ -4039,7 +4062,7 @@ processChatCommand cxt nm = \case
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'')
pure (ConnectionId connId, Nothing, XInfo p'' Nothing)
ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq
ctMsgReq ChangedProfileContact {conn} =
fmap $ \SndMessage {msgId, msgBody} ->
@@ -4072,7 +4095,7 @@ processChatCommand cxt nm = \case
when (mergedProfile' /= mergedProfile) $
withContactLock "updateContactPrefs" (contactId' ct) $ do
p <- presentUserBadge user incognitoProfile mergedProfile'
void (sendDirectContactMessage user ct' $ XInfo p) `catchAllErrors` eToView
void (sendDirectContactMessage user ct' $ XInfo p Nothing) `catchAllErrors` eToView
lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct'
pure $ CRContactPrefsUpdated user ct ct'
runUpdateGroupProfile :: User -> GroupInfo -> GroupProfile -> Bool -> CM ChatResponse
@@ -4248,12 +4271,13 @@ processChatCommand cxt nm = \case
createInternalChatItem user cd (CISndGroupE2EEInfo $ e2eInfoGroup gInfo) Nothing
createGroupFeatureItems user cd CISndGroupFeature gInfo
sendGrpInvitation :: User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> CM ()
sendGrpInvitation user ct@Contact {contactId, localDisplayName} gInfo@GroupInfo {groupId, groupProfile, membership, businessChat} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
sendGrpInvitation user ct@Contact {contactId, localDisplayName} gInfo@GroupInfo {groupId, groupProfile, membership, businessChat} m@GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo
GroupMember {memberRole = userRole, memberId = userMemberId} = membership
groupInv =
GroupInvitation
{ fromMember = MemberIdRole userMemberId userRole,
fromMemberKey = groupMemberKey gInfo,
invitedMember = MemberIdRole memberId memRole,
connRequest = cReq,
groupProfile,
@@ -4772,7 +4796,8 @@ processChatCommand cxt nm = \case
Just file -> do
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
binding_ <- ifM ((not (contactConnIncognito ct) &&) <$> fileNeedsBadge fileSize) (directChatBinding ct) (pure Nothing)
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 (CGContact ct) binding_
pure (Just fInv, Just ciFile)
Nothing -> pure (Nothing, Nothing)
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect)))
@@ -4803,8 +4828,10 @@ processChatCommand cxt nm = \case
sendGroupContentMessages user gInfo scope showGroupAsSender live itemTTL sign cmrs = do
assertMultiSendable live cmrs
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo modsCompatVersion
sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs
-- the member key is created before the send, so that signatures and file badge proofs assert the same key
gInfo' <- createUserMemberKey gInfo
recipients <- getGroupRecipients cxt user gInfo' chatScopeInfo modsCompatVersion
sendGroupContentMessages_ user gInfo' scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs
where
hasReport = any (\(ComposedMessage {msgContent}, _, _, _) -> isReport msgContent) cmrs
modsCompatVersion = if hasReport then contentReportsVersion else groupKnockingVersion
@@ -4857,7 +4884,9 @@ processChatCommand cxt nm = \case
Just file -> do
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
needsBadge <- fileNeedsBadge fileSize
let binding_ = if needsBadge && not (incognitoMembership gInfo) then sndGroupChatBinding gInfo showGroupAsSender else Nothing
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize n (CGGroup gInfo recipients) binding_
fInv' <-
if signMsgs && useRelays' gInfo
then (\d -> (fInv :: FileInvitation) {fileDigest = Just d}) <$> cryptoFileDigest file
@@ -4915,9 +4944,9 @@ processChatCommand cxt nm = \case
-- batching retrieval of quoted messages (prepareMsgs).
when (live || length (L.filter (\(ComposedMessage {quotedItemId}, _, _, _) -> isJust quotedItemId) cmrs) > 1) $
throwCmdError "invalid multi send: live and more than one quote not supported"
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd)
xftpSndFileTransfer user file fileSize n contactOrGroup = do
(fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> Maybe ByteString -> CM (FileInvitation, CIFile 'MDSnd)
xftpSndFileTransfer user file fileSize n contactOrGroup binding_ = do
(fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n (Just contactOrGroup) binding_
case contactOrGroup of
CGContact Contact {activeConn} -> forM_ activeConn $ \conn ->
withFastStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr
@@ -5007,7 +5036,7 @@ processChatCommand cxt nm = \case
chunkSize <- asks $ fileChunkSize . config
withFastStore' $ \db -> do
fileId <- createLocalFile CIFSSndStored db user nf createdAt cf fileSize chunkSize
pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal, fileExpires = Nothing}
pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal, fileExpires = Nothing, fileProhibited = Nothing}
prepareLocalItemsData ::
NonEmpty ComposedMessageReq ->
NonEmpty (Maybe (CIFile 'MDSnd)) ->
@@ -5175,7 +5204,7 @@ presentUserBadgeToContacts user'@User {userId, profile = LocalProfile {localBadg
| 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
void (sendDirectContactMessage user' ct' (XInfo p Nothing)) `catchAllErrors` eToView
_ -> pure ()
-- | The check character is verified before anything leaves the device, and the signing keys are
@@ -5955,7 +5984,7 @@ chatCommandP =
*> ( APIGetChats
<$> A.decimal
<*> (" pcc=on" $> True <|> " pcc=off" $> False <|> pure False)
<*> (A.space *> paginationByTimeP <|> pure (PTLast 5000))
<*> optional (A.space *> paginationByTimeP)
<*> (A.space *> jsonP <|> pure clqNoFilters)
),
"/_get chat " *> (APIGetChat <$> chatRefP <*> optional (" content=" *> strP) <* A.space <*> chatPaginationP <*> optional (" search=" *> textP)),
src/Simplex/Chat/Library/Internal.hs
+225 -60
View File
@@ -40,7 +40,7 @@ import Data.Foldable (foldr')
import Data.Functor (($>))
import Data.Functor.Identity
import Data.Int (Int64)
import Data.List (foldl', mapAccumL, partition)
import Data.List (find, foldl', mapAccumL, partition)
import Data.List.NonEmpty (NonEmpty (..), (<|))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
@@ -53,7 +53,7 @@ import Data.Text.Encoding (encodeUtf8)
import Data.Time (addUTCTime)
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToDiffTime)
import Simplex.Chat.Badges (BadgeCredential (..), ProofPresHeader (..), BadgeProof (..), BadgeStatus (..), LocalBadge (..), badgeProof, mkBadgeStatus, verifyBadge)
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), ProofPresHeader (..), BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), LocalBadge (..), badgeProof, badgeSndGraceInterval, generateBadgeProof, localBadgeStatus, maxXFTPFileSize, mkBadgeStatus, verifyBadge)
import Simplex.Chat.Names (SimplexDomainClaim (..), claimDomain)
import Simplex.Chat.Call
import Simplex.Chat.Controller
@@ -98,7 +98,8 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding (smpEncode)
import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..))
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (MsgBody, MsgFlags (..), ProtoServerWithAuth (..), ProtocolServer, ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer)
import qualified Simplex.Messaging.Protocol as SMP
@@ -435,10 +436,11 @@ roundedFDCount n
| n <= 0 = 4
| otherwise = max 4 $ fromIntegral $ (2 :: Integer) ^ (ceiling (logBase 2 (fromIntegral n) :: Double) :: Integer)
xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ = do
xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> Maybe ByteString -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ binding_ = do
fileBadge <- pure binding_ $>>= \chatBinding -> sndBadgeProof user PHFileInv {chatBinding, fileSize = fromInteger fileSize}
let fileName = takeFileName filePath
fInv = xftpFileInvitation fileName fileSize dummyFileDescr
fInv = (xftpFileInvitation fileName fileSize dummyFileDescr :: FileInvitation) {fileBadge}
fsFilePath <- lift $ toFSFilePath filePath
let srcFile = CryptoFile fsFilePath cfArgs
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n) Nothing
@@ -446,9 +448,32 @@ xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOr
chSize <- asks $ fileChunkSize . config
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup_ file fInv (AgentSndFileId aFileId) Nothing chSize
let fileSource = Just $ CryptoFile filePath cfArgs
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP, fileExpires = Nothing}
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP, fileExpires = Nothing, fileProhibited = Nothing}
pure (fInv, ciFile, ft)
fileNeedsBadge :: Integer -> CM Bool
fileNeedsBadge fileSize = (fileSize >) . noBadge <$> asks (fileSizeLimits . config)
sndBadgeProof :: User -> ProofPresHeader -> CM (Maybe BadgeProof)
sndBadgeProof user = sndBadgeProof_ user . BBSPresHeader . strEncode
sndBadgeProof_ :: User -> BBSPresHeader -> CM (Maybe BadgeProof)
sndBadgeProof_ User {profile = LocalProfile {localBadge}} ph = case localBadge of
Just (OwnBadge cred@(BadgeCredential keyIdx _ _ _) _) -> do
keys <- asks $ badgePublicKeys . config
case M.lookup keyIdx keys of
Nothing -> Nothing <$ logError "sndBadgeProof: badge key index not in config"
Just key ->
liftIO (generateBadgeProof key cred ph) >>= \case
Right proof -> pure $ Just proof
Left e -> Nothing <$ logError ("sndBadgeProof: proof generation failed: " <> T.pack e)
_ -> pure Nothing
sndGroupChatBinding :: GroupInfo -> ShowGroupAsSender -> Maybe ByteString
sndGroupChatBinding GroupInfo {groupKeys, membership = GroupMember {memberId}} asGroup
| asGroup = (\PublicGroupKeys {publicGroupId} -> encodeChatBinding CBChannel $ smpEncode publicGroupId) <$> (groupKeys >>= publicGroupKeys)
| otherwise = (\GroupKeys {memberPrivKey} -> encodeChatBinding CBGroup $ groupBindingData groupKeys memberId (C.publicKey memberPrivKey)) <$> groupKeys
cryptoFileDigest :: CryptoFile -> CM FD.FileDigest
cryptoFileDigest (CryptoFile filePath cfArgs) = do
fsPath <- lift $ toFSFilePath filePath
@@ -744,10 +769,11 @@ rctFileCancelled = \case
_ -> False
acceptFileReceive :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM AChatItem
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId, cryptoArgs} userApprovedRelays rcvInline_ filePath_ = do
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileProhibited, fileStatus, grpMemberId, cryptoArgs} userApprovedRelays rcvInline_ filePath_ = do
unless (fileStatus == RFSNew) $ case fileStatus of
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
_ -> throwChatError $ CEFileAlreadyReceiving fName
when (isJust fileProhibited) $ throwChatError $ CEFileSize fName
cxt <- chatStoreCxt
case (xftpRcvFile, fileConnReq) of
-- XFTP
@@ -970,7 +996,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId
pure (ct, conn, ExistingIncognito <$> incognitoProfile)
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend
dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend Nothing
(ct,conn,) <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode)
acceptContactRequestAsync :: User -> Int64 -> Contact -> UserContactRequest -> Maybe IncognitoProfile -> CM Contact
@@ -991,7 +1017,7 @@ acceptContactRequestAsync
Connection {connId} <- liftIO $ createAcceptedContactConn db user (Just uclId) contactId acId chatV cReqChatVRange cReqPQSup incognitoProfile subMode currentTs
liftIO $ setCommandConnId db user cmdId connId
getContact db cxt user contactId
agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend) cReqPQSup subMode
agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend Nothing) cReqPQSup subMode
pure ct'
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
@@ -1032,6 +1058,7 @@ acceptGroupJoinRequestAsync
GroupLinkInvitation
{ fromMember = MemberIdRole userMemberId userRole,
fromMemberName = displayName,
fromMemberKey = groupMemberKey gInfo,
invitedMember = MemberIdRole memberId gLinkMemRole,
groupProfile,
accepted = Just gAccepted,
@@ -1095,6 +1122,7 @@ acceptBusinessJoinRequestAsync
GroupLinkInvitation
{ fromMember = MemberIdRole userMemberId userRole,
fromMemberName = displayName,
fromMemberKey = groupMemberKey gInfo,
invitedMember = MemberIdRole memberId GRMember,
groupProfile = businessGroupProfile userProfile groupPreferences,
accepted = Just GAAccepted,
@@ -1417,15 +1445,17 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
resolveAuthor (Just gmId) = do
cxt <- chatStoreCxt
eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupMemberById db cxt user gmId)
getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime))
getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe HistoryFile)
getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus, fileExpires} = do
expired <- fileExpired fileExpires
if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired
then pure Nothing
else do
rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId
pure $ invCompleteDescr ciFile rfd
getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime))
(rfd, (invBadge, descrBadge)) <- withStore $ \db -> do
rfd <- getRcvFileDescrByRcvFileId db fileId
(rfd,) <$> liftIO (getFileBadgeProofs db fileId)
pure $ invCompleteDescr ciFile rfd invBadge descrBadge
getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe HistoryFile)
getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus, fileExpires} = do
expired <- fileExpired fileExpires
if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired
@@ -1433,28 +1463,54 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
else do
-- can also lookup in extra_xftp_file_descriptions, though it can be empty;
-- would be best if snd file had a single rcv description for all members saved in files table
rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId
pure $ invCompleteDescr ciFile rfd
now <- liftIO getCurrentTime
(rfd, (invBadge, descrBadge)) <- withStore $ \db -> do
rfd <- getRcvFileDescrBySndFileId db fileId
(rfd,) <$> liftIO (getFileBadgeProofs db fileId)
-- a signed item forwards the author's original bytes, so its invitation proof cannot be replaced
(invBadge', descrBadge') <-
if isNothing signedMsg_ && ownBadgeActive && (staleBadge now invBadge || staleBadge now descrBadge)
then refreshSndBadges fileId invBadge descrBadge
else pure (invBadge, descrBadge)
pure $ invCompleteDescr ciFile rfd invBadge' descrBadge'
staleBadge :: UTCTime -> Maybe BadgeProof -> Bool
staleBadge now = \case
Just BadgeProof {badgeInfo = BadgeInfo {badgeExpiry}} -> addUTCTime badgeSndGraceInterval badgeExpiry < now
Nothing -> False
ownBadgeActive :: Bool
ownBadgeActive = maybe False ((BSActive ==) . localBadgeStatus) localBadge
where
User {profile = LocalProfile {localBadge}} = user
-- both proofs are made with the same badge, and are re-made with the current badge over the stored headers
refreshSndBadges :: FileTransferId -> Maybe BadgeProof -> Maybe BadgeProof -> CM (Maybe BadgeProof, Maybe BadgeProof)
refreshSndBadges fileId invBadge descrBadge = do
invBadge' <- mapM reProve invBadge
descrBadge' <- mapM reProve descrBadge
withStore' $ \db -> do
forM_ invBadge' $ createFileBadgeProof db fileId BPKInvitation
forM_ descrBadge' $ createFileBadgeProof db fileId BPKDescription
pure (invBadge', descrBadge')
where
reProve badge@BadgeProof {presHeader} = fromMaybe badge <$> sndBadgeProof_ user presHeader
fileExpired :: Maybe UTCTime -> CM Bool
fileExpired fileExpires = do
ttl <- asks $ rcvFilesTTL . agentConfig . config
now <- liftIO getCurrentTime
pure $ fromMaybe (addUTCTime ttl $ chatItemTs cci) fileExpires < now
invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime)
invCompleteDescr CIFile {fileName, fileSize, fileExpires} RcvFileDescr {fileDescrText, fileDescrComplete}
invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe BadgeProof -> Maybe BadgeProof -> Maybe HistoryFile
invCompleteDescr CIFile {fileName, fileSize, fileExpires} RcvFileDescr {fileDescrText, fileDescrComplete} invBadge descrBadge
| fileDescrComplete =
let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
fInv = xftpFileInvitation fileName fileSize fInvDescr
in Just (fInv, fileDescrText, fileExpires)
let fInv = (xftpFileInvitation fileName fileSize dummyFileDescr :: FileInvitation) {fileBadge = invBadge}
in Just (fInv, fileDescrText, fileExpires, descrBadge)
| otherwise = Nothing
processContentItem :: Maybe GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime) -> CM [(GrpMsgForward, VerifiedMsg 'Json)]
processContentItem :: Maybe GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe HistoryFile -> CM [(GrpMsgForward, VerifiedMsg 'Json)]
processContentItem member_ ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ =
if isNothing fInvDescr_ && not (msgContentHasText mc)
then pure []
else do
let CIMeta {itemTs, itemSharedMsgId, itemTimed, showGroupAsSender} = meta
quotedItemId_ = quoteItemId =<< quotedItem
fInv_ = (\(fInv, _, _) -> fInv) <$> fInvDescr_
fInv_ = (\(fInv, _, _, _) -> fInv) <$> fInvDescr_
(mc', _, mentions') = updatedMentionNames mc formattedText mentions
mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions'
-- for channel messages default chat version range to membership range
@@ -1473,10 +1529,10 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
(chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing showGroupAsSender mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False
pure $ VMUnsigned ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent}
fileDescrEvents <- case (fInvDescr_, itemSharedMsgId) of
(Just (_, fileDescrText, fileExpires), Just msgId) -> do
(Just (_, fileDescrText, fileExpires, descrBadge), Just msgId) -> do
partSize <- asks $ xftpDescrPartSize . config
let parts = splitFileDescr partSize fileDescrText
pure . L.toList $ L.map (\fd -> XMsgFileDescr msgId fd fileExpires) parts
let parts = splitFileDescr partSize (maybe partSize (const badgeDescrPartSize) descrBadge) fileDescrText
pure . L.toList $ L.map (\fd@FileDescr {fileDescrComplete} -> XMsgFileDescr msgId fd fileExpires (if fileDescrComplete then descrBadge else Nothing)) parts
_ -> pure []
let fileDescrVMs = map (VMUnsigned . ChatMessage senderVRange Nothing) fileDescrEvents
pure $ map ((,) fwd) (contentVM : fileDescrVMs)
@@ -1486,11 +1542,16 @@ memberShortenedName GroupMember {memberProfile = LocalProfile {displayName}}
| T.length displayName <= 16 = displayName
| otherwise = T.take 16 displayName `T.snoc` '…'
splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr
splitFileDescr partSize rfdText = splitParts 1 rfdText
-- the description proof travels on the last part, so that part leaves room for it
badgeDescrPartSize :: Int
badgeDescrPartSize = 13500
splitFileDescr :: Int -> Int -> RcvFileDescrText -> NonEmpty FileDescr
splitFileDescr partSize lastSize rfdText = splitParts 1 rfdText
where
splitParts partNo remText =
let (part, rest) = T.splitAt partSize remText
let n = T.length remText
(part, rest) = T.splitAt (if n <= lastSize then n else if n <= partSize then lastSize else partSize) remText
complete = T.null rest
fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete}
in if complete
@@ -1593,7 +1654,7 @@ groupLinkData gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {public
publicGroupData_ = PublicGroupData <$> publicMemberCount
userData = encodeShortLinkData $ GroupShortLinkData {groupProfile, publicGroupData = publicGroupData_}
owners = case groupKeys of
Just GroupKeys {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey} ->
Just GroupKeys {publicGroupKeys = Just PublicGroupKeys {groupRootKey = GRKPrivate rootPrivKey}, memberPrivKey} ->
let ownerId = unMemberId memberId
ownerKey = C.publicKey memberPrivKey
authOwnerSig = C.sign' rootPrivKey (ownerId <> C.encodePubKey ownerKey)
@@ -2248,27 +2309,111 @@ createSndMessages idsEvents = do
encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt}
groupMsgSigning :: Bool -> GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning
groupMsgSigning sign gInfo@GroupInfo {membership = GroupMember {memberId}, groupKeys = Just GroupKeys {publicGroupId, memberPrivKey}} evt
| useRelays' gInfo && shouldSign =
Just $ MsgSigning CBGroup (smpEncode (publicGroupId, memberId)) KRMember memberPrivKey
groupMsgSigning sign GroupInfo {membership = GroupMember {memberId}, groupKeys} evt = case groupKeys of
Just gks@GroupKeys {memberPrivKey} | shouldSign -> Just $ MsgSigning CBGroup bindingData KRMember memberPrivKey
where
tag = toCMEventTag evt
shouldSign = requiresSignature tag || (sign && signableContent tag)
bindingData = groupBindingData (Just gks) memberId (C.publicKey memberPrivKey)
_ -> Nothing
groupBindingData :: Maybe GroupKeys -> MemberId -> C.PublicKeyEd25519 -> ByteString
groupBindingData gks memberId memberKey = case gks >>= publicGroupKeys of
Just PublicGroupKeys {publicGroupId} -> smpEncode (publicGroupId, memberId)
Nothing -> smpEncode (memberId, memberKey)
type HistoryFile = (FileInvitation, RcvFileDescrText, Maybe UTCTime, Maybe BadgeProof)
directChatBinding :: Contact -> CM (Maybe ByteString)
directChatBinding ct =
forM (contactConn ct) $ \conn ->
encodeChatBinding CBDirect <$> withAgent (`getConnectionRatchetAdHash` aConnId conn)
rcvGroupChatBinding :: GroupInfo -> Maybe GroupMember -> ShowGroupAsSender -> Maybe BadgeProof -> Maybe ByteString
rcvGroupChatBinding GroupInfo {groupKeys} m_ asGroup badge_ =
case (groupKeys >>= publicGroupKeys, asGroup, m_) of
(Just PublicGroupKeys {publicGroupId}, True, _) ->
Just $ encodeChatBinding CBChannel $ smpEncode publicGroupId
(Just PublicGroupKeys {publicGroupId}, False, Just GroupMember {memberId}) ->
Just $ encodeChatBinding CBGroup $ smpEncode (publicGroupId, memberId)
(Nothing, False, Just GroupMember {memberId, memberPubKey}) ->
(\k -> encodeChatBinding CBGroup $ smpEncode (memberId, k)) <$> (memberPubKey <|> proofMemberKey memberId badge_)
_ -> Nothing
proofMemberKey :: MemberId -> Maybe BadgeProof -> Maybe C.PublicKeyEd25519
proofMemberKey memberId badge_ = do
BadgeProof _ (BBSPresHeader phBytes) _ _ <- badge_
binding <- headerChatBinding =<< eitherToMaybe (strDecode phBytes)
d <- B.stripPrefix (smpEncode CBGroup) binding
(mId, k) <- eitherToMaybe (smpDecode d :: Either String (MemberId, C.PublicKeyEd25519))
if mId == memberId then Just k else Nothing
where
tag = toCMEventTag evt
shouldSign = requiresSignature tag || (sign && signableContent tag)
groupMsgSigning _ _ _ = Nothing
headerChatBinding = \case
PHFileInv {chatBinding} -> Just chatBinding
PHFileDescr {chatBinding} -> Just chatBinding
_ -> Nothing
badgeProofStatus :: Maybe ProofPresHeader -> BadgeProof -> CM BadgeStatus
badgeProofStatus expected_ badge@BadgeProof {presHeader = BBSPresHeader phBytes, badgeInfo} =
case expected_ of
Just expected | phBytes == strEncode expected -> do
keys <- asks $ badgePublicKeys . config
verified <- liftIO $ verifyBadge keys badge
now <- liftIO getCurrentTime
pure $ mkBadgeStatus now verified badgeInfo
_ -> pure BSFailed
rcvDirectFileProhibited :: Contact -> FileInvitation -> CM (Maybe FileProhibited)
rcvDirectFileProhibited ct fInv@FileInvitation {fileBadge} = do
binding_ <- if isJust fileBadge then directChatBinding ct else pure Nothing
rcvFileProhibited binding_ fInv
rcvGroupFileProhibited :: GroupInfo -> Maybe GroupMember -> ShowGroupAsSender -> FileInvitation -> CM (Maybe FileProhibited)
rcvGroupFileProhibited gInfo m_ asGroup fInv@FileInvitation {fileBadge} =
rcvFileProhibited (rcvGroupChatBinding gInfo m_ asGroup fileBadge) fInv
rcvFileProhibited :: Maybe ByteString -> FileInvitation -> CM (Maybe FileProhibited)
rcvFileProhibited binding_ FileInvitation {fileSize, fileBadge} = do
lims <- asks $ fileSizeLimits . config
if fileSize <= noBadge lims
then pure Nothing
else case fileBadge of
Nothing -> pure $ Just FileProhibited {maxSize = noBadge lims, badgeStatus = Nothing}
Just badge -> do
st <- badgeProofStatus ((\chatBinding -> PHFileInv {chatBinding, fileSize = fromInteger fileSize}) <$> binding_) badge
let maxSize = maxXFTPFileSize lims $ Just $ PeerBadge badge st
pure $
if fileSize <= maxSize
then Nothing
else Just FileProhibited {maxSize, badgeStatus = Just st}
createUserMemberKey :: GroupInfo -> CM GroupInfo
createUserMemberKey gInfo@GroupInfo {groupId, membership, groupKeys}
| useRelays' gInfo || isJust groupKeys = pure gInfo
| otherwise = do
(_, memberPrivKey) <- atomically . C.generateKeyPair =<< asks random
withStore' $ \db -> setUserMemberKey db groupId (groupMemberId' membership) memberPrivKey
pure gInfo {groupKeys = Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey}}
groupMemberKey :: GroupInfo -> Maybe MemberKey
groupMemberKey GroupInfo {groupKeys} = MemberKey . C.publicKey . memberPrivKey <$> groupKeys
sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfo -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
sendGroupMemberMessages user gInfo@GroupInfo {groupId} conn events = do
when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning False gInfo evt, evt)) events
mode = if useRelays' gInfo then BMBinary else BMJson
(errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts
unless (null errs) $ toView $ CEvtChatErrors errs
forM_ (L.nonEmpty msgs) $ \msgs' ->
batchSendConnMessages mode user conn MsgFlags {notification = True} msgs'
batchSendConnMessages gInfo user conn MsgFlags {notification = True} msgs'
batchSendConnMessages :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessages mode user conn msgFlags msgs =
batchSendConnMessages :: GroupInfo -> User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessages gInfo user conn msgFlags msgs =
batchSendConnMessagesB mode user conn msgFlags $ L.map Right msgs
where
mode
| useRelays' gInfo || maxVersion (peerChatVRange conn) >= relayWebCapVersion = BMBinary
| otherwise = BMJson
batchSendConnMessagesB :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption)
batchSendConnMessagesB mode _user conn msgFlags msgs_ = do
@@ -2326,9 +2471,10 @@ encodeSignedConnInfo signing chatMsgEvent = do
encodeXMemberConnInfo :: GroupInfo -> MemberId -> Profile -> CM ByteString
encodeXMemberConnInfo GroupInfo {membership = GroupMember {memberId}, groupKeys} relayMemberId profileToSend =
case groupKeys of
Just GroupKeys {publicGroupId, memberPrivKey} ->
Just gks@GroupKeys {memberPrivKey} ->
let xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey) (Just relayMemberId)
signing = MsgSigning CBGroup (smpEncode (publicGroupId, memberId)) KRMember memberPrivKey
bindingData = groupBindingData (Just gks) memberId (C.publicKey memberPrivKey)
signing = MsgSigning CBGroup bindingData KRMember memberPrivKey
in encodeSignedConnInfo signing xMemberEvt
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
@@ -2483,13 +2629,15 @@ sendRelayCapIfNeeded user gInfo = do
withStore' $ \db -> updateRelaySentWebDomain db gInfo currentWebDomain
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages user gInfo scope asGroup members sign events = do
sendGroupMessages user gInfo' scope asGroup members sign events = do
gInfo <- createUserMemberKey gInfo'
sendGroupProfileUpdate user gInfo scope asGroup members
sendGroupMessages_ user gInfo members sign events
-- per-item signer variant of sendGroupMessages (used for per-item delete signing); preserves the profile-update prelude
sendGroupSignedMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupSignedMessages user gInfo scope asGroup members signedEvents = do
sendGroupSignedMessages user gInfo' scope asGroup members signedEvents = do
gInfo <- createUserMemberKey gInfo'
sendGroupProfileUpdate user gInfo scope asGroup members
sendGroupSignedMessages_ gInfo members signedEvents
@@ -2513,7 +2661,7 @@ sendGroupProfileUpdate user gInfo scope asGroup members =
sendProfileUpdate = do
-- shouldSendProfileUpdate excludes incognito membership, so the badge is presented
profileUpdate <- presentUserBadge user Nothing $ redactedMemberProfile gInfo (membership gInfo) $ fromLocalProfile p
void $ sendGroupMessage' user gInfo members $ XInfo profileUpdate
void $ sendGroupMessage' user gInfo members $ XInfo profileUpdate (groupMemberKey gInfo)
currentTs <- liftIO getCurrentTime
withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs
@@ -2533,7 +2681,7 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
recipientMembers' <- liftIO $ shuffleMembers recipientMembers
let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events}
(toSend, toPending, forwarded, _, dups) =
foldr' (addMember recipientMembers') ([], [], [], S.empty, 0 :: Int) recipientMembers'
foldr' (addMember recipientMembers') (([], []), [], [], S.empty, 0 :: Int) recipientMembers'
when (dups /= 0) $ logError $ "sendGroupMessages_: " <> tshow dups <> " duplicate members"
-- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here
-- Deliver to toSend members
@@ -2557,26 +2705,30 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
liftM2 (<>) (shuffle adminMs) (shuffle otherMs)
where
isAdmin GroupMember {memberRole} = memberRole >= GRAdmin
addMember members m acc@(toSend, pending, forwarded, !mIds, !dups) =
addMember members m acc@(toSend@(toSendBin, toSendJson), pending, forwarded, !mIds, !dups) =
case memberSendAction gInfo events members m of
Just a
| mId `S.member` mIds -> (toSend, pending, forwarded, mIds, dups + 1)
| otherwise -> case a of
MSASend conn -> ((m, conn) : toSend, pending, forwarded, mIds', dups)
MSASend conn ->
let toSend' = case batchMode gInfo m of
BMBinary -> ((m, conn) : toSendBin, toSendJson)
BMJson -> (toSendBin, (m, conn) : toSendJson)
in (toSend', pending, forwarded, mIds', dups)
MSAPending -> (toSend, m : pending, forwarded, mIds', dups)
MSAForwarded -> (toSend, pending, m : forwarded, mIds', dups)
Nothing -> acc
where
mId = groupMemberId' m
mIds' = S.insert mId mIds
prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
prepareMsgReqs msgFlags msgs toSend = do
let mode = if useRelays' gInfo then BMBinary else BMJson
batched_ = batchSndMessagesJSON mode msgs
case L.nonEmpty batched_ of
Just batched' -> foldMembers (length batched' + length msgs) msgBatchMBR batched' toSend
Nothing -> ([], [])
prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> ([(GroupMember, Connection)], [(GroupMember, Connection)]) -> ([GroupMemberId], [Either ChatError ChatMsgReq])
prepareMsgReqs msgFlags msgs (toSendBin, toSendJson) =
batchReqs 1 BMBinary toSendBin <> batchReqs 2 BMJson toSendJson
where
batchReqs _ _ [] = ([], [])
batchReqs n mode toSend' = case L.nonEmpty (batchSndMessagesJSON mode msgs) of
Just batched -> foldMembers (n * (length batched + length msgs)) msgBatchMBR batched toSend'
Nothing -> ([], [])
foldMembers :: forall a. Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq])
foldMembers lastRef mkMb mbs mems = snd $ foldr' foldMsgBodies (lastMemIdx_, ([], [])) mems
where
@@ -2609,6 +2761,11 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents
createPendingMsg db (groupMemberId, msgId) =
createPendingGroupMessage db groupMemberId msgId $> Right ()
batchMode :: GroupInfo -> GroupMember -> BatchMode
batchMode gInfo m
| useRelays' gInfo || m `supportsVersion` relayWebCapVersion = BMBinary
| otherwise = BMJson
data MemberSendAction = MSASend Connection | MSAPending | MSAForwarded
memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction
@@ -2682,10 +2839,9 @@ sendFwdMemberMessage member fwd verifiedMsg =
-- TODO ensure order - pending messages interleave with user input messages
sendPendingGroupMessages :: User -> GroupInfo -> GroupMember -> Connection -> CM ()
sendPendingGroupMessages user gInfo GroupMember {groupMemberId} conn = do
let mode = if useRelays' gInfo then BMBinary else BMJson
msgs <- withStore' $ \db -> getPendingGroupMessages db groupMemberId
forM_ (L.nonEmpty msgs) $ \msgs' -> do
void $ batchSendConnMessages mode user conn MsgFlags {notification = True} msgs'
void $ batchSendConnMessages gInfo user conn MsgFlags {notification = True} msgs'
lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs'
saveDirectRcvMSG :: forall e. MsgEncodingI e => Connection -> MsgMeta -> ChatMessage e -> CM (Connection, RcvMessage)
@@ -2890,10 +3046,19 @@ joinAgentConnectionAsync :: CommandId -> Bool -> ConnId -> Bool -> ConnectionReq
joinAgentConnectionAsync cmdId updateConn connId enableNtfs cReqUri cInfo subMode =
withAgent $ \a -> joinConnectionAsync a (aCorrId cmdId) updateConn connId enableNtfs cReqUri cInfo PQSupportOff subMode
allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync user conn@Connection {connId, pqSupport} confId msg = do
allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> Maybe GroupInfo -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync user conn@Connection {pqSupport} confId gInfo_ msg = do
let signing_ = case gInfo_ of
Just gInfo | useRelays' gInfo || maxVersion (peerChatVRange conn) >= relayWebCapVersion -> groupMsgSigning False gInfo msg
_ -> Nothing
dm <- case signing_ of
Just signing -> encodeSignedConnInfo signing msg
Nothing -> encodeConnInfoPQ pqSupport msg
allowAgentConnectionInfo user conn confId dm
allowAgentConnectionInfo :: User -> Connection -> ConfirmationId -> ByteString -> CM ()
allowAgentConnectionInfo user conn@Connection {connId} confId dm = do
cmdId <- withStore' $ \db -> createCommand db user (Just connId) CFAllowConn
dm <- encodeConnInfoPQ pqSupport msg
withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm
withStore' $ \db -> updateConnectionStatus db conn ConnAccepted
src/Simplex/Chat/Library/Subscriber.hs
+235 -166
View File
@@ -46,6 +46,7 @@ import Data.Time.Format (defaultTimeLocale, formatTime)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as V4
import Data.Word (Word32)
import Simplex.Chat.Badges (BadgeProof, BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), ProofPresHeader (..))
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Delivery
@@ -76,7 +77,7 @@ import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.FileTransfer.Description (ValidFileDescription)
import qualified Simplex.FileTransfer.Description as FD
import Simplex.FileTransfer.Protocol (FilePartyI, GrantedStorageTime (..))
import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI, GrantedStorageTime (..))
import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId)
import Simplex.Messaging.Agent
@@ -112,11 +113,11 @@ import qualified Data.Aeson as J
smallGroupsRcptsMemLimit :: Int
smallGroupsRcptsMemLimit = 20
-- Verifies member signatures over CBGroup <> (publicGroupId, memberId) <> signedBody under the given key.
-- Verifies member signatures over CBGroup <> (publicGroupId, memberId) or (memberId, pubKey) <> signedBody under the given key.
-- signatures is NonEmpty so the verification can't be vacuously true.
verifyGroupSig :: C.PublicKeyEd25519 -> B64UrlByteString -> MemberId -> NonEmpty MsgSignature -> ByteString -> Bool
verifyGroupSig key publicGroupId memberId signatures signedBody =
let prefix = smpEncode CBGroup <> smpEncode (publicGroupId, memberId)
verifyGroupSig :: C.PublicKeyEd25519 -> Maybe GroupKeys -> MemberId -> NonEmpty MsgSignature -> ByteString -> Bool
verifyGroupSig key gks memberId signatures signedBody =
let prefix = encodeChatBinding CBGroup $ groupBindingData gks memberId key
in all (\case (MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 key) sig (prefix <> signedBody)) signatures
processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
@@ -134,10 +135,33 @@ processAgentMessage corrId connId msg = do
lockEntity <- critical connId (withStore (`getChatLockEntity` AgentConnId connId))
withEntityLock "processAgentMessage" lockEntity $ do
cxt <- chatStoreCxt
-- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here
critical connId (withStore' (`getUserByAConnId` AgentConnId connId)) >>= \case
Just user -> processAgentMessageConn cxt user corrId connId msg `catchAllErrors` eToView
-- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert,
-- as in this case no need to ACK message - we can't process messages for this connection anyway.
critical connId (withStore $ getUserEntity cxt) >>= \case
Just (user, entity) -> processAgentMessageConn cxt user entity corrId connId msg `catchAllErrors` eToView
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
where
getUserEntity :: StoreCxt -> DB.Connection -> ExceptT StoreError IO (Maybe (User, ConnectionEntity))
getUserEntity cxt db =
liftIO (getUserByAConnId db $ AgentConnId connId)
>>= mapM (\user -> (user,) <$> (getConnectionEntity db cxt user (AgentConnId connId) >>= liftIO . updateConnStatus db))
updateConnStatus :: DB.Connection -> ConnectionEntity -> IO ConnectionEntity
updateConnStatus db acEntity = case agentMsgConnStatus (entityConnection acEntity) msg of
Just connStatus -> do
let conn = (entityConnection acEntity) {connStatus}
updateConnectionStatus db conn connStatus
pure $ updateEntityConnStatus acEntity connStatus
Nothing -> pure acEntity
agentMsgConnStatus :: Connection -> AEvent e -> Maybe ConnStatus
agentMsgConnStatus Connection {connStatus = cs} = \case
JOINED True -> Just ConnSndReady
CONF {} -> Just ConnRequested
INFO {} -> Just ConnSndReady
CON _ -> Just ConnReady
ERR err | cs /= ConnReady && not (temporaryOrHostError err) -> Just $ ConnFailed (tshow err)
_ -> Nothing
-- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps.
-- SEDBBusyError will only be thrown on IO exceptions or SQLError during DB queries,
@@ -224,7 +248,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
-- we have 1 chunk - use it as URI whether it is redirect or not
ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor
toView $ CEvtSndStandaloneFileComplete user ft' $ map (decodeLatin1 . strEncode . FD.fileDescriptionURI) rfds'
Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) ->
Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted, showGroupAsSender}}) ->
case (msgId_, itemDeleted) of
(Just sharedMsgId, Nothing) -> do
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
@@ -232,9 +256,16 @@ processAgentMsgSndFile _corrId aFileId msg = do
toView $ CEvtSndFileProgressXFTP user ci ft 1 1
case (rfds, sfts, d, cInfo) of
(rfd : extraRFDs, sft : _, SMDSnd, DirectChat ct) -> do
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
conn@Connection {connId} <- liftEither $ contactSendConn_ ct
sendFileDescriptions (ConnectionId connId) ((conn, sft, fileDescrText rfd) :| []) sharedMsgId fileExpires >>= \case
let FileTransferMeta {fileSize} = ft
binding_ <- ifM ((not (contactConnIncognito ct) &&) <$> fileNeedsBadge fileSize) (directChatBinding ct) (pure Nothing)
descrBadge <- pure binding_ $>>= \chatBinding ->
let FD.ValidFileDescription fd = sndDescr
in sndBadgeProof user PHFileDescr {chatBinding, fileSize = fromInteger fileSize, descrHash = FD.sharedDescriptionHash fd, fileExpires}
withStore' $ \db -> do
createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
forM_ descrBadge $ createFileBadgeProof db fileId BPKDescription
sendFileDescriptions (ConnectionId connId) ((conn, sft, fileDescrText rfd) :| []) sharedMsgId fileExpires descrBadge >>= \case
Just rs -> case L.last rs of
Right ([msgDeliveryId], _) ->
withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId
@@ -247,9 +278,17 @@ processAgentMsgSndFile _corrId aFileId msg = do
ms <- getRecipients
let rfdsMemberFTs = zipWith (\rfd (conn, sft) -> (conn, sft, fileDescrText rfd)) rfds (memberFTs ms)
extraRFDs = drop (length rfdsMemberFTs) rfds
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
FileTransferMeta {fileSize} = ft
needsBadge <- fileNeedsBadge fileSize
let binding_ = if needsBadge && not (incognitoMembership g) then sndGroupChatBinding g showGroupAsSender else Nothing
descrBadge <- pure binding_ $>>= \chatBinding ->
let FD.ValidFileDescription fd = sndDescr
in sndBadgeProof user PHFileDescr {chatBinding, fileSize = fromInteger fileSize, descrHash = FD.sharedDescriptionHash fd, fileExpires}
withStore' $ \db -> do
createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
forM_ descrBadge $ createFileBadgeProof db fileId BPKDescription
forM_ (L.nonEmpty rfdsMemberFTs) $ \rfdsMemberFTs' ->
sendFileDescriptions (GroupId groupId) rfdsMemberFTs' sharedMsgId fileExpires
sendFileDescriptions (GroupId groupId) rfdsMemberFTs' sharedMsgId fileExpires descrBadge
ci' <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
getChatItemByFileId db cxt user fileId
@@ -278,8 +317,8 @@ processAgentMsgSndFile _corrId aFileId msg = do
where
fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
fileDescrText = safeDecodeUtf8 . strEncode
sendFileDescriptions :: ConnOrGroupId -> NonEmpty (Connection, SndFileTransfer, RcvFileDescrText) -> SharedMsgId -> Maybe UTCTime -> CM (Maybe (NonEmpty (Either ChatError ([Int64], PQEncryption))))
sendFileDescriptions connOrGroupId connsTransfersDescrs sharedMsgId fileExpires = do
sendFileDescriptions :: ConnOrGroupId -> NonEmpty (Connection, SndFileTransfer, RcvFileDescrText) -> SharedMsgId -> Maybe UTCTime -> Maybe BadgeProof -> CM (Maybe (NonEmpty (Either ChatError ([Int64], PQEncryption))))
sendFileDescriptions connOrGroupId connsTransfersDescrs sharedMsgId fileExpires descrBadge = do
lift . void . withStoreBatch' $ \db -> L.map (\(_, sft, rfdText) -> updateSndFTDescrXFTP db user sft rfdText) connsTransfersDescrs
partSize <- asks $ xftpDescrPartSize . config
let connsIdsEvts = connDescrEvents partSize
@@ -295,7 +334,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
where
splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json))]
splitText (conn, _, rfdText) =
map (\fileDescr -> (conn, (connOrGroupId, Nothing, XMsgFileDescr {msgId = sharedMsgId, fileDescr, fileExpires}))) (L.toList $ splitFileDescr partSize rfdText)
map (\fileDescr@FileDescr {fileDescrComplete} -> (conn, (connOrGroupId, Nothing, XMsgFileDescr {msgId = sharedMsgId, fileDescr, fileExpires, fileBadge = if fileDescrComplete then descrBadge else Nothing}))) (L.toList $ splitFileDescr partSize (maybe partSize (const badgeDescrPartSize) descrBadge) rfdText)
toMsgReq :: (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq
toMsgReq (conn, _) SndMessage {msgId, msgBody} =
(conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, (vrValue msgBody, [msgId]))
@@ -392,11 +431,8 @@ processAgentMsgRcvFile _corrId aFileId msg = do
type ShouldDeleteGroupConns = Bool
processAgentMessageConn :: StoreCxt -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = do
-- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert,
-- as in this case no need to ACK message - we can't process messages for this connection anyway.
entity <- critical agentConnId $ withStore (\db -> getConnectionEntity db cxt user $ AgentConnId agentConnId) >>= updateConnStatus
processAgentMessageConn :: StoreCxt -> User -> ConnectionEntity -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMessage =
case agentMessage of
END -> case entity of
RcvDirectMsgConnection _ (Just ct) -> toView $ CEvtContactAnotherClient user ct
@@ -410,23 +446,6 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
UserContactConnection conn uc ->
processContactConnMessage agentMessage entity conn uc
where
updateConnStatus :: ConnectionEntity -> CM ConnectionEntity
updateConnStatus acEntity = case agentMsgConnStatus (entityConnection acEntity) agentMessage of
Just connStatus -> do
let conn = (entityConnection acEntity) {connStatus}
withStore' $ \db -> updateConnectionStatus db conn connStatus
pure $ updateEntityConnStatus acEntity connStatus
Nothing -> pure acEntity
agentMsgConnStatus :: Connection -> AEvent e -> Maybe ConnStatus
agentMsgConnStatus Connection {connStatus = cs} = \case
JOINED True -> Just ConnSndReady
CONF {} -> Just ConnRequested
INFO {} -> Just ConnSndReady
CON _ -> Just ConnReady
ERR err | cs /= ConnReady && not (temporaryOrHostError err) -> Just $ ConnFailed (tshow err)
_ -> Nothing
processCONFpqSupport :: Connection -> PQSupport -> CM Connection
processCONFpqSupport conn@Connection {connId, pqSupport = pq} pq'
| pq == PQSupportOn && pq' == PQSupportOff = do
@@ -481,7 +500,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
Just gInfo -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
allowAgentConnectionAsync user conn'' confId gInfo_ $ XInfo profileToSend (groupMemberKey =<< gInfo_)
INFO pqSupport connInfo -> do
processINFOpqSupport conn pqSupport
void $ saveConnInfo conn connInfo
@@ -491,7 +510,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
withAckMessage' "new contact msg" agentConnId meta $ pure ()
SENT msgId _proxy -> do
void $ continueSending connEntity conn
sentMsgDeliveryEvent conn msgId
withStore' $ \db -> sentMsgDeliveryEvent db conn msgId
OK ->
-- [async agent commands] continuation on receiving OK
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
@@ -550,7 +569,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
let ct'' = ct' {activeConn = Just conn''} :: Contact
case event of
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
XMsgFileDescr sharedMsgId fileDescr fileExpires -> messageFileDescription ct'' sharedMsgId fileDescr fileExpires
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> messageFileDescription ct'' sharedMsgId fileDescr fileExpires fileBadge
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
XMsgDel sharedMsgId _ _ _ -> messageDelete ct'' sharedMsgId msg msgMeta
XMsgReact sharedMsgId _ _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
@@ -558,7 +577,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
XFile fInv -> processFileInvitation' ct'' fInv msg msgMeta
XFileCancel sharedMsgId -> xFileCancel ct'' sharedMsgId
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct'' sharedMsgId fileConnReq_ fName
XInfo p -> xInfo ct'' p
XInfo p _ -> xInfo ct'' p
XDirectDel -> xDirectDel ct'' msg msgMeta
XGrpInv gInv -> processGroupInvitation ct'' gInv msg msgMeta
XInfoProbe probe -> xInfoProbe (COMContact ct'') probe
@@ -591,24 +610,25 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
-- TODO check member ID
-- TODO update member profile
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn'' confId XOk
XInfo profile -> do
allowAgentConnectionAsync user conn'' confId Nothing XOk
XInfo profile _ -> do
ct' <- processContactProfileUpdate ct profile False `catchAllErrors` const (pure ct)
-- [incognito] send incognito profile
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
p <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True
allowAgentConnectionAsync user conn'' confId $ XInfo p
allowAgentConnectionAsync user conn'' confId Nothing $ XInfo p Nothing
void $ withStore' $ \db -> resetMemberContactFields db ct'
XGrpLinkInv glInv -> do
-- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group
memberKeys <- atomically . C.generateKeyPair =<< asks random
(gInfo, host) <- withStore $ \db -> do
liftIO $ deleteContactCardKeepConn db connId ct
createGroupInvitedViaLink db cxt user conn'' glInv
createGroupInvitedViaLink db cxt user conn'' memberKeys glInv
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
-- [incognito] send saved profile
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
allowAgentConnectionAsync user conn'' confId (Just gInfo) $ XInfo profileToSend (groupMemberKey gInfo)
toView $ CEvtBusinessLinkConnecting user gInfo host ct
_ -> messageError "CONF for existing contact must have x.grp.mem.info or x.info"
INFO pqSupport connInfo -> do
@@ -620,7 +640,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
-- TODO check member ID
-- TODO update member profile
pure ()
XInfo profile -> do
XInfo profile _ -> do
let prepared = isJust (preparedContact ct) || isJust (contactRequestId' ct)
void $ processContactProfileUpdate ct profile prepared
XOk -> pure ()
@@ -651,11 +671,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
withStore' $ \db -> resetContactConnInitiated db user conn'
SENT msgId proxy -> do
void $ continueSending connEntity conn
sentMsgDeliveryEvent conn msgId
checkSndInlineFTComplete conn msgId
cis <- withStore $ \db -> do
(fileEvent_, cis) <- withStore $ \db -> do
liftIO $ sentMsgDeliveryEvent db conn msgId
fileEvent_ <- checkSndInlineFTComplete db conn msgId
cis <- updateDirectItemsStatus' db ct conn msgId (CISSndSent SSPComplete)
liftIO $ forM cis $ \ci -> setDirectSndChatItemViaProxy db user ct ci (isJust proxy)
(fileEvent_,) <$> liftIO (forM cis $ \ci -> setDirectSndChatItemViaProxy db user ct ci (isJust proxy))
mapM_ toView fileEvent_
let acis = map ctItem cis
unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis
where
@@ -754,11 +775,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
case memberCategory m of
GCInviteeMember ->
case chatMsgEvent of
XGrpAcpt memId
XGrpAcpt memId mKey
| sameMemberId memId m -> do
withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
forM_ mKey $ \(MemberKey k) -> withStore' $ \db -> setMemberPubKey db (groupMemberId' m) k
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId XOk
allowAgentConnectionAsync user conn' confId (Just gInfo) XOk
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
XGrpRelayAcpt relayLink relayCap
| memberRole' membership == GROwner && isRelay m -> do
@@ -778,7 +800,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
liftIO $ updateGroupMemberStatus db userId m GSMemLeft
pure (relay', m {memberStatus = GSMemLeft})
-- complete the contact handshake so the relay receives INFO and cleans up its transient bookkeeping
allowAgentConnectionAsync user conn' confId XOk
allowAgentConnectionAsync user conn' confId (Just gInfo) XOk
toView $ CEvtGroupRelayUpdated user gInfo m' relay'
toViewTE $ TERelayRejected user gInfo reason
| otherwise -> messageError "x.grp.relay.reject: only owner should receive relay rejection"
@@ -790,11 +812,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
pgId = fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId),
useRelays' gInfo == isJust rcvPG && pgId rcvPG == pgId curPG -> do
-- XGrpLinkInv here means we are connecting via prepared group, and we have to update user and host member records
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
(gInfo'', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
gInfo' <- createUserMemberKey gInfo''
-- [incognito] send saved profile
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
allowAgentConnectionAsync user conn' confId $ XInfo profileToSend
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo' (fromLocalProfile <$> incognitoProfile)
allowAgentConnectionAsync user conn' confId (Just gInfo') $ XInfo profileToSend (groupMemberKey gInfo')
toView $ CEvtGroupLinkConnecting user gInfo' m'
| otherwise -> messageError "x.grp.link.inv: publicGroupId mismatch"
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
@@ -810,11 +833,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
-- TODO update member profile
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membershipMemId membershipProfile
allowAgentConnectionAsync user conn' confId (Just gInfo) $ XGrpMemInfo membershipMemId membershipProfile
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
_ -> messageError "CONF from member must have x.grp.mem.info"
INFO _pqSupport connInfo -> do
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
(signedMsg_, ChatMessage {chatVRange, chatMsgEvent}) <- parseChatMessage' conn connInfo
_conn' <- updatePeerChatVRange conn chatVRange
case chatMsgEvent of
XGrpMemInfo memId _memProfile
@@ -823,11 +846,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
pure ()
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
-- sent when connecting via group link
XInfo _ ->
XInfo _ mKey
-- TODO Keep rejected member to allow them to appeal against rejection.
when (memberStatus m == GSMemRejected) $ do
deleteMemberConnection' m True
withStore' $ \db -> deleteGroupMember db user m
| memberStatus m == GSMemRejected -> do
deleteMemberConnection' m True
withStore' $ \db -> deleteGroupMember db user m
| otherwise -> mapM_ (storeMemberKey gInfo m signedMsg_) mKey
XOk ->
-- transient relay-reject row cleanup after the rejection handshake completes
when (memberCategory m == GCHostMember && not (relayServesGroup gInfo)) $ do
@@ -913,7 +937,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
_ -> pure ()
toView $ CEvtJoinedGroupMember user gInfo'' m' {memberStatus = mStatus}
let Connection {viaUserContactLink} = conn
when (isJust viaUserContactLink && isNothing (memberContactId m')) $ sendXGrpLinkMem gInfo''
when (isJust viaUserContactLink && isNothing (memberContactId m')) $ sendXGrpLinkMem gInfo'' m'
if useRelays' gInfo''
then do
introduceInChannel cxt user gInfo'' m'
@@ -931,10 +955,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
_ -> False
when (groupFeatureAllowed SGFHistory gInfo'' && not memberIsCustomer) $ sendHistory user gInfo'' m'
where
sendXGrpLinkMem gInfo'' = do
sendXGrpLinkMem gInfo''' m' = do
gInfo'' <- createUserMemberKey gInfo'''
let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo''
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile)
void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo'' (fromIncognitoProfile <$> incognitoProfile)
sendGroupMemberMessages user gInfo'' conn [XGrpLinkMem profileToSend (groupMemberKey gInfo'')]
_ -> do
unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected
notifyMemberConnected gInfo m Nothing
@@ -1035,7 +1060,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
where
MsgContainer {scope, asGroup} = mc
-- file description is always allowed, to allow sending files to support scope
XMsgFileDescr sharedMsgId fileDescr fileExpires -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr fileExpires
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr fileExpires fileBadge
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
checkSendAsGroup asGroup_ $
memberCanSend (Just m'') msgScope $
@@ -1047,8 +1072,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
XFile fInv -> Nothing <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs
XFileCancel sharedMsgId -> xFileCancelGroup gInfo' (Just m'') sharedMsgId
XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName
XInfo p -> fmap ctx <$> xInfoMember gInfo' m'' p msg brokerTs
XGrpLinkMem p -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p
XInfo p mKey -> fmap ctx <$> xInfoMember gInfo' m'' p mKey msg brokerTs
XGrpLinkMem p mKey -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p mKey msg
XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs
XGrpRelayNew rl -> fmap ctx <$> xGrpRelayNew gInfo' m'' rl
XGrpRelayCap relayCap
@@ -1138,9 +1163,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
groupMsgReceived gInfo m conn msgMeta msgRcpt
SENT msgId proxy -> do
continued <- continueSending connEntity conn
sentMsgDeliveryEvent conn msgId
checkSndInlineFTComplete conn msgId
updateGroupItemsStatus gInfo m conn msgId GSSSent (Just $ isJust proxy)
(fileEvent_, acis) <- withStore $ \db -> do
liftIO $ sentMsgDeliveryEvent db conn msgId
fileEvent_ <- checkSndInlineFTComplete db conn msgId
(fileEvent_,) <$> updateGroupItemsStatus db gInfo m conn msgId GSSSent (Just $ isJust proxy)
mapM_ toView fileEvent_
unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis
when continued $ do
when (isUserGrpFwdRelay gInfo) $ serveRoster user gInfo m -- roster ahead of the resumed backlog
sendPendingGroupMessages user gInfo m conn
@@ -1229,7 +1257,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
pure (confId, m', relay)
allowAgentConnectionAsync user conn confId XOk
allowAgentConnectionAsync user conn confId (Just gInfo) XOk
toView $ CEvtGroupRelayUpdated user gInfo m' relay
else
-- TODO [relays] owner: TBC failed RelayStatus?
@@ -1359,9 +1387,9 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
REQ invId pqSupport _ connInfo rejectionSupported -> do
(signedMsg_, ChatMessage {chatVRange, chatMsgEvent}) <- parseChatMessage' conn connInfo
case chatMsgEvent of
XContact p xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ pqSupport rejectionSupported
XContact p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ pqSupport rejectionSupported
XMember p joiningMemberId joiningMemberKey viaRelay -> memberJoinRequestViaRelay invId chatVRange signedMsg_ p joiningMemberId joiningMemberKey viaRelay
XInfo p -> profileContactRequest invId chatVRange p Nothing Nothing Nothing pqSupport rejectionSupported
XInfo p _ -> profileContactRequest invId chatVRange p Nothing Nothing Nothing Nothing pqSupport rejectionSupported
XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv
XGrpRelayTest challenge _ -> xGrpRelayTest invId chatVRange challenge
-- TODO show/log error, other events in contact request
@@ -1435,8 +1463,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
-- TODO add debugging output
_ -> pure ()
where
profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> PQSupport -> Bool -> CM ()
profileContactRequest invId chatVRange p@Profile {displayName} xContactId_ welcomeMsgId_ requestMsg_ reqPQSup rejectionSupported = do
profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe MemberKey -> Maybe XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> PQSupport -> Bool -> CM ()
profileContactRequest invId chatVRange p@Profile {displayName} memberKey_ xContactId_ welcomeMsgId_ requestMsg_ reqPQSup rejectionSupported = do
(ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId
let v = maxVersion chatVRange
case gLinkInfo_ of
@@ -1589,7 +1617,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
maybe (pure $ Right (GAAccepted, gLinkMemRole)) (\am -> liftIO $ am gInfo gli p) acceptMember_ >>= \case
Right (acceptance, useRole) -> do
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode Nothing Nothing
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode memberKey_ Nothing
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem'
@@ -1649,9 +1677,9 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
where
-- replay defense: the viaRelay == own memberId check (viaRelay is in the signed body); without it a sibling relay could replay a privileged member's signed join
verifyKey gInfo rosterMem = case (signedMsg_, groupKeys gInfo) of
(Just SignedMsg {chatBinding = CBGroup, signatures, signedBody}, Just GroupKeys {publicGroupId}) ->
(Just SignedMsg {chatBinding = CBGroup, signatures, signedBody}, Just gks) ->
memberPubKey rosterMem == Just joiningKey
&& verifyGroupSig joiningKey publicGroupId joiningMemberId signatures signedBody
&& verifyGroupSig joiningKey (Just gks) joiningMemberId signatures signedBody
&& viaRelay == Just (memberId' (membership gInfo))
_ -> False
acceptJoin gInfo existingMem_ acceptRole = do
@@ -1773,9 +1801,9 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM ()
ackMsg MsgMeta {recipient = (msgId, _)} rcpt = withAgent $ \a -> ackMessageAsync a "" cId msgId rcpt
sentMsgDeliveryEvent :: Connection -> AgentMsgId -> CM ()
sentMsgDeliveryEvent Connection {connId} msgId =
withStore' $ \db -> updateSndMsgDeliveryStatus db connId msgId MDSSndSent
sentMsgDeliveryEvent :: DB.Connection -> Connection -> AgentMsgId -> IO ()
sentMsgDeliveryEvent db Connection {connId} msgId =
updateSndMsgDeliveryStatus db connId msgId MDSSndSent
agentSndError :: AgentErrorType -> SndError
agentSndError = \case
@@ -1891,7 +1919,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
let MsgContainer {ttl = itemTTL, live = live_} = mc
timed_ = rcvContactCITimed ct itemTTL
live = fromMaybe False live_
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
file_ <- processFileInvitation fInv_ content (rcvDirectFileProhibited ct) $ \db -> createRcvFileTransfer db userId ct
newChatItem (CIRcvMsgContent content, msgContentTexts content) (snd <$> file_) timed_ live
autoAcceptFile file_
where
@@ -1907,36 +1935,37 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
ChatConfig {autoAcceptFileSize = sz} <- asks config
when (sz > fileSize) $ receiveFileEvt' user ft False Nothing Nothing >>= toView
messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> Maybe UTCTime -> CM ()
messageFileDescription Contact {contactId} sharedMsgId fileDescr fileExpires = do
messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> Maybe UTCTime -> Maybe BadgeProof -> CM ()
messageFileDescription ct@Contact {contactId} sharedMsgId fileDescr fileExpires fileBadge = do
(fileId, aci) <- withStore $ \db -> do
fileId <- getFileIdBySharedMsgId db userId contactId sharedMsgId
aci <- getChatItemByFileId db cxt user fileId
pure (fileId, aci)
processFDMessage fileId aci fileDescr fileExpires
binding_ <- if isJust fileBadge then directChatBinding ct else pure Nothing
processFDMessage binding_ fileId aci fileDescr fileExpires fileBadge
groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> Maybe UTCTime -> CM (Maybe DeliveryTaskContext)
groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr fileExpires = do
groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> Maybe UTCTime -> Maybe BadgeProof -> CM (Maybe DeliveryTaskContext)
groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr fileExpires fileBadge = do
(fileId, aci) <- withStore $ \db -> do
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
aci <- getChatItemByFileId db cxt user fileId
pure (fileId, aci)
case aci of
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir}
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir, meta = CIMeta {showGroupAsSender}}
| validSender m_ chatDir -> do
-- in processFDMessage some paths are programmed as errors,
-- for example failure on not approved relays (CEFileNotApproved).
-- we catch error, so that even if processFDMessage fails, message can still be forwarded.
processFDMessage fileId aci fileDescr fileExpires `catchAllErrors` \_ -> pure ()
processFDMessage (rcvGroupChatBinding g m_ showGroupAsSender fileBadge) fileId aci fileDescr fileExpires fileBadge `catchAllErrors` \_ -> pure ()
pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir)
| otherwise -> messageError "x.msg.file.descr: file/sender mismatch" $> Nothing
_ -> messageError "x.msg.file.descr: invalid file description part" $> Nothing
processFDMessage :: FileTransferId -> AChatItem -> FileDescr -> Maybe UTCTime -> CM ()
processFDMessage fileId aci fileDescr fileExpires = do
processFDMessage :: Maybe ByteString -> FileTransferId -> AChatItem -> FileDescr -> Maybe UTCTime -> Maybe BadgeProof -> CM ()
processFDMessage binding_ fileId aci fileDescr fileExpires fileBadge = do
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
unless (rcvFileCompleteOrCancelled ft) $ do
(rfd@RcvFileDescr {fileDescrComplete}, ft'@RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs, fileInvitation = FileInvitation {fileSize}}) <- withStore $ \db -> do
(rfd@RcvFileDescr {fileDescrComplete}, ft'@RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs, fileProhibited, fileInvitation = FileInvitation {fileSize}}) <- withStore $ \db -> do
rfd <- appendRcvFD db userId fileId fileDescr
forM_ fileExpires $ liftIO . setFileExpiration db user fileId
-- reading second time in the same transaction as appending description
@@ -1944,16 +1973,41 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
ft' <- getRcvFileTransfer db user fileId
pure (rfd, ft')
when fileDescrComplete $ toView $ CEvtRcvFileDescrReady user aci ft' rfd
case (fileStatus, xftpRcvFile) of
(RFSAccepted _, Just XFTPRcvFile {userApprovedRelays}) -> receiveViaCompleteFD user fileId rfd fileSize userApprovedRelays cryptoArgs
_ -> pure ()
maxSize <- asks $ noBadge . fileSizeLimits . config
let descrBadgeRequired = fileDescrComplete && fileSize > maxSize && isNothing fileProhibited
prohibited_ <- case fileBadge of
_ | not descrBadgeRequired -> pure Nothing
Nothing -> pure $ Just FileProhibited {maxSize, badgeStatus = Nothing}
Just badge -> do
st <- descrBadgeStatus binding_ fileSize rfd fileExpires badge
if st == BSActive
then do
withStore' $ \db -> createFileBadgeProof db fileId BPKDescription badge
pure Nothing
else pure $ Just FileProhibited {maxSize, badgeStatus = Just st}
case prohibited_ of
Nothing -> case (fileStatus, xftpRcvFile) of
(RFSAccepted _, Just XFTPRcvFile {userApprovedRelays}) -> receiveViaCompleteFD user fileId rfd fileSize userApprovedRelays cryptoArgs
_ -> pure ()
-- the file may already be accepted, so it is reset to an invitation the apps refuse by its prohibition
Just prohibited -> do
withStore' $ \db -> setFileProhibited db user fileId prohibited
aci_ <- resetRcvCIFileStatus user fileId CIFSRcvInvitation
forM_ aci_ $ \aci' -> toView $ CEvtChatItemUpdated user aci'
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv -> do
descrBadgeStatus :: Maybe ByteString -> Integer -> RcvFileDescr -> Maybe UTCTime -> BadgeProof -> CM BadgeStatus
descrBadgeStatus binding_ fileSize RcvFileDescr {fileDescrText} fileExpires badge = do
FD.ValidFileDescription fd <- parseFileDescription @'FRecipient fileDescrText
let descrHash = FD.sharedDescriptionHash fd
badgeProofStatus ((\chatBinding -> PHFileDescr {chatBinding, fileSize = fromInteger fileSize, descrHash, fileExpires}) <$> binding_) badge
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (FileInvitation -> CM (Maybe FileProhibited)) -> (DB.Connection -> FileInvitation -> Maybe FileProhibited -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
processFileInvitation fInv_ mc fileProhibited_ createRcvFT = forM fInv_ $ \fInv -> do
ChatConfig {fileChunkSize} <- asks config
fInv'@FileInvitation {fileName, fileSize} <- validateFileInvitation fInv
fileProhibited <- fileProhibited_ fInv'
inline <- receiveInlineMode fInv' (Just mc) fileChunkSize
ft@RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFT db fInv' inline fileChunkSize
ft@RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFT db fInv' fileProhibited inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
(filePath, fileStatus, ft') <- case inline of
Just IFMSent -> do
@@ -1965,15 +2019,19 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
_ -> pure (Nothing, CIFSRcvInvitation, ft)
let RcvFileTransfer {cryptoArgs} = ft'
fileSource = (`CryptoFile` cryptoArgs) <$> filePath
pure (ft', CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires = Nothing})
pure (ft', CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires = Nothing, fileProhibited})
mkValidFileInvitation :: FileInvitation -> FileInvitation
mkValidFileInvitation fInv@FileInvitation {fileName} = fInv {fileName = safeFileNameStr fileName}
validateFileInvitation :: FileInvitation -> CM FileInvitation
validateFileInvitation fInv@FileInvitation {fileName, fileSize}
| fileSize > 0 = pure $ mkValidFileInvitation fInv
| otherwise = throwChatError $ CEFileSize fileName
validateFileInvitation fInv@FileInvitation {fileName, fileSize, fileDescr}
| fileSize <= 0 = throwChatError $ CEFileSize fileName
| otherwise = do
-- a file that requires a badge is received from the description message, where the proof binds the description
needsBadge <- fileNeedsBadge fileSize
let fileDescr' = if needsBadge then dummyFileDescr <$ fileDescr else fileDescr
pure $ mkValidFileInvitation fInv {fileDescr = fileDescr'}
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> CM ()
messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
@@ -2196,7 +2254,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
unless (maybe False memberBlocked m') $ autoAcceptFile file_
processFileInv gInfo' m' =
let fileMember_ = if sentAsGroup then Nothing else m'
in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_ FTNormal sharedMsgId_
in processFileInvitation fInv_ content (rcvGroupFileProhibited gInfo' m' sentAsGroup) $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_ FTNormal sharedMsgId_
newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed live = do
let mentions' = if maybe False memberBlocked m' then M.empty else mentions
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed live mentions'
@@ -2418,10 +2476,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
processFileInvitation' ct fInv msg@RcvMessage {sharedMsgId_} msgMeta = do
ChatConfig {fileChunkSize} <- asks config
fInv'@FileInvitation {fileName, fileSize} <- validateFileInvitation fInv
fileProhibited <- rcvDirectFileProhibited ct fInv'
inline <- receiveInlineMode fInv' Nothing fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv' inline fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv' fileProhibited inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing}
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing, fileProhibited}
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci]
@@ -2433,10 +2492,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
processGroupFileInvitation' gInfo m fInv msg@RcvMessage {sharedMsgId_} brokerTs = do
ChatConfig {fileChunkSize} <- asks config
fInv'@FileInvitation {fileName, fileSize} <- validateFileInvitation fInv
fileProhibited <- rcvGroupFileProhibited gInfo (Just m) False fInv'
inline <- receiveInlineMode fInv' Nothing fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) FTNormal sharedMsgId_ fInv' inline fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) FTNormal sharedMsgId_ fInv' fileProhibited inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing}
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing, fileProhibited}
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
(ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo Nothing m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
ci' <- blockedMemberCI gInfo m ci
@@ -2505,18 +2565,17 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
imageOrVoice _ = False
assertSMPAcceptNotProhibited _ = pure ()
checkSndInlineFTComplete :: Connection -> AgentMsgId -> CM ()
checkSndInlineFTComplete conn agentMsgId = do
sft_ <- withStore' $ \db -> getSndFTViaMsgDelivery db user conn agentMsgId
forM_ sft_ $ \sft@SndFileTransfer {fileId} -> do
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do
liftIO $ updateSndFileStatus db sft FSComplete
updateDirectCIFileStatus db cxt user fileId CIFSSndComplete
checkSndInlineFTComplete :: DB.Connection -> Connection -> AgentMsgId -> ExceptT StoreError IO (Maybe ChatEvent)
checkSndInlineFTComplete db conn agentMsgId = do
sft_ <- liftIO $ getSndFTViaMsgDelivery db user conn agentMsgId
forM sft_ $ \sft@SndFileTransfer {fileId} -> do
liftIO $ updateSndFileStatus db sft FSComplete
ci@(AChatItem _ _ _ ChatItem {file}) <- updateDirectCIFileStatus db cxt user fileId CIFSSndComplete
case file of
Just CIFile {fileProtocol = FPXFTP} -> do
ft <- withStore $ \db -> getFileTransferMeta db user fileId
toView $ CEvtSndFileCompleteXFTP user ci ft
_ -> toView $ CEvtSndFileComplete user ci sft
ft <- getFileTransferMeta db user fileId
pure $ CEvtSndFileCompleteXFTP user ci ft
_ -> pure $ CEvtSndFileComplete user ci sft
allowSendInline :: Integer -> Maybe InlineFileMode -> CM Bool
allowSendInline fileSize = \case
@@ -2618,14 +2677,15 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId
memberKeys <- atomically . C.generateKeyPair =<< asks random
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId memberKeys
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let GroupMember {groupMemberId, memberId = membershipMemId} = membership
-- hostContact is only reported for group links, where the client replaces
-- the transient host connection view with the group and removes its chat
joinGroupAsync hostContact_ sameLink = do
subMode <- chatReadVar subscriptionMode
dm <- encodeConnInfo $ XGrpAcpt membershipMemId
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (groupMemberKey gInfo)
connIds@(cmdId, acId) <- prepareAgentJoin user Nothing True connRequest
withStore' $ \db -> do
when sameLink $ setViaGroupLinkUri db groupId connId
@@ -2729,22 +2789,35 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
Profile {displayName = n, fullName = fn, shortDescr = sd, image = i, contactLink = cl} = p
Profile {displayName = n', fullName = fn', shortDescr = sd', image = i', contactLink = cl'} = p'
xInfoMember :: GroupInfo -> GroupMember -> Profile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xInfoMember gInfo m p' msg brokerTs = do
xInfoMember :: GroupInfo -> GroupMember -> Profile -> Maybe MemberKey -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xInfoMember gInfo m p' mKey msg@RcvMessage {signedMsg_} brokerTs = do
mapM_ (storeMemberKey gInfo m signedMsg_) mKey
void $ processMemberProfileUpdate gInfo m p' (Just (msg, brokerTs))
pure $ memberEventDeliveryScope m
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM ()
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> Maybe MemberKey -> RcvMessage -> CM ()
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' mKey RcvMessage {signedMsg_} = do
xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId
if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived
then do
mapM_ (storeMemberKey gInfo m signedMsg_) mKey
m' <- processMemberProfileUpdate gInfo m p' Nothing
withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True
let connectedIncognito = memberIncognito membership
probeMatchingMemberContact m' connectedIncognito
else messageError "x.grp.link.mem error: invalid group link host profile update"
storeMemberKey :: GroupInfo -> GroupMember -> Maybe SignedMsg -> MemberKey -> CM ()
storeMemberKey gInfo GroupMember {groupMemberId, memberPubKey, memberId} signedMsg_ (MemberKey k) = case memberPubKey of
Just k0 -> when (k /= k0) $ messageError "member key change rejected, keeping current key"
Nothing
| signed -> withStore' $ \db -> setMemberPubKey db groupMemberId k
| otherwise -> messageError "member key not signed by that key, ignored"
where
signed = case signedMsg_ of
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} -> verifyGroupSig k (groupKeys gInfo) memberId signatures signedBody
_ -> False
xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
xGrpLinkAcpt gInfo@GroupInfo {membership} m acceptance role memberId msg brokerTs
| memberRole' m < GRModerator || memberRole' m < role =
@@ -2840,7 +2913,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of
Just bc | isMainBusinessMember bc m -> do
g' <- withStore $ \db -> updateGroupProfileFromMember db user g p'
toView $ CEvtGroupUpdated user g g' (Just m) Nothing
toView $ CEvtGroupUpdated user g g' (Just m) ((\(RcvMessage {msgSigned}, _) -> msgSigned) =<< msgTs_)
_ -> pure ()
isMainBusinessMember BusinessChatInfo {chatType, businessId, customerId} GroupMember {memberId} = case chatType of
BCBusiness -> businessId == memberId
@@ -3076,16 +3149,18 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
conn' <- updatePeerChatVRange activeConn chatVRange
case chatMsgEvent of
XInfo p -> do
XInfo p _ -> do
ct <- withStore $ \db -> createDirectContact db cxt user conn' p
toView $ CEvtContactConnecting user ct
pure (conn', Nothing)
XGrpLinkInv glInv -> do
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db cxt user conn' glInv
memberKeys <- atomically . C.generateKeyPair =<< asks random
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db cxt user conn' memberKeys glInv
toView $ CEvtGroupLinkConnecting user gInfo host
pure (conn', Just gInfo)
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db cxt user conn' glRjct
memberKeys <- atomically . C.generateKeyPair =<< asks random
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db cxt user conn' memberKeys glRjct
toView $ CEvtGroupLinkConnecting user gInfo host
toViewTE $ TEGroupLinkRejected user gInfo rejectionReason
pure (conn', Just gInfo)
@@ -3389,7 +3464,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
cleanupRosterTransfer gInfo (groupMemberId' fromMember)
let relayHdr = if isUserGrpFwdRelay gInfo then Just sm else Nothing
chSize <- asks $ fileChunkSize . config
let rosterFInv = FileInvitation {fileName = "roster", fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Just IFMSent, fileDescr = Nothing}
let rosterFInv = FileInvitation {fileName = "roster", fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Just IFMSent, fileDescr = Nothing, fileBadge = Nothing}
-- transfer record + its scratch file in one transaction (file owned by the transfer, keyed per source)
rft@RcvFileTransfer {fileId} <- withStore $ \db -> do
transferId <- liftIO $ createRosterTransfer db gInfo (groupMemberId' fromMember) newVer fileDigest (groupMemberId' author) brokerTs relayHdr
@@ -3826,7 +3901,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
-- [incognito] send membership incognito profile
p <- presentUserBadge user (incognitoMembershipProfile g) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True
-- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ)
dm <- encodeConnInfo $ XInfo p
dm <- encodeConnInfo $ XInfo p Nothing
joinAgentConnectionAsync cmdId False acId True connReq dm subMode
createItems mCt' m' = do
(g', m'', scopeInfo) <- mkGroupChatScope g m'
@@ -3878,13 +3953,13 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
where
MsgContainer {scope} = mc
-- file description is always allowed, to allow sending files to support scope
XMsgFileDescr sharedMsgId fileDescr fileExpires -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr fileExpires
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr fileExpires fileBadge
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_
XMsgDel sharedMsgId memId scope_ _ -> void $ groupMessageDelete gInfo author_ sharedMsgId memId scope_ False rcvMsg msgTs
XMsgReact sharedMsgId memId scope_ reaction add -> withAuthor XMsgReact_ $ \author -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs
XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId
XInfo p -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p rcvMsg msgTs
XInfo p mKey -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p mKey rcvMsg msgTs
XGrpRelayNew rl -> withAuthor XGrpRelayNew_ $ \author -> void $ xGrpRelayNew gInfo author rl
XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs
XGrpMemRole memId memRole memberKey rosterVer -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo (Just m) author memId memRole memberKey rosterVer rcvMsg msgTs
@@ -3903,7 +3978,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author"
withVerifiedMsg :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ParsedMsg e -> UTCTime -> (VerifiedMsg e -> CM a) -> CM (Maybe a)
withVerifiedMsg gInfo@GroupInfo {membership} scopeInfo member (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action =
withVerifiedMsg gInfo@GroupInfo {membership, groupKeys} scopeInfo member@GroupMember {memberPubKey, memberId} (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action =
case verified of
Just verifiedMsg -> Just <$> action verifiedMsg
Nothing -> do
@@ -3911,17 +3986,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
pure Nothing
where
verified = case signedMsg_ of
Just sm@SignedMsg {chatBinding, signatures, signedBody}
| GroupMember {memberPubKey = Just pubKey, memberId} <- member ->
case chatBinding of
CBGroup
| Just GroupKeys {publicGroupId} <- groupKeys gInfo ->
signed MSSVerified <$ guard (verifyGroupSig pubKey publicGroupId memberId signatures signedBody)
| otherwise ->
let prefix = smpEncode chatBinding <> smpEncode (memberId, pubKey) -- forward compatibility for verifying signed messages in p2p groups
in signed MSSVerified <$ guard (all (\case (MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig (prefix <> signedBody)) signatures)
_ -> signed MSSSignedNoKey <$ guard signatureOptional
| otherwise -> signed MSSSignedNoKey <$ guard (signatureOptional || unverifiedAllowed membership member tag)
Just sm@SignedMsg {chatBinding, signatures, signedBody} -> case memberPubKey of
Just pubKey -> case chatBinding of
CBGroup -> signed MSSVerified <$ guard (verifyGroupSig pubKey groupKeys memberId signatures signedBody)
_ -> signed MSSSignedNoKey <$ guard signatureOptional
Nothing -> signed MSSSignedNoKey <$ guard (signatureOptional || unverifiedAllowed membership member tag)
where
signed status = VMSigned status sm chatMsg
Nothing -> VMUnsigned chatMsg <$ guard signatureOptional
@@ -3941,8 +4010,10 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
(gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m
checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchAllErrors` \_ -> pure ()
forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
updateGroupItemsStatus gInfo' m' conn agentMsgId (GSSRcvd msgRcptStatus) Nothing
acis <- withStore $ \db -> do
liftIO $ updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
updateGroupItemsStatus db gInfo' m' conn agentMsgId (GSSRcvd msgRcptStatus) Nothing
unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis
-- Searches chat items for many agent message IDs and updates their status
updateDirectItemsStatusMsgs :: Contact -> Connection -> [AgentMsgId] -> CIStatus 'MDSnd -> CM ()
@@ -3983,22 +4054,20 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
| otherwise -> updateGroupSndStatus db itemId groupMemberId newStatus $> True
_ -> pure False
updateGroupItemsStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> GroupSndStatus -> Maybe Bool -> CM ()
updateGroupItemsStatus gInfo@GroupInfo {groupId} GroupMember {groupMemberId} Connection {connId} msgId newMemStatus viaProxy_ = do
acis <- withStore $ \db -> do
items <- liftIO $ getGroupChatItemsByAgentMsgId db user groupId connId msgId
cis <- catMaybes <$> mapM (updateItem db) items
-- SENT and RCVD events are received for messages that may be batched in single scope,
-- so we can look up scope of first item
scopeInfo <- case cis of
(ci : _) -> getGroupChatScopeInfoForItem db cxt user gInfo (chatItemId' ci)
_ -> pure Nothing
pure $ map (gItem scopeInfo) cis
unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis
updateGroupItemsStatus :: DB.Connection -> GroupInfo -> GroupMember -> Connection -> AgentMsgId -> GroupSndStatus -> Maybe Bool -> ExceptT StoreError IO [AChatItem]
updateGroupItemsStatus db gInfo@GroupInfo {groupId} GroupMember {groupMemberId} Connection {connId} msgId newMemStatus viaProxy_ = do
items <- liftIO $ getGroupChatItemsByAgentMsgId db user groupId connId msgId
cis <- catMaybes <$> mapM updateItem items
-- SENT and RCVD events are received for messages that may be batched in single scope,
-- so we can look up scope of first item
scopeInfo <- case cis of
(ci : _) -> getGroupChatScopeInfoForItem db cxt user gInfo (chatItemId' ci)
_ -> pure Nothing
pure $ map (gItem scopeInfo) cis
where
gItem scopeInfo ci = AChatItem SCTGroup SMDSnd (GroupChat gInfo scopeInfo) ci
updateItem :: DB.Connection -> CChatItem 'CTGroup -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
updateItem db = \case
updateItem :: CChatItem 'CTGroup -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
updateItem = \case
(CChatItem SMDSnd ChatItem {meta = CIMeta {itemStatus = CISSndRcvd _ SSPComplete}}) -> pure Nothing
(CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}}) -> do
forM_ viaProxy_ $ \viaProxy -> liftIO $ setGroupSndViaProxy db itemId groupMemberId viaProxy
@@ -4379,7 +4448,7 @@ runRelayRequestWorker a Worker {doWork} = do
r -> pure r
scheduleRequest :: GroupId -> NominalDiffTime -> CM ()
scheduleRequest groupId delay = do
v_ <- liftIO $ atomically $
v_ <- atomically $
ifM
(isNothing <$> TM.lookup groupId delayThreads)
(newEmptyTMVar >>= \v -> TM.insert groupId v delayThreads $> Just v)
@@ -4390,7 +4459,7 @@ runRelayRequestWorker a Worker {doWork} = do
atomically $ TM.delete groupId delayThreads
void $ atomically $ tryPutTMVar doWork ()
weakTId <- liftIO $ mkWeakThreadId tId
liftIO $ atomically $ putTMVar v weakTId
atomically $ putTMVar v weakTId
retryTmpError :: (Int, NominalDiffTime) -> GroupId -> RelayRequestData -> ChatError -> CM ()
retryTmpError (retriesThreshold, ttl) groupId RelayRequestData {reqDelay, reqRetries, reqCreatedAt} = \case
ChatErrorAgent {agentError} | temporaryOrHostError agentError -> do
@@ -4450,7 +4519,7 @@ runRelayRequestWorker a Worker {doWork} = do
gVar <- asks random
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
subMode <- chatReadVar subscriptionMode
sigKeys <- liftIO $ atomically $ C.generateKeyPair gVar
sigKeys <- atomically $ C.generateKeyPair gVar
let crClientData = encodeJSON $ CRDataGroup groupLinkId
-- prepare link with relayMemId as linkEntityId (no server request)
(ccLink, preparedParams) <- withAgent $ \a' -> prepareConnectionLink a' (aUserId user) sigKeys relayMemId True (Just crClientData) CR.IKPQOff False Nothing
src/Simplex/Chat/Messages.hs
+2 -1
View File
@@ -688,7 +688,8 @@ data CIFile (d :: MsgDirection) = CIFile
fileSource :: Maybe CryptoFile, -- local file path with optional key and nonce
fileStatus :: CIFileStatus d,
fileProtocol :: FileProtocol,
fileExpires :: Maybe UTCTime
fileExpires :: Maybe UTCTime,
fileProhibited :: Maybe FileProhibited
}
deriving (Show)
src/Simplex/Chat/Messages/Batch.hs
+1 -1
View File
@@ -67,7 +67,7 @@ batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0)
| msgLen <= maxLen = (addBatch acc, [body], [msg], msgLen, 1)
| otherwise = (errLarge msg : addBatch acc, [], [], 0, 0)
where
body = encodeBatchElement signedMsg_ msgBody
body = encodeBatchElement (if mode == BMBinary then signedMsg_ else Nothing) msgBody
msgLen = B.length body
len' = len + msgLen
n' = n + 1
src/Simplex/Chat/Mobile.hs
+1
View File
@@ -259,6 +259,7 @@ mobileChatOpts dbOptions =
logAgent = Nothing,
logFile = Nothing,
tbqSize = 4096,
maxChats = 5000,
deviceName = Nothing,
chatRelay = False,
webPreviewConfig = Nothing,
src/Simplex/Chat/Options.hs
+11
View File
@@ -67,6 +67,7 @@ data CoreChatOpts = CoreChatOpts
logAgent :: Maybe LogLevel,
logFile :: Maybe FilePath,
tbqSize :: Natural,
maxChats :: Int,
deviceName :: Maybe Text,
chatRelay :: Bool,
webPreviewConfig :: Maybe WebPreviewConfig,
@@ -234,6 +235,15 @@ coreChatOptsP appDir defaultDbName = do
<> value 1024
<> showDefault
)
maxChats <-
option
auto
( long "max-chats"
<> metavar "COUNT"
<> help "Max number of chats loaded by chat list API"
<> value 5000
<> showDefault
)
deviceName <-
optional $
strOption
@@ -340,6 +350,7 @@ coreChatOptsP appDir defaultDbName = do
logAgent = if logAgent || logLevel == CLLDebug then Just $ agentLogLevel logLevel else Nothing,
logFile,
tbqSize,
maxChats,
deviceName,
chatRelay,
webPreviewConfig,
src/Simplex/Chat/Protocol.hs
+28 -21
View File
@@ -50,7 +50,7 @@ import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word16, Word32)
import Simplex.Chat.Badges (LocalBadge)
import Simplex.Chat.Badges (BadgeProof, LocalBadge)
import Simplex.Chat.Call
import Simplex.Chat.Options.DB (FromField (..), ToField (..))
import Simplex.Chat.Types
@@ -86,12 +86,13 @@ import Simplex.Messaging.Version hiding (version)
-- 17 - allow host voice messages during member approval regardless of group voice setting (2026-02-10)
-- 18 - relay web capabilities (2026-05-31)
-- 19 - group roster (2026-06-18)
-- 20 - p2p group member keys for signing (2026-07-26)
-- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig.
-- This indirection is needed for backward/forward compatibility testing.
-- Testing with real app versions is still needed, as tests use the current code with different version ranges, not the old code.
currentChatVersion :: VersionChat
currentChatVersion = VersionChat 19
currentChatVersion = VersionChat 20
-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
supportedChatVRange :: VersionRangeChat
@@ -135,6 +136,10 @@ relayWebCapVersion = VersionChat 18
groupRosterVersion :: VersionChat
groupRosterVersion = VersionChat 19
-- members sign messages in p2p groups; member keys are distributed for verification
groupMemberKeyVersion :: VersionChat
groupMemberKeyVersion = VersionChat 20
data ConnectionEntity
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
@@ -446,7 +451,7 @@ signChatMsgBody MsgSigning {bindingTag, bindingData, keyRef, privKey} msgBody =
data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr, fileExpires :: Maybe UTCTime} -> ChatMsgEvent 'Json
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr, fileExpires :: Maybe UTCTime, fileBadge :: Maybe BadgeProof} -> ChatMsgEvent 'Json
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MsgMention, ttl :: Maybe Int, live :: Maybe Bool, scope :: Maybe MsgScope, asGroup :: Maybe Bool} -> ChatMsgEvent 'Json
XMsgDel :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope, onlyHistory :: Bool} -> ChatMsgEvent 'Json
XMsgDeleted :: ChatMsgEvent 'Json
@@ -455,15 +460,15 @@ data ChatMsgEvent (e :: MsgEncoding) where
XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol
XFileAcptInv :: SharedMsgId -> Maybe ConnReqInvitation -> String -> ChatMsgEvent 'Json
XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
XInfo :: Profile -> ChatMsgEvent 'Json
XContact :: {profile :: Profile, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json
XInfo :: {profile :: Profile, memberKey :: Maybe MemberKey} -> ChatMsgEvent 'Json
XContact :: {profile :: Profile, memberKey :: Maybe MemberKey, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json
XMember :: {profile :: Profile, newMemberId :: MemberId, newMemberKey :: MemberKey, viaRelay :: Maybe MemberId} -> ChatMsgEvent 'Json
XDirectDel :: ChatMsgEvent 'Json
XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json
XGrpAcpt :: MemberId -> ChatMsgEvent 'Json
XGrpAcpt :: MemberId -> Maybe MemberKey -> ChatMsgEvent 'Json
XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json
XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json
XGrpLinkMem :: Profile -> ChatMsgEvent 'Json
XGrpLinkMem :: Profile -> Maybe MemberKey -> ChatMsgEvent 'Json
XGrpLinkAcpt :: GroupAcceptance -> GroupMemberRole -> MemberId -> ChatMsgEvent 'Json
XGrpRelayInv :: GroupRelayInvitation -> ChatMsgEvent 'Json
XGrpRelayAcpt :: ShortLinkContact -> RelayCapabilities -> ChatMsgEvent 'Json
@@ -522,7 +527,7 @@ isForwardedGroupMsg ev = case ev of
XMsgDel {} -> True
XMsgReact {} -> True
XFileCancel _ -> True
XInfo _ -> True
XInfo {} -> True
XGrpRelayNew _ -> True
XGrpMemNew {} -> True
XGrpMemRole {} -> True
@@ -1248,15 +1253,15 @@ toCMEventTag msg = case msg of
XFileAcpt _ -> XFileAcpt_
XFileAcptInv {} -> XFileAcptInv_
XFileCancel _ -> XFileCancel_
XInfo _ -> XInfo_
XInfo {} -> XInfo_
XContact {} -> XContact_
XMember {} -> XMember_
XDirectDel -> XDirectDel_
XGrpInv _ -> XGrpInv_
XGrpAcpt _ -> XGrpAcpt_
XGrpAcpt {} -> XGrpAcpt_
XGrpLinkInv _ -> XGrpLinkInv_
XGrpLinkReject _ -> XGrpLinkReject_
XGrpLinkMem _ -> XGrpLinkMem_
XGrpLinkMem {} -> XGrpLinkMem_
XGrpLinkAcpt {} -> XGrpLinkAcpt_
XGrpRelayInv _ -> XGrpRelayInv_
XGrpRelayAcpt {} -> XGrpRelayAcpt_
@@ -1342,6 +1347,7 @@ requiresSignature = \case
XGrpRelayNew_ -> True
XGrpRoster_ -> True
XInfo_ -> True
XGrpLinkMem_ -> True
_ -> False
-- | Content events a member may sign (XMsgNew opt-in; XMsgUpdate/XMsgDel when the target was signed).
@@ -1391,7 +1397,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
msg :: CMEventTag 'Json -> Either String (ChatMsgEvent 'Json)
msg = \case
XMsgNew_ -> XMsgNew <$> JT.parseEither parseJSON (J.Object params)
XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr" <*> opt "fileExpires"
XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr" <*> opt "fileExpires" <*> opt "fileBadge"
XMsgUpdate_ -> do
msgId' <- p "msgId"
content <- p "content"
@@ -1408,22 +1414,23 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
XFileAcpt_ -> XFileAcpt <$> p "fileName"
XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> opt "fileConnReq" <*> p "fileName"
XFileCancel_ -> XFileCancel <$> p "msgId"
XInfo_ -> XInfo <$> p "profile"
XInfo_ -> XInfo <$> p "profile" <*> opt "memberKey"
XContact_ -> do
profile <- p "profile"
memberKey <- opt "memberKey"
contactReqId <- opt "contactReqId"
welcomeMsgId <- opt "welcomeMsgId"
reqMsgId <- opt "msgId"
reqContent <- opt "content"
let requestMsg = (,) <$> reqMsgId <*> reqContent
pure XContact {profile, contactReqId, welcomeMsgId, requestMsg}
pure XContact {profile, memberKey, contactReqId, welcomeMsgId, requestMsg}
XMember_ -> XMember <$> p "profile" <*> p "newMemberId" <*> p "newMemberKey" <*> opt "viaRelay"
XDirectDel_ -> pure XDirectDel
XGrpInv_ -> XGrpInv <$> p "groupInvitation"
XGrpAcpt_ -> XGrpAcpt <$> p "memberId"
XGrpAcpt_ -> XGrpAcpt <$> p "memberId" <*> opt "memberKey"
XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation"
XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection"
XGrpLinkMem_ -> XGrpLinkMem <$> p "profile"
XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" <*> opt "memberKey"
XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "acceptance" <*> p "role" <*> p "memberId"
XGrpRelayInv_ -> XGrpRelayInv <$> p "groupRelayInvitation"
XGrpRelayAcpt_ -> XGrpRelayAcpt <$> p "relayLink" <*> (fromMaybe defaultRelayCapabilities <$> opt "relayCap")
@@ -1482,7 +1489,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
XMsgNew mc -> case toJSON mc of
J.Object obj -> obj
_ -> JM.empty
XMsgFileDescr msgId' fileDescr fileExpires -> o $ ("fileExpires" .=? fileExpires) ["msgId" .= msgId', "fileDescr" .= fileDescr]
XMsgFileDescr msgId' fileDescr fileExpires fileBadge -> o $ ("fileExpires" .=? fileExpires) $ ("fileBadge" .=? fileBadge) ["msgId" .= msgId', "fileDescr" .= fileDescr]
XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope, asGroup} -> o $ ("asGroup" .=? asGroup) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' memberId scope onlyHistory -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) $ ("onlyHistory" .=? justTrue onlyHistory) ["msgId" .= msgId']
XMsgDeleted -> JM.empty
@@ -1491,15 +1498,15 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
XFileAcpt fileName -> o ["fileName" .= fileName]
XFileAcptInv sharedMsgId fileConnReq fileName -> o $ ("fileConnReq" .=? fileConnReq) ["msgId" .= sharedMsgId, "fileName" .= fileName]
XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId]
XInfo profile -> o ["profile" .= profile]
XContact {profile, contactReqId, welcomeMsgId, requestMsg} -> o $ ("contactReqId" .=? contactReqId) $ ("welcomeMsgId" .=? welcomeMsgId) $ ("msgId" .=? (fst <$> requestMsg)) $ ("content" .=? (snd <$> requestMsg)) $ ["profile" .= profile]
XInfo {profile, memberKey} -> o $ ("memberKey" .=? memberKey) ["profile" .= profile]
XContact {profile, memberKey, contactReqId, welcomeMsgId, requestMsg} -> o $ ("contactReqId" .=? contactReqId) $ ("welcomeMsgId" .=? welcomeMsgId) $ ("msgId" .=? (fst <$> requestMsg)) $ ("content" .=? (snd <$> requestMsg)) $ ("memberKey" .=? memberKey) $ ["profile" .= profile]
XMember {profile, newMemberId, newMemberKey, viaRelay} -> o $ ("viaRelay" .=? viaRelay) ["profile" .= profile, "newMemberId" .= newMemberId, "newMemberKey" .= newMemberKey]
XDirectDel -> JM.empty
XGrpInv groupInv -> o ["groupInvitation" .= groupInv]
XGrpAcpt memId -> o ["memberId" .= memId]
XGrpAcpt memId memberKey -> o $ ("memberKey" .=? memberKey) ["memberId" .= memId]
XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv]
XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct]
XGrpLinkMem profile -> o ["profile" .= profile]
XGrpLinkMem profile memberKey -> o $ ("memberKey" .=? memberKey) ["profile" .= profile]
XGrpLinkAcpt acceptance role memberId -> o ["acceptance" .= acceptance, "role" .= role, "memberId" .= memberId]
XGrpRelayInv groupRelayInv -> o ["groupRelayInvitation" .= groupRelayInv]
XGrpRelayAcpt relayLink relayCap -> o ["relayLink" .= relayLink, "relayCap" .= relayCap]
src/Simplex/Chat/Store/Files.hs
+81 -20
View File
@@ -45,6 +45,9 @@ module Simplex.Chat.Store.Files
updateSndFileStatus,
createRcvFileTransfer,
createRcvGroupFileTransfer,
createFileBadgeProof,
getFileBadgeProofs,
setFileProhibited,
createRosterRcvFile,
createRcvStandaloneFileTransfer,
appendRcvFD,
@@ -86,6 +89,7 @@ import Control.Monad.IO.Class
import Data.Either (rights)
import Data.Functor ((<&>))
import Data.Int (Int64)
import Data.List (foldl')
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
@@ -93,6 +97,7 @@ import Data.Time (addUTCTime)
import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
import Data.Type.Equality
import Data.Word (Word32)
import Simplex.Chat.Badges (BadgeProof, BadgeProofKind (..), BadgeProofRow, BadgeStatus (..), badgeProofToRow, rowToBadgeProof)
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Store.Messages
@@ -180,7 +185,7 @@ getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMs
<$> (contactName_ <|> memberName_)
createSndFileTransferXFTP :: DB.Connection -> User -> Maybe ContactOrGroup -> CryptoFile -> FileInvitation -> AgentSndFileId -> Maybe FileTransferId -> Integer -> IO FileTransferMeta
createSndFileTransferXFTP db User {userId} contactOrGroup_ (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize} agentSndFileId xftpRedirectFor chunkSize = do
createSndFileTransferXFTP db User {userId} contactOrGroup_ (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize, fileBadge} agentSndFileId xftpRedirectFor chunkSize = do
currentTs <- getCurrentTime
let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False, cryptoArgs}
DB.execute
@@ -188,6 +193,7 @@ createSndFileTransferXFTP db User {userId} contactOrGroup_ (CryptoFile filePath
"INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, redirect_file_id, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
(maybe (Nothing, Nothing) contactAndGroupIds contactOrGroup_ :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize) :. (xftpRedirectFor, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
fileId <- insertedRowId db
forM_ fileBadge $ createFileBadgeProof db fileId BPKInvitation
pure FileTransferMeta {fileId, xftpSndFile, xftpRedirectFor, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO ()
@@ -445,8 +451,8 @@ updateSndFileStatus db SndFileTransfer {fileId, connId} status = do
currentTs <- getCurrentTime
DB.execute db "UPDATE snd_files SET file_status = ?, updated_at = ? WHERE file_id = ? AND connection_id = ?" (status, currentTs, fileId, connId)
createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe FileProhibited -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr, fileBadge} prohibited_ rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
@@ -456,18 +462,57 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
fileId <- liftIO $ do
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, currentTs, currentTs)
"INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_max_size, file_badge_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
((userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol) :. prohibitedRow prohibited_ :. (currentTs, currentTs))
insertedRowId db
liftIO $
liftIO $ do
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs)
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, fileType = FTNormal, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing}
forM_ (storedBadge prohibited_ fileBadge) $ createFileBadgeProof db fileId BPKInvitation
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileProhibited = prohibited_, fileStatus = RFSNew, fileType = FTNormal, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing}
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> Maybe GroupMember -> FileType -> Maybe SharedMsgId -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ fileType sharedMsgId_ f@FileInvitation {fileName, fileSize, fileDigest, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
setFileProhibited :: DB.Connection -> User -> Int64 -> FileProhibited -> IO ()
setFileProhibited db User {userId} fileId FileProhibited {maxSize, badgeStatus} = do
currentTs <- getCurrentTime
DB.execute
db
"UPDATE files SET file_max_size = ?, file_badge_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?"
(maxSize, badgeStatus, currentTs, userId, fileId)
prohibitedRow :: Maybe FileProhibited -> (Maybe Integer, Maybe BadgeStatus)
prohibitedRow = \case
Just FileProhibited {maxSize, badgeStatus} -> (Just maxSize, badgeStatus)
Nothing -> (Nothing, Nothing)
-- a proof that did not verify is not stored - files.file_badge_status records that it failed
storedBadge :: Maybe FileProhibited -> Maybe BadgeProof -> Maybe BadgeProof
storedBadge prohibited_ badge_ = case prohibited_ of
Just FileProhibited {badgeStatus = Just st} | st /= BSActive -> Nothing
_ -> badge_
createFileBadgeProof :: DB.Connection -> Int64 -> BadgeProofKind -> BadgeProof -> IO ()
createFileBadgeProof db fileId kind badge = do
currentTs <- getCurrentTime
DB.execute
db
[sql|
INSERT INTO file_badge_proofs (file_id, proof_kind, badge_proof, badge_pres_header, badge_key_idx, badge_type, badge_expiry, badge_extra, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?)
ON CONFLICT (file_id, proof_kind) DO UPDATE SET
badge_proof = excluded.badge_proof,
badge_pres_header = excluded.badge_pres_header,
badge_key_idx = excluded.badge_key_idx,
badge_type = excluded.badge_type,
badge_expiry = excluded.badge_expiry,
badge_extra = excluded.badge_extra,
updated_at = excluded.updated_at
|]
((fileId, kind) :. badgeProofToRow badge :. (currentTs, currentTs))
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> Maybe GroupMember -> FileType -> Maybe SharedMsgId -> FileInvitation -> Maybe FileProhibited -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ fileType sharedMsgId_ f@FileInvitation {fileName, fileSize, fileDigest, fileConnReq, fileInline, fileDescr, fileBadge} prohibited_ rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
@@ -479,15 +524,16 @@ createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gNam
fileId <- liftIO $ do
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
((userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, fileType, sharedMsgId_, currentTs, currentTs) :. Only fileDigest)
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest, file_max_size, file_badge_status) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
((userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, fileProtocol, fileType, sharedMsgId_, currentTs, currentTs) :. Only fileDigest :. prohibitedRow prohibited_)
insertedRowId db
liftIO $
liftIO $ do
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, grpMemberId_, rfdId, currentTs, currentTs)
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, fileType, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = grpMemberId_, cryptoArgs = Nothing}
forM_ (storedBadge prohibited_ fileBadge) $ createFileBadgeProof db fileId BPKInvitation
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileProhibited = prohibited_, fileStatus = RFSNew, fileType, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = grpMemberId_, cryptoArgs = Nothing}
-- Roster scratch file owned by a per-source transfer: group_member_id is the delivering relay (so chunk
-- streams from different relays are distinct files), roster_transfer_id links to the metadata record.
@@ -506,7 +552,7 @@ createRosterRcvFile db userId GroupInfo {groupId} src@GroupMember {localDisplayN
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, grpMemberId_, currentTs, currentTs)
pure RcvFileTransfer {fileId, xftpRcvFile = Nothing, fileInvitation = f, fileStatus = RFSNew, fileType = FTRoster, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = Just grpMemberId_, cryptoArgs = Nothing}
pure RcvFileTransfer {fileId, xftpRcvFile = Nothing, fileInvitation = f, fileProhibited = Nothing, fileStatus = RFSNew, fileType = FTRoster, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = Just grpMemberId_, cryptoArgs = Nothing}
createRcvStandaloneFileTransfer :: DB.Connection -> UserId -> CryptoFile -> Int64 -> Word32 -> ExceptT StoreError IO Int64
createRcvStandaloneFileTransfer db userId (CryptoFile filePath cfArgs_) fileSize chunkSize = do
@@ -586,7 +632,7 @@ rcvFileDescrWithinLimits partNo descrText =
&& T.length descrText <= maxRcvFileDescrTextLength
getRcvFileDescrByRcvFileId :: DB.Connection -> FileTransferId -> ExceptT StoreError IO RcvFileDescr
getRcvFileDescrByRcvFileId db fileId = do
getRcvFileDescrByRcvFileId db fileId =
liftIO (getRcvFileDescrByRcvFileId_ db fileId) >>= \case
Nothing -> throwError $ SERcvFileDescrNotFound fileId
Just rfd -> pure rfd
@@ -625,6 +671,19 @@ getRcvFileDescrBySndFileId_ db fileId =
|]
(Only fileId)
getFileBadgeProofs :: DB.Connection -> Int64 -> IO (Maybe BadgeProof, Maybe BadgeProof)
getFileBadgeProofs db fileId = foldl' addProof (Nothing, Nothing) <$> DB.query db q (Only fileId)
where
q =
[sql|
SELECT proof_kind, badge_proof, badge_pres_header, badge_key_idx, badge_type, badge_expiry, badge_extra
FROM file_badge_proofs
WHERE file_id = ?
|]
addProof (inv_, descr_) (Only kind :. row) = case kind of
BPKInvitation -> (rowToBadgeProof row, descr_)
BPKDescription -> (inv_, rowToBadgeProof row)
toRcvFileDescr :: (Int64, Text, Int, BoolInt) -> RcvFileDescr
toRcvFileDescr (fileDescrId, fileDescrText, fileDescrPartNo, BI fileDescrComplete) =
RcvFileDescr {fileDescrId, fileDescrText, fileDescrPartNo, fileDescrComplete}
@@ -652,7 +711,8 @@ getRcvFileTransfer_ db userId fileId = do
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline,
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest,
f.file_max_size, f.file_badge_status
FROM rcv_files r
JOIN files f USING (file_id)
LEFT JOIN contacts cs ON cs.contact_id = f.contact_id
@@ -666,9 +726,9 @@ getRcvFileTransfer_ db userId fileId = do
where
rcvFileTransfer ::
Maybe RcvFileDescr ->
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. (Maybe ContactName, FileType, Maybe FileDigest) ->
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. (Maybe ContactName, FileType, Maybe FileDigest, Maybe Integer, Maybe BadgeStatus) ->
ExceptT StoreError IO RcvFileTransfer
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. (groupName_, fileType, fileDigest_)) =
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. (groupName_, fileType, fileDigest_, fileMaxSize_, fileBadgeStatus_)) =
case contactName_ <|> memberName_ <|> groupName_ <|> standaloneName_ of
Nothing -> throwError $ SERcvFileInvalid fileId
Just name ->
@@ -683,10 +743,11 @@ getRcvFileTransfer_ db userId fileId = do
(Just _, Just _) -> Just "" -- filePath marks files that are accepted from contact or, in this case, set by createRcvDirectFileTransfer
_ -> Nothing
ft senderDisplayName fileStatus =
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = fileDigest_, fileConnReq, fileInline, fileDescr = Nothing}
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = fileDigest_, fileConnReq, fileInline, fileDescr = Nothing, fileBadge = Nothing}
fileProhibited = (\maxSize -> FileProhibited {maxSize, badgeStatus = fileBadgeStatus_}) <$> fileMaxSize_
cryptoArgs = CFArgs <$> fileKey <*> fileNonce
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted, userApprovedRelays}) <$> rfd_
in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, fileType, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs}
in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileProhibited, fileStatus, fileType, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs}
filePath = case filePath_ of
Nothing -> throwError $ SERcvFileInvalid fileId
Just fp -> pure fp
src/Simplex/Chat/Store/Groups.hs
+60 -42
View File
@@ -107,6 +107,8 @@ module Simplex.Chat.Store.Groups
deleteRosterTransfer,
deleteGroupRosterTransfers,
setGroupMemberKeyRole,
setUserMemberKey,
setMemberPubKey,
setGroupMemberVerified,
createRelayForOwner,
getCreateRelayForMember,
@@ -387,10 +389,12 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
let (rootPrivKey_, rootPubKey_, memberPrivKey_) = case groupKeys of
Nothing -> (Nothing, Nothing, Nothing)
Just GroupKeys {groupRootKey, memberPrivKey} ->
let (rpk, rpub) = case groupRootKey of
GRKPrivate pk -> (Just pk, Nothing)
GRKPublic k -> (Nothing, Just k)
Just GroupKeys {publicGroupKeys, memberPrivKey} ->
let (rpk, rpub) = case publicGroupKeys of
Just PublicGroupKeys {groupRootKey} -> case groupRootKey of
GRKPrivate pk -> (Just pk, Nothing)
GRKPublic k -> (Nothing, Just k)
Nothing -> (Nothing, Nothing)
in (rpk, rpub, Just memberPrivKey)
groupId <- liftIO $ do
DB.execute
@@ -452,9 +456,9 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
}
-- | creates a new group record for the group the current user was invited to, or returns an existing one
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile, business} incognitoProfileId = do
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> C.KeyPairEd25519 -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ _ = throwError $ SEContactNotReady localDisplayName
createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, fromMemberKey, invitedMember, connRequest, groupProfile, business} incognitoProfileId memberKeys = do
liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_
Just gId -> do
@@ -492,14 +496,14 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
[sql|
INSERT INTO groups
(group_profile_id, local_display_name, inv_queue_info, user_id, enable_ntfs,
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, business_member_id, customer_member_id)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
created_at, updated_at, chat_ts, user_member_profile_sent_at, member_priv_key, business_chat, business_member_id, customer_member_id)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
((profileId, localDisplayName, connRequest, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. businessChatInfoRow business)
((profileId, localDisplayName, connRequest, userId, BI True, currentTs, currentTs, currentTs, currentTs, snd memberKeys) :. businessChatInfoRow business)
insertedRowId db
let hostVRange = adjustedMemberVRange (vr cxt) peerChatVRange
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing Nothing currentTs hostVRange
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId Nothing currentTs (vr cxt)
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing ((\(MemberKey k) -> k) <$> fromMemberKey) currentTs hostVRange
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId (Just $ fst memberKeys) currentTs (vr cxt)
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure
( GroupInfo
@@ -526,7 +530,7 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
customData = Nothing,
membersRequireAttention = 0,
viaGroupLinkUri = Nothing,
groupKeys = Nothing,
groupKeys = Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey = snd memberKeys},
groupDomainVerified = Nothing
},
groupMemberId
@@ -647,8 +651,9 @@ deleteContactCardKeepConn db connId Contact {contactId, profile = LocalProfile {
createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> StoreCxt -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> GroupMemberRole -> Maybe Int64 -> Maybe SimplexDomain -> ExceptT StoreError IO (GroupInfo, Maybe GroupMember)
createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId useRelays userMemberRole publicMemberCount_ verifiedDomain = do
currentTs <- liftIO getCurrentTime
(memberPubKey, memberPrivKey) <- atomically $ C.generateKeyPair gVar
let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
(groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing publicMemberCount_ currentTs
(groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing publicMemberCount_ (Just memberPrivKey) currentTs
hostMemberId_ <-
if useRelays
then pure Nothing
@@ -658,8 +663,7 @@ createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile b
then liftIO $ MemberId <$> encodedRandomBytes gVar 12
else pure $ MemberId $ encodeUtf8 groupLDN <> "_user_unknown_id"
let userMember = MemberIdRole userMemberId userMemberRole
-- TODO [member keys] user key must be included here. Should key be added when group is prepared?
membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs (vr cxt)
membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing (Just memberPubKey) currentTs (vr cxt)
hostMember_ <- forM hostMemberId_ $ getGroupMember db cxt user groupId
forM_ hostMember_ $ \hostMember ->
when business $ liftIO $ setGroupBusinessChatInfo groupId membership hostMember
@@ -781,10 +785,12 @@ updatePreparedGroupUser db cxt user gInfo@GroupInfo {groupId, membership} hostMe
safeDeleteLDN db user oldHostLDN
updatePreparedUserAndHostMembersInvited :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembersInvited db cxt user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
updatePreparedUserAndHostMembersInvited db cxt user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberKey, fromMemberName, invitedMember, groupProfile, accepted, business} = do
let fromMemberProfile = profileFromName fromMemberName
initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
r@(_, hostMember') <- updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
forM_ fromMemberKey $ \(MemberKey k) -> liftIO $ setMemberPubKey db (groupMemberId' hostMember') k
pure r
updatePreparedUserAndHostMembersRejected :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
updatePreparedUserAndHostMembersRejected db cxt user gInfo hostMember GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
@@ -846,36 +852,37 @@ updatePreparedUserAndHostMembers'
(memberId, memberRole, currentTs, gmId)
getGroupMemberById db cxt user gmId
createGroupInvitedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink db cxt user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
createGroupInvitedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> C.KeyPairEd25519 -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupInvitedViaLink db cxt user conn memberKeys GroupLinkInvitation {fromMember, fromMemberKey, fromMemberName, invitedMember, groupProfile, accepted, business} = do
let fromMemberProfile = profileFromName fromMemberName
initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile business initialStatus
createGroupViaLink' db cxt user conn memberKeys fromMember fromMemberProfile ((\(MemberKey k) -> k) <$> fromMemberKey) invitedMember groupProfile business initialStatus
createGroupRejectedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupRejectedViaLink db cxt user conn GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
createGroupRejectedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> C.KeyPairEd25519 -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupRejectedViaLink db cxt user conn memberKeys GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
let fromMemberProfile = profileFromName $ nameFromMemberId memberId
createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
createGroupViaLink' db cxt user conn memberKeys fromMember fromMemberProfile Nothing invitedMember groupProfile Nothing GSMemRejected
createGroupViaLink' :: DB.Connection -> StoreCxt -> User -> Connection -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupViaLink' :: DB.Connection -> StoreCxt -> User -> Connection -> C.KeyPairEd25519 -> MemberIdRole -> Profile -> Maybe C.PublicKeyEd25519 -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
createGroupViaLink'
db
cxt
user@User {userId, userContactId}
Connection {connId, customUserProfileId}
memberKeys
fromMember
fromMemberProfile
fromMemberPubKey_
invitedMember
groupProfile
business
membershipStatus = do
currentTs <- liftIO getCurrentTime
(groupId, _groupLDN) <- createGroup_ db userId groupProfile Nothing business False Nothing Nothing currentTs
(groupId, _groupLDN) <- createGroup_ db userId groupProfile Nothing business False Nothing Nothing (Just (snd memberKeys)) currentTs
hostMemberId <- insertHost_ currentTs groupId
liftIO $ DB.execute db "UPDATE connections SET conn_type = ?, group_member_id = ?, updated_at = ? WHERE connection_id = ?" (ConnMember, hostMemberId, currentTs, connId)
-- using IBUnknown since host is created without contact
-- TODO [member keys] this is currently not used with public groups. If it needs to be used, member keys need to be added
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId Nothing currentTs (vr cxt)
_membership <- createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId (Just (fst memberKeys)) currentTs (vr cxt)
liftIO $ setViaGroupLinkUri db groupId connId
(,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user hostMemberId
where
@@ -889,16 +896,16 @@ createGroupViaLink'
[sql|
INSERT INTO group_members
( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
user_id, local_display_name, contact_id, contact_profile_id, member_pub_key, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
( (groupId, indexInGroup, memberId, memberRole, GCHostMember, GSMemAccepted, Binary B.empty, fromInvitedBy userContactId IBUnknown)
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, fromMemberPubKey_, currentTs, currentTs)
)
insertedRowId db
createGroup_ :: DB.Connection -> UserId -> GroupProfile -> Maybe (CreatedLinkContact, Maybe SharedMsgId) -> Maybe BusinessChatInfo -> Bool -> Maybe RelayStatus -> Maybe Int64 -> UTCTime -> ExceptT StoreError IO (GroupId, Text)
createGroup_ db userId groupProfile prepared business useRelays relayOwnStatus publicMemberCount_ currentTs = ExceptT $ do
createGroup_ :: DB.Connection -> UserId -> GroupProfile -> Maybe (CreatedLinkContact, Maybe SharedMsgId) -> Maybe BusinessChatInfo -> Bool -> Maybe RelayStatus -> Maybe Int64 -> Maybe C.PrivateKeyEd25519 -> UTCTime -> ExceptT StoreError IO (GroupId, Text)
createGroup_ db userId groupProfile prepared business useRelays relayOwnStatus publicMemberCount_ memberPrivKey_ currentTs = ExceptT $ do
let GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission} = groupProfile
(groupType_, groupLink_, publicGroupId_) = case publicGroup of
Just PublicGroupProfile {groupType, groupLink, publicGroupId} -> (Just groupType, Just groupLink, Just publicGroupId)
@@ -924,10 +931,10 @@ createGroup_ db userId groupProfile prepared business useRelays relayOwnStatus p
INSERT INTO groups
(group_profile_id, local_display_name, user_id, enable_ntfs,
created_at, updated_at, chat_ts, user_member_profile_sent_at, conn_full_link_to_connect, conn_short_link_to_connect, welcome_shared_msg_id,
business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count, member_priv_key)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|]
((profileId, localDisplayName, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. toPreparedGroupRow prepared :. businessChatInfoRow business :. (BI useRelays, relayOwnStatus, publicMemberCount_))
((profileId, localDisplayName, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. toPreparedGroupRow prepared :. businessChatInfoRow business :. (BI useRelays, relayOwnStatus, publicMemberCount_, memberPrivKey_))
groupId <- insertedRowId db
pure (groupId, localDisplayName)
@@ -1688,6 +1695,17 @@ 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)
setUserMemberKey :: DB.Connection -> GroupId -> GroupMemberId -> C.PrivateKeyEd25519 -> IO ()
setUserMemberKey db groupId membershipId memberPrivKey = do
currentTs <- getCurrentTime
DB.execute db "UPDATE groups SET member_priv_key = ?, updated_at = ? WHERE group_id = ?" (memberPrivKey, currentTs, groupId)
DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (C.publicKey memberPrivKey, currentTs, membershipId)
setMemberPubKey :: DB.Connection -> GroupMemberId -> C.PublicKeyEd25519 -> IO ()
setMemberPubKey db groupMemberId pubKey = do
currentTs <- getCurrentTime
DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (pubKey, currentTs, groupMemberId)
setGroupMemberVerified :: DB.Connection -> User -> GroupMemberId -> Maybe Text -> IO ()
setGroupMemberVerified db User {userId} groupMemberId code = do
updatedAt <- getCurrentTime
@@ -1896,7 +1914,7 @@ createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMemb
groupPreferences = Nothing,
memberAdmission = Nothing
}
(groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing currentTs
(groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing Nothing currentTs
-- Store relay request data for recovery
liftIO $ setRelayRequestData_ groupId currentTs
ownerMemberId <- insertOwner_ currentTs groupId
@@ -2151,6 +2169,7 @@ createBusinessRequestGroup
pure (groupInfo, clientMember)
where
insertGroup_ currentTs = do
(memberPubKey, memberPrivKey) <- atomically $ C.generateKeyPair gVar
liftIO $
DB.execute
db
@@ -2163,14 +2182,13 @@ createBusinessRequestGroup
[sql|
INSERT INTO groups
(group_profile_id, local_display_name, user_id, enable_ntfs,
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat)
VALUES (?,?,?,?,?,?,?,?,?)
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, member_priv_key)
VALUES (?,?,?,?,?,?,?,?,?,?)
|]
(groupProfileId, ldn, userId, BI True, currentTs, currentTs, currentTs, currentTs, BCCustomer)
(groupProfileId, ldn, userId, BI True, currentTs, currentTs, currentTs, currentTs, BCCustomer, memberPrivKey)
groupId <- liftIO $ insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12
-- TODO [member keys] we could support member keys in business groups to allow binding agreements (though identity keys would be better for it.
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing Nothing currentTs (vr cxt)
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing (Just memberPubKey) currentTs (vr cxt)
pure (groupId, membership)
VersionRange minV maxV = cReqChatVRange
insertClientMember_ currentTs groupId membership =
src/Simplex/Chat/Store/Messages.hs
+14 -9
View File
@@ -164,6 +164,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (addUTCTime)
import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Simplex.Chat.Badges (BadgeStatus)
import Simplex.Chat.Controller (ChatListQuery (..), ChatPagination (..), PaginationByTime (..))
import Simplex.Chat.Markdown
import Simplex.Chat.Messages
@@ -1093,7 +1094,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do
-- this function can be changed so it never fails, not only avoid failure on invalid json
toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal)
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)) =
toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires) :. (fileMaxSize_, fileBadgeStatus_)) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -1113,7 +1114,8 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
let cfArgs = CFArgs <$> fileKey <*> fileNonce
fileSource = (`CryptoFile` cfArgs) <$> filePath
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires}
fileProhibited = (\maxSize -> FileProhibited {maxSize, badgeStatus = fileBadgeStatus_}) <$> fileMaxSize_
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires, fileProhibited}
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTLocal d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTLocal
cItem d chatDir ciStatus content file =
@@ -2276,7 +2278,7 @@ updateLocalChatItemsRead db User {userId} noteFolderId = do
|]
(CISRcvRead, currentTs, userId, noteFolderId, CISRcvNew)
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol, Maybe UTCTime)
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol, Maybe UTCTime) :. (Maybe Integer, Maybe BadgeStatus)
type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt, Maybe MsgVerified)
@@ -2304,7 +2306,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
-- this function can be changed so it never fails, not only avoid failure on invalid json
toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)) :. quoteRow) =
toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires) :. (fileMaxSize_, fileBadgeStatus_)) :. quoteRow) =
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
where
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
@@ -2324,7 +2326,8 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
let cfArgs = CFArgs <$> fileKey <*> fileNonce
fileSource = (`CryptoFile` cfArgs) <$> filePath
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires}
fileProhibited = (\maxSize -> FileProhibited {maxSize, badgeStatus = fileBadgeStatus_}) <$> fileMaxSize_
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires, fileProhibited}
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTDirect d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTDirect
cItem d chatDir ciStatus content file =
@@ -2380,6 +2383,7 @@ toGroupChatItem
:. forwardedFromRow
:. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, msgSigned)
:. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_, fileExpires)
:. (fileMaxSize_, fileBadgeStatus_)
)
:. (forwardedByMember, BI showGroupAsSender)
:. memberRow_
@@ -2414,7 +2418,8 @@ toGroupChatItem
(Just fileId, Just fileName, Just fileSize, Just fileProtocol) ->
let cfArgs = CFArgs <$> fileKey <*> fileNonce
fileSource = (`CryptoFile` cfArgs) <$> filePath
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires}
fileProhibited = (\maxSize -> FileProhibited {maxSize, badgeStatus = fileBadgeStatus_}) <$> fileMaxSize_
in Just CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires, fileProhibited}
_ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe (CIFile d) -> CChatItem 'CTGroup
cItem d chatDir ciStatus content file =
@@ -2705,7 +2710,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status,
-- DirectQuote
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
FROM chat_items i
@@ -3099,7 +3104,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status,
-- CIMeta forwardedByMember, showGroupAsSender
i.forwarded_by_group_member_id, i.show_group_as_sender,
-- GroupMember
@@ -3212,7 +3217,7 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE i.user_id = ? AND i.note_folder_id = ? AND i.chat_item_id = ?
src/Simplex/Chat/Store/Postgres/Migrations.hs
+2
View File
@@ -49,6 +49,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260723_contact_request_rejectio
import Simplex.Chat.Store.Postgres.Migrations.M20260813_auto_accept_group_invitations
import Simplex.Chat.Store.Postgres.Migrations.M20260822_forward_link
import Simplex.Chat.Store.Postgres.Migrations.M20260828_file_expiry
import Simplex.Chat.Store.Postgres.Migrations.M20260904_file_badges
import Simplex.Chat.Store.Postgres.Migrations.M20261001_user_badges
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
@@ -99,6 +100,7 @@ schemaMigrations =
("20260813_auto_accept_group_invitations", m20260813_auto_accept_group_invitations, Just down_m20260813_auto_accept_group_invitations),
("20260822_forward_link", m20260822_forward_link, Just down_m20260822_forward_link),
("20260828_file_expiry", m20260828_file_expiry, Just down_m20260828_file_expiry),
("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges),
("20261001_user_badges", m20261001_user_badges, Just down_m20261001_user_badges)
]
src/Simplex/Chat/Store/Postgres/Migrations/M20260904_file_badges.hs
+40
View File
@@ -0,0 +1,40 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.Postgres.Migrations.M20260904_file_badges where
import Data.Text (Text)
import Text.RawString.QQ (r)
m20260904_file_badges :: Text
m20260904_file_badges =
[r|
ALTER TABLE files ADD COLUMN file_max_size BIGINT;
ALTER TABLE files ADD COLUMN file_badge_status TEXT;
CREATE TABLE file_badge_proofs(
badge_proof_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY,
file_id BIGINT NOT NULL REFERENCES files ON DELETE CASCADE,
proof_kind TEXT NOT NULL,
badge_proof BYTEA NOT NULL,
badge_pres_header BYTEA NOT NULL,
badge_key_idx BIGINT NOT NULL,
badge_type TEXT NOT NULL,
badge_expiry TIMESTAMPTZ NOT NULL,
badge_extra TEXT NOT NULL,
created_at TIMESTAMPTZ NOT NULL,
updated_at TIMESTAMPTZ NOT NULL
);
CREATE UNIQUE INDEX idx_file_badge_proofs_file_id_kind ON file_badge_proofs(file_id, proof_kind);
|]
down_m20260904_file_badges :: Text
down_m20260904_file_badges =
[r|
DROP INDEX idx_file_badge_proofs_file_id_kind;
DROP TABLE file_badge_proofs;
ALTER TABLE files DROP COLUMN file_badge_status;
ALTER TABLE files DROP COLUMN file_max_size;
|]
src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql
+44 -1
View File
@@ -899,6 +899,33 @@ ALTER TABLE test_chat_schema.extra_xftp_file_descriptions ALTER COLUMN extra_fil
CREATE TABLE test_chat_schema.file_badge_proofs (
badge_proof_id bigint NOT NULL,
file_id bigint NOT NULL,
proof_kind text NOT NULL,
badge_proof bytea NOT NULL,
badge_pres_header bytea NOT NULL,
badge_key_idx bigint NOT NULL,
badge_type text NOT NULL,
badge_expiry timestamp with time zone NOT NULL,
badge_extra text NOT NULL,
created_at timestamp with time zone NOT NULL,
updated_at timestamp with time zone NOT NULL
);
ALTER TABLE test_chat_schema.file_badge_proofs ALTER COLUMN badge_proof_id ADD GENERATED ALWAYS AS IDENTITY (
SEQUENCE NAME test_chat_schema.file_badge_proofs_badge_proof_id_seq
START WITH 1
INCREMENT BY 1
NO MINVALUE
NO MAXVALUE
CACHE 1
);
CREATE TABLE test_chat_schema.files (
file_id bigint NOT NULL,
contact_id bigint,
@@ -926,7 +953,9 @@ CREATE TABLE test_chat_schema.files (
file_type text DEFAULT 'normal'::text NOT NULL,
roster_transfer_id bigint,
file_digest bytea,
file_expires_at timestamp with time zone
file_expires_at timestamp with time zone,
file_max_size bigint,
file_badge_status text
);
@@ -1955,6 +1984,11 @@ ALTER TABLE ONLY test_chat_schema.extra_xftp_file_descriptions
ALTER TABLE ONLY test_chat_schema.file_badge_proofs
ADD CONSTRAINT file_badge_proofs_pkey PRIMARY KEY (badge_proof_id);
ALTER TABLE ONLY test_chat_schema.files
ADD CONSTRAINT files_pkey PRIMARY KEY (file_id);
@@ -2688,6 +2722,10 @@ CREATE INDEX idx_extra_xftp_file_descriptions_user_id ON test_chat_schema.extra_
CREATE UNIQUE INDEX idx_file_badge_proofs_file_id_kind ON test_chat_schema.file_badge_proofs USING btree (file_id, proof_kind);
CREATE INDEX idx_files_chat_item_id ON test_chat_schema.files USING btree (chat_item_id);
@@ -3429,6 +3467,11 @@ ALTER TABLE ONLY test_chat_schema.extra_xftp_file_descriptions
ALTER TABLE ONLY test_chat_schema.file_badge_proofs
ADD CONSTRAINT file_badge_proofs_file_id_fkey FOREIGN KEY (file_id) REFERENCES test_chat_schema.files(file_id) ON DELETE CASCADE;
ALTER TABLE ONLY test_chat_schema.files
ADD CONSTRAINT files_contact_id_fkey FOREIGN KEY (contact_id) REFERENCES test_chat_schema.contacts(contact_id) ON DELETE CASCADE;
src/Simplex/Chat/Store/SQLite/Migrations.hs
+2
View File
@@ -172,6 +172,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260723_contact_request_rejection
import Simplex.Chat.Store.SQLite.Migrations.M20260813_auto_accept_group_invitations
import Simplex.Chat.Store.SQLite.Migrations.M20260822_forward_link
import Simplex.Chat.Store.SQLite.Migrations.M20260828_file_expiry
import Simplex.Chat.Store.SQLite.Migrations.M20260904_file_badges
import Simplex.Chat.Store.SQLite.Migrations.M20261001_user_badges
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
@@ -345,6 +346,7 @@ schemaMigrations =
("20260813_auto_accept_group_invitations", m20260813_auto_accept_group_invitations, Just down_m20260813_auto_accept_group_invitations),
("20260822_forward_link", m20260822_forward_link, Just down_m20260822_forward_link),
("20260828_file_expiry", m20260828_file_expiry, Just down_m20260828_file_expiry),
("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges),
("20261001_user_badges", m20261001_user_badges, Just down_m20261001_user_badges)
]
src/Simplex/Chat/Store/SQLite/Migrations/M20260904_file_badges.hs
+39
View File
@@ -0,0 +1,39 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.SQLite.Migrations.M20260904_file_badges where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20260904_file_badges :: Query
m20260904_file_badges =
[sql|
ALTER TABLE files ADD COLUMN file_max_size INTEGER;
ALTER TABLE files ADD COLUMN file_badge_status TEXT;
CREATE TABLE file_badge_proofs(
badge_proof_id INTEGER PRIMARY KEY AUTOINCREMENT,
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
proof_kind TEXT NOT NULL,
badge_proof BLOB NOT NULL,
badge_pres_header BLOB NOT NULL,
badge_key_idx INTEGER NOT NULL,
badge_type TEXT NOT NULL,
badge_expiry TEXT NOT NULL,
badge_extra TEXT NOT NULL,
created_at TEXT NOT NULL,
updated_at TEXT NOT NULL
) STRICT;
CREATE UNIQUE INDEX idx_file_badge_proofs_file_id_kind ON file_badge_proofs(file_id, proof_kind);
|]
down_m20260904_file_badges :: Query
down_m20260904_file_badges =
[sql|
DROP INDEX idx_file_badge_proofs_file_id_kind;
DROP TABLE file_badge_proofs;
ALTER TABLE files DROP COLUMN file_badge_status;
ALTER TABLE files DROP COLUMN file_max_size;
|]
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+41 -14
View File
@@ -115,8 +115,8 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta
Query:
INSERT INTO groups
(group_profile_id, local_display_name, inv_queue_info, user_id, enable_ntfs,
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, business_member_id, customer_member_id)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
created_at, updated_at, chat_ts, user_member_profile_sent_at, member_priv_key, business_chat, business_member_id, customer_member_id)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
Plan:
@@ -288,8 +288,8 @@ SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
Query:
INSERT INTO group_members
( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by,
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
user_id, local_display_name, contact_id, contact_profile_id, member_pub_key, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
Plan:
SEARCH rcv_roster_transfers USING COVERING INDEX idx_rcv_roster_transfers_from_member_id (from_member_id=?)
@@ -395,8 +395,8 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta
Query:
INSERT INTO groups
(group_profile_id, local_display_name, user_id, enable_ntfs,
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat)
VALUES (?,?,?,?,?,?,?,?,?)
created_at, updated_at, chat_ts, user_member_profile_sent_at, business_chat, member_priv_key)
VALUES (?,?,?,?,?,?,?,?,?,?)
Plan:
@@ -1336,8 +1336,8 @@ Query:
INSERT INTO groups
(group_profile_id, local_display_name, user_id, enable_ntfs,
created_at, updated_at, chat_ts, user_member_profile_sent_at, conn_full_link_to_connect, conn_short_link_to_connect, welcome_shared_msg_id,
business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
business_chat, business_member_id, customer_member_id, use_relays, relay_own_status, public_member_count, member_priv_key)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
Plan:
@@ -1381,7 +1381,7 @@ Query:
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE i.user_id = ? AND i.note_folder_id = ? AND i.chat_item_id = ?
@@ -1399,7 +1399,7 @@ Query:
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status,
-- CIMeta forwardedByMember, showGroupAsSender
i.forwarded_by_group_member_id, i.show_group_as_sender,
-- GroupMember
@@ -1456,7 +1456,7 @@ Query:
i.fwd_from_group_type, i.fwd_from_group_link, i.fwd_from_public_group_id, i.fwd_from_member_id, i.fwd_from_shared_msg_id,
i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed,
-- CIFile
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at,
f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, f.file_expires_at, f.file_max_size, f.file_badge_status,
-- DirectQuote
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
FROM chat_items i
@@ -1745,7 +1745,8 @@ Query:
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline,
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type, f.file_digest,
f.file_max_size, f.file_badge_status
FROM rcv_files r
JOIN files f USING (file_id)
LEFT JOIN contacts cs ON cs.contact_id = f.contact_id
@@ -4053,6 +4054,14 @@ SEARCH pgm USING INDEX idx_pending_group_messages_group_member_id (group_member_
SEARCH m USING INTEGER PRIMARY KEY (rowid=?)
USE TEMP B-TREE FOR ORDER BY
Query:
SELECT proof_kind, badge_proof, badge_pres_header, badge_key_idx, badge_type, badge_expiry, badge_extra
FROM file_badge_proofs
WHERE file_id = ?
Plan:
SEARCH file_badge_proofs USING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
Query:
SELECT r.contact_id, g.group_id, r.group_member_id
FROM received_probes r
@@ -4855,6 +4864,7 @@ Plan:
SEARCH files USING INDEX idx_files_user_id (user_id=?)
LIST SUBQUERY 1
SEARCH chat_items USING COVERING INDEX idx_chat_items_note_folder_has_link_created_at (user_id=? AND note_folder_id=?)
SEARCH file_badge_proofs USING COVERING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
SEARCH extra_xftp_file_descriptions USING COVERING INDEX idx_extra_xftp_file_descriptions_file_id (file_id=?)
SEARCH rcv_files USING INTEGER PRIMARY KEY (rowid=?)
SEARCH snd_files USING COVERING INDEX idx_snd_files_file_id (file_id=?)
@@ -4991,6 +5001,20 @@ Query:
Plan:
Query:
INSERT INTO file_badge_proofs (file_id, proof_kind, badge_proof, badge_pres_header, badge_key_idx, badge_type, badge_expiry, badge_extra, created_at, updated_at)
VALUES (?,?,?,?,?,?,?,?,?,?)
ON CONFLICT (file_id, proof_kind) DO UPDATE SET
badge_proof = excluded.badge_proof,
badge_pres_header = excluded.badge_pres_header,
badge_key_idx = excluded.badge_key_idx,
badge_type = excluded.badge_type,
badge_expiry = excluded.badge_expiry,
badge_extra = excluded.badge_extra,
updated_at = excluded.updated_at
Plan:
Query:
INSERT INTO files
( user_id, note_folder_id,
@@ -6802,6 +6826,7 @@ SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
Query: DELETE FROM files WHERE roster_transfer_id = ?
Plan:
SEARCH files USING COVERING INDEX idx_files_roster_transfer_id (roster_transfer_id=?)
SEARCH file_badge_proofs USING COVERING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
SEARCH extra_xftp_file_descriptions USING COVERING INDEX idx_extra_xftp_file_descriptions_file_id (file_id=?)
SEARCH rcv_files USING INTEGER PRIMARY KEY (rowid=?)
SEARCH snd_files USING COVERING INDEX idx_snd_files_file_id (file_id=?)
@@ -6810,6 +6835,7 @@ SEARCH files USING COVERING INDEX idx_files_redirect_file_id (redirect_file_id=?
Query: DELETE FROM files WHERE user_id = ? AND contact_id = ?
Plan:
SEARCH files USING INDEX idx_files_contact_id (contact_id=?)
SEARCH file_badge_proofs USING COVERING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
SEARCH extra_xftp_file_descriptions USING COVERING INDEX idx_extra_xftp_file_descriptions_file_id (file_id=?)
SEARCH rcv_files USING INTEGER PRIMARY KEY (rowid=?)
SEARCH snd_files USING COVERING INDEX idx_snd_files_file_id (file_id=?)
@@ -6818,6 +6844,7 @@ SEARCH files USING COVERING INDEX idx_files_redirect_file_id (redirect_file_id=?
Query: DELETE FROM files WHERE user_id = ? AND group_id = ? AND file_type = ?
Plan:
SEARCH files USING INDEX idx_files_group_id (group_id=?)
SEARCH file_badge_proofs USING COVERING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
SEARCH extra_xftp_file_descriptions USING COVERING INDEX idx_extra_xftp_file_descriptions_file_id (file_id=?)
SEARCH rcv_files USING INTEGER PRIMARY KEY (rowid=?)
SEARCH snd_files USING COVERING INDEX idx_snd_files_file_id (file_id=?)
@@ -7128,13 +7155,13 @@ Plan:
Query: INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, redirect_file_id, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
Plan:
Query: INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)
Query: INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_max_size, file_badge_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
Plan:
Query: INSERT INTO files (user_id, file_name, file_path, file_size, chunk_size, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)
Plan:
Query: INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
Query: INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at, file_digest, file_max_size, file_badge_status) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
Plan:
Query: INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, roster_transfer_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+20 -1
View File
@@ -303,7 +303,9 @@ CREATE TABLE files(
file_type TEXT NOT NULL DEFAULT 'normal',
roster_transfer_id INTEGER,
file_digest BLOB,
file_expires_at TEXT
file_expires_at TEXT,
file_max_size INTEGER,
file_badge_status TEXT
) STRICT;
CREATE TABLE snd_files(
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
@@ -853,6 +855,19 @@ CREATE TABLE rcv_roster_transfers(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
) STRICT;
CREATE TABLE file_badge_proofs(
badge_proof_id INTEGER PRIMARY KEY AUTOINCREMENT,
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
proof_kind TEXT NOT NULL,
badge_proof BLOB NOT NULL,
badge_pres_header BLOB NOT NULL,
badge_key_idx INTEGER NOT NULL,
badge_type TEXT NOT NULL,
badge_expiry TEXT NOT NULL,
badge_extra TEXT NOT NULL,
created_at TEXT NOT NULL,
updated_at TEXT NOT NULL
) STRICT;
CREATE TABLE invoices(
invoice_id TEXT NOT NULL PRIMARY KEY,
provider TEXT NOT NULL,
@@ -1535,6 +1550,10 @@ CREATE INDEX idx_files_roster_transfer_id ON files(roster_transfer_id);
CREATE INDEX idx_chat_items_item_signed_by_group_member_id ON chat_items(
item_signed_by_group_member_id
);
CREATE UNIQUE INDEX idx_file_badge_proofs_file_id_kind ON file_badge_proofs(
file_id,
proof_kind
);
CREATE INDEX idx_payments_provider_ref ON payments(provider, provider_ref);
CREATE INDEX idx_payments_invoice ON payments(invoice_id);
CREATE INDEX idx_badge_offers_price ON badge_offers(price_id);
src/Simplex/Chat/Store/Shared.hs
+6 -4
View File
@@ -734,10 +734,12 @@ toPublicGroupAccess (groupWebPage, groupDomain_, domainWebPage_, allowEmbedding_
allowEmbedding = maybe False unBI allowEmbedding_
toGroupKeys :: Maybe B64UrlByteString -> GroupKeysRow -> Maybe GroupKeys
toGroupKeys (Just publicGroupId) (rootPrivKey_, rootPubKey_, Just memberPrivKey) =
(\grk -> GroupKeys {publicGroupId, groupRootKey = grk, memberPrivKey})
<$> (GRKPrivate <$> rootPrivKey_ <|> GRKPublic <$> rootPubKey_)
toGroupKeys _ _ = Nothing
toGroupKeys publicGroupId_ (rootPrivKey, rootPubKey, memberPrivKey) =
let publicGroupKeys = case (publicGroupId_, GRKPrivate <$> rootPrivKey <|> GRKPublic <$> rootPubKey) of
(Just publicGroupId, Just groupRootKey) -> Just $ Just PublicGroupKeys {publicGroupId, groupRootKey}
(Nothing, Nothing) -> Just Nothing
_ -> Nothing -- invalid state, in which case messages won't be signed even if memberPrivKey is present
in GroupKeys <$> publicGroupKeys <*> memberPrivKey
toGroupMember :: UTCTime -> Int64 -> GroupMemberRow -> GroupMember
toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, BI showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. profileRow :. (createdAt, updatedAt) :. (supportChatTs_, supportChatUnread, supportChatMemberAttention, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) =
src/Simplex/Chat/Terminal/Input.hs
+1 -1
View File
@@ -80,7 +80,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
CRChatItemsDeleted u ((ChatItemDeletion (AChatItem _ _ cInfo _) _) : _) _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
CRGroupDeletedUser u g _ -> whenCurrUser cc u $ unsetActiveGroup ct g
CRGroupDeletedUser u g _ _ -> whenCurrUser cc u $ unsetActiveGroup ct g
CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
CRCmdOk _ -> case cmd of
Right APIDeleteUser {} -> setActive ct ""
src/Simplex/Chat/Types.hs
+21 -4
View File
@@ -480,12 +480,17 @@ groupRootPubKey (GRKPrivate pk) = C.publicKey pk
groupRootPubKey (GRKPublic pk) = pk
data GroupKeys = GroupKeys
{ publicGroupId :: B64UrlByteString,
groupRootKey :: GroupRootKey,
{ publicGroupKeys :: Maybe PublicGroupKeys,
memberPrivKey :: C.PrivateKeyEd25519
}
deriving (Eq, Show)
data PublicGroupKeys = PublicGroupKeys
{ publicGroupId :: B64UrlByteString,
groupRootKey :: GroupRootKey
}
deriving (Eq, Show)
data GroupInfo = GroupInfo
{ groupId :: GroupId,
useRelays :: BoolDef,
@@ -943,6 +948,7 @@ instance ToJSON GroupLinkId where
data GroupInvitation = GroupInvitation
{ fromMember :: MemberIdRole,
fromMemberKey :: Maybe MemberKey,
invitedMember :: MemberIdRole,
connRequest :: ConnReqInvitation,
groupProfile :: GroupProfile,
@@ -955,6 +961,7 @@ data GroupInvitation = GroupInvitation
data GroupLinkInvitation = GroupLinkInvitation
{ fromMember :: MemberIdRole,
fromMemberName :: ContactName,
fromMemberKey :: Maybe MemberKey,
invitedMember :: MemberIdRole,
groupProfile :: GroupProfile,
accepted :: Maybe GroupAcceptance,
@@ -1551,7 +1558,8 @@ data FileInvitation = FileInvitation
fileDigest :: Maybe FileDigest,
fileConnReq :: Maybe ConnReqInvitation,
fileInline :: Maybe InlineFileMode,
fileDescr :: Maybe FileDescr
fileDescr :: Maybe FileDescr,
fileBadge :: Maybe BadgeProof
}
deriving (Eq, Show)
@@ -1566,7 +1574,8 @@ xftpFileInvitation fileName fileSize fileDescr =
fileDigest = Nothing,
fileConnReq = Nothing,
fileInline = Nothing,
fileDescr = Just fileDescr
fileDescr = Just fileDescr,
fileBadge = Nothing
}
data InlineFileMode
@@ -1620,10 +1629,14 @@ instance ToJSON FileType where
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
data FileProhibited = FileProhibited {maxSize :: Integer, badgeStatus :: Maybe BadgeStatus}
deriving (Eq, Show)
data RcvFileTransfer = RcvFileTransfer
{ fileId :: FileTransferId,
xftpRcvFile :: Maybe XFTPRcvFile,
fileInvitation :: FileInvitation,
fileProhibited :: Maybe FileProhibited,
fileStatus :: RcvFileStatus,
fileType :: FileType,
rcvFileInline :: Maybe InlineFileMode,
@@ -2336,6 +2349,8 @@ instance FromJSON GroupSummary where
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GRK") ''GroupRootKey)
$(JQ.deriveJSON defaultJSON ''PublicGroupKeys)
$(JQ.deriveJSON defaultJSON ''GroupKeys)
$(JQ.deriveJSON defaultJSON ''GroupInfo)
@@ -2370,6 +2385,8 @@ $(JQ.deriveJSON defaultJSON ''GroupMemberRef)
$(JQ.deriveJSON defaultJSON ''FileDescr)
$(JQ.deriveJSON defaultJSON ''FileProhibited)
$(JQ.deriveJSON defaultJSON ''FileInvitation)
$(JQ.deriveJSON defaultJSON ''SndFileTransfer)
src/Simplex/Chat/View.hs
+19 -5
View File
@@ -245,7 +245,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
"use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the group (also clears the rejection)"
]
| otherwise -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g
CRGroupDeletedUser u g signed -> ttyUser u [ttyGroup' g <> ": you deleted the group" <> signedStr signed]
CRGroupDeletedUser u g signed local -> ttyUser u [ttyGroup' g <> (if local then ": you deleted your local copy of the group" else ": you deleted the group" <> signedStr signed)]
CRForwardPlan u count itemIds fc -> ttyUser u $ viewForwardPlan count itemIds fc
CRChatMsgContent u mc -> ttyUser u $ ttyMsgContent mc <> viewMsgTestInfo testView mc
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
@@ -2480,11 +2480,25 @@ viewReceivedFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZon
viewReceivedFileInvitation from file ts tz meta = receivedWithTime_ ts tz from [] meta (receivedFileInvitation_ file) False
receivedFileInvitation_ :: CIFile d -> [StyledString]
receivedFileInvitation_ CIFile {fileId, fileName, fileSize, fileStatus} =
receivedFileInvitation_ CIFile {fileId, fileName, fileSize, fileStatus, fileProhibited} =
["sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)"]
<> case fileStatus of
CIFSRcvAccepted -> []
_ -> ["use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"]
<> case fileProhibited of
Just fp -> [prohibitedFileReason fp]
Nothing -> case fileStatus of
CIFSRcvAccepted -> []
_ -> ["use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"]
prohibitedFileReason :: FileProhibited -> StyledString
prohibitedFileReason FileProhibited {maxSize, badgeStatus} =
"file is above the limit of " <> sShow maxSize <> " bytes: " <> reason
where
reason = case badgeStatus of
Nothing -> "sender has no badge"
Just BSActive -> "above the limit of the sender badge"
Just BSExpired -> "sender badge expired"
Just BSExpiredOld -> "sender badge expired"
Just BSFailed -> "sender badge did not verify"
Just BSUnknownKey -> "sender badge key is not known"
humanReadableSize :: Integer -> StyledString
humanReadableSize size
src/Simplex/Chat/Web.hs
+5 -5
View File
@@ -24,7 +24,7 @@ module Simplex.Chat.Web
where
import Control.Concurrent.STM (check, flushTQueue)
import Control.Exception (SomeException, catch)
import Control.Exception (SomeException)
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except (runExceptT)
@@ -75,7 +75,7 @@ import Simplex.Chat.Types
)
import Simplex.Messaging.Agent.Store.Common (withTransaction)
import Simplex.Messaging.Encoding.String (strEncode)
import Simplex.Messaging.Util (catchOwn, eitherToMaybe, safeDecodeUtf8, tshow)
import Simplex.Messaging.Util (catchOwn, catchOwn', eitherToMaybe, safeDecodeUtf8, tshow)
import Simplex.Messaging.Parsers (defaultJSON)
import System.Directory (createDirectoryIfMissing, listDirectory, removeFile, renameFile)
import System.FilePath (dropExtension, takeExtension, (</>))
@@ -150,7 +150,7 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva
drainRemovals = atomically (tryReadTQueue filesToRemove) >>= \case
Nothing -> pure ()
Just f -> do
removeFile (webJsonDir </> f) `catch` \(_ :: SomeException) -> pure ()
removeFile (webJsonDir </> f) `catchOwn'` \(_ :: SomeException) -> pure ()
drainRemovals
-- flush the whole queue and render each group once: a burst of changes in one
@@ -202,7 +202,7 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva
renderOneGroup WebPreviewState {publishableGroupIds} gId = do
publishable <- atomically $ M.member gId <$> readTVar publishableGroupIds
when publishable $
renderOrRemoveStale `catch` \(e :: SomeException) ->
renderOrRemoveStale `catchOwn'` \(e :: SomeException) ->
logError $ "web preview: error rendering group " <> T.pack (show gId) <> ": " <> T.pack (show e)
where
renderOrRemoveStale = do
@@ -217,7 +217,7 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva
modifyTVar' publishableGroupIds (M.delete gId)
pure $ pgFileName <$> pg
forM_ fName $ \f ->
removeFile (webJsonDir </> f) `catch` \(_ :: SomeException) -> pure ()
removeFile (webJsonDir </> f) `catchOwn'` \(_ :: SomeException) -> pure ()
logInfo $ "web preview: group " <> T.pack (show gId) <> " no longer publishable"
findUser f = go users