From a0f32eae8922a80b568a18a22b5637515a9d28c7 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Thu, 4 Jun 2026 17:53:53 +0400 Subject: [PATCH] core: roster delivery via inline file --- docs/protocol/channels-overview.md | 1 + src/Simplex/Chat/Library/Commands.hs | 3 + src/Simplex/Chat/Library/Internal.hs | 87 +++++- src/Simplex/Chat/Library/Subscriber.hs | 260 ++++++++++++------ src/Simplex/Chat/Protocol.hs | 49 +++- src/Simplex/Chat/Store/Files.hs | 90 +++++- src/Simplex/Chat/Store/Groups.hs | 102 +++++++ .../Migrations/M20260601_group_roster.hs | 22 ++ .../Migrations/M20260601_group_roster.hs | 22 ++ .../Store/SQLite/Migrations/chat_schema.sql | 18 +- src/Simplex/Chat/Types.hs | 32 +++ src/Simplex/Chat/Types/Shared.hs | 7 + tests/ChatTests/Groups.hs | 65 +++++ 13 files changed, 646 insertions(+), 112 deletions(-) diff --git a/docs/protocol/channels-overview.md b/docs/protocol/channels-overview.md index d4cd2d2965..21f29abd82 100644 --- a/docs/protocol/channels-overview.md +++ b/docs/protocol/channels-overview.md @@ -236,6 +236,7 @@ This threat model assumes the [SimpleX network threat model](https://github.com/ - Selectively target specific subscribers while delivering correctly to others. - Ignore the "message from channel" directive, revealing which owner sent a message. Detectable out-of-band. - Fabricate or hide subscriber connections, inflating or deflating counts. Detectable if subscribers are connected to other relays. +- Replay a previously valid roster - the owner-signed header plus its blob - to a *new* joiner, re-introducing a member whose privileged role was later revoked (or masking a later demotion). The owner signature binds the channel entity ID and the roster version, and the header's digest binds the blob to that header, so cross-channel and cross-version substitution remain blocked; but a same-group replay to a joiner that has not yet seen a newer version is not prevented. Existing members are protected by the monotonic roster version check - they reject any roster not strictly newer than the one already applied, so the replay reaches only members with no prior roster state. *cannot:* diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 78af15c837..3a5b5875d3 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -1270,6 +1270,8 @@ processChatCommand vr nm = \case filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo withGroupLock "deleteChat group" chatId $ do deleteCIFiles user filesInfo + -- the roster blob file has no chat item, so it is missed by getGroupFileInfo above + cleanupGroupRosterFile user gInfo (members, recipients) <- getRecipients gInfo let doSendDel = memberActive membership && isOwner msgSigned <- @@ -1304,6 +1306,7 @@ processChatCommand vr nm = \case gInfo <- withFastStore $ \db -> getGroupInfo db vr user chatId filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo deleteCIFiles user filesInfo + cleanupGroupRosterFile user gInfo withFastStore' $ \db -> deleteGroupChatItemsMessages db user gInfo membersToDelete <- withFastStore' $ \db -> getGroupMembersForExpiration db vr user gInfo forM_ membersToDelete $ \m -> withFastStore' $ \db -> deleteGroupMember db user m diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index d25645858f..57f3e66ebd 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -79,6 +79,7 @@ import Simplex.Chat.Types.Shared import Simplex.Chat.Util (encryptFile, shuffle) import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription) import qualified Simplex.FileTransfer.Description as FD +import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.Messaging.Agent @@ -1172,15 +1173,19 @@ memberIntroEvt gInfo reMember = forwardGroupRoster :: User -> GroupInfo -> GroupMember -> CM () forwardGroupRoster user gInfo subscriber = do vr <- chatVersionRange - withStore' (\db -> getGroupRoster db gInfo) >>= \case - Nothing -> pure () - Just (ownerGMId, brokerTs, sm@SignedMsg {signedBody}) -> - forM_ (eitherToMaybe (J.eitherDecodeStrict' signedBody) :: Maybe (ChatMessage 'Json)) $ \chatMsg -> + withStore' (\db -> (,) <$> getGroupRoster db gInfo <*> getRosterBlob db gInfo) >>= \case + (Just (ownerGMId, brokerTs, sm@SignedMsg {signedBody}), blob_) -> + forM_ (eitherToMaybe (J.eitherDecodeStrict' signedBody) :: Maybe (ChatMessage 'Json)) $ \chatMsg@ChatMessage {msgId} -> withStore' (\db -> runExceptT $ getGroupMemberById db vr user ownerGMId) >>= \case Right owner -> do let fwd = GrpMsgForward {fwdSender = FwdMember (memberId' owner) (memberShortenedName owner), fwdBrokerTs = brokerTs} sendFwdMemberMessage subscriber fwd (VMSigned MSSVerified sm chatMsg) + -- re-serve the blob under the owner's original shared_msg_id (carried in the forwarded header), + -- so the joiner keys the roster file the same way whether it arrived direct or forwarded + forM_ ((,) <$> msgId <*> blob_) $ \(sid, blob) -> + sendRosterBlobChunks user gInfo [subscriber] sid blob Left _ -> pure () + _ -> pure () -- Used in groups with relays to introduce moderators and above to a new member, -- and to announce the new member to moderators and above. @@ -1238,9 +1243,10 @@ isRosterRole :: GroupMemberRole -> Bool isRosterRole r = r == GRModerator || r == GRAdmin -- Drop non-privileged-role entries and de-duplicate by memberId, keeping the first. -validateGroupRoster :: GroupRoster -> GroupRoster -validateGroupRoster GroupRoster {version = ver, roster = entries} = - GroupRoster {version = ver, roster = dedup [] $ filter (\RosterMember {role} -> isRosterRole role) entries} +-- Runs on the parsed roster blob. +validateGroupRoster :: [RosterMember] -> [RosterMember] +validateGroupRoster entries = + dedup [] $ filter (\RosterMember {role} -> isRosterRole role) entries where dedup _ [] = [] dedup seen (rm@RosterMember {memberId} : rms) @@ -1248,8 +1254,8 @@ validateGroupRoster GroupRoster {version = ver, roster = entries} = | otherwise = rm : dedup (memberId : seen) rms -- Privileged members without a known key are skipped (recipients can't verify them). -buildGroupRoster :: VersionRoster -> [GroupMember] -> GroupRoster -buildGroupRoster ver mods = GroupRoster {version = ver, roster = mapMaybe rosterMember mods} +buildGroupRoster :: [GroupMember] -> [RosterMember] +buildGroupRoster mods = mapMaybe rosterMember mods where rosterMember m@GroupMember {memberId, memberPubKey, memberRole} | isRosterRole memberRole = (\k -> RosterMember {memberId, name = memberShortenedName m, key = MemberKey k, role = memberRole}) <$> memberPubKey @@ -1872,6 +1878,39 @@ closeFileHandle fileId files = do h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m) liftIO $ mapM_ hClose h_ `catchAll_` pure () +-- Roster-file cleanup keyed on the group (the roster file has no chat item, so the +-- normal chat-item file enumeration misses it and the on-disk file would leak): evict +-- the cached handle, remove the on-disk file, delete the rows (rcv_files/chunks cascade), +-- and clear the pending columns. +cleanupGroupRosterFile :: User -> GroupInfo -> CM () +cleanupGroupRosterFile User {userId} gInfo@GroupInfo {groupId} = do + info_ <- withStore' $ \db -> getGroupRosterFileInfo db userId groupId + forM_ info_ $ \(fileId, filePath_) -> do + lift $ closeFileHandle fileId rcvFiles + forM_ filePath_ removeRosterFsFile + withStore' $ \db -> do + deleteGroupRosterFile db userId groupId + clearRosterPending db gInfo + +-- Discard partial roster chunks so the transfer re-drives from chunk 1 (relay restart / +-- re-subscribe / QCONT). MUST evict the cached AppendMode handle first, or appended bytes +-- land after the stale prefix and corrupt the blob (the digest then fails). +resetRosterPartialChunks :: RcvFileTransfer -> CM () +resetRosterPartialChunks ft@RcvFileTransfer {fileId, fileStatus} = do + lift $ closeFileHandle fileId rcvFiles + forM_ (rcvFilePath fileStatus) removeRosterFsFile + withStore' $ \db -> deleteRcvFileChunks db ft + where + rcvFilePath = \case + RFSAccepted p -> Just p + RFSConnected p -> Just p + _ -> Nothing + +removeRosterFsFile :: FilePath -> CM () +removeRosterFsFile fp = do + p <- lift $ toFSFilePath fp + removeFile p `catchAllErrors` \_ -> pure () + deleteMembersConnections :: User -> [GroupMember] -> CM () deleteMembersConnections user members = deleteMembersConnections' user members False @@ -2176,13 +2215,13 @@ bumpAndBroadcastRoster :: User -> GroupInfo -> CM () bumpAndBroadcastRoster user gInfo = do vr <- chatVersionRange let rosterVer = maybe (VersionRoster 0) (\(VersionRoster n) -> VersionRoster (n + 1)) (rosterVersion gInfo) - (relays, roster) <- withStore' $ \db -> do + (relays, mods) <- withStore' $ \db -> do relays <- getGroupRelayMembers db vr user gInfo mods <- getGroupRosterMembers db vr user gInfo setGroupRosterVersion db gInfo rosterVer - pure (relays, buildGroupRoster rosterVer mods) + pure (relays, mods) forM_ (L.nonEmpty relays) $ \relays' -> - void $ sendGroupMessage' user gInfo (L.toList relays') (XGrpRoster roster) + sendRoster user gInfo (L.toList relays') rosterVer (buildGroupRoster mods) -- Send the current roster (no version bump) to a newly added relay so it can serve joiners. sendGroupRosterToRelay :: User -> GroupInfo -> GroupMember -> CM () @@ -2190,7 +2229,29 @@ sendGroupRosterToRelay user gInfo relayMember = forM_ (rosterVersion gInfo) $ \rosterVer -> do vr <- chatVersionRange mods <- withStore' $ \db -> getGroupRosterMembers db vr user gInfo - void $ sendGroupMessage' user gInfo [relayMember] (XGrpRoster (buildGroupRoster rosterVer mods)) + sendRoster user gInfo [relayMember] rosterVer (buildGroupRoster mods) + +-- Build the roster blob, send the owner-signed header carrying its size + digest, then +-- send the blob as BFileChunks under the header's shared_msg_id. Row-less: no files/ +-- snd_files rows for the send, so there is no send-side cleanup; redelivery is the agent's. +sendRoster :: User -> GroupInfo -> [GroupMember] -> VersionRoster -> [RosterMember] -> CM () +sendRoster user gInfo members rosterVer roster = do + let blob = encodeRosterBlob roster + fileInv = InlineFileInvitation {fileSize = fromIntegral (B.length blob), fileDigest = FD.FileDigest $ LC.sha512Hash $ LB.fromStrict blob} + SndMessage {sharedMsgId} <- sendGroupMessage' user gInfo members (XGrpRoster GroupRoster {version = rosterVer, fileInv}) + sendRosterBlobChunks user gInfo members sharedMsgId blob + +-- Chunk a roster blob and send each as a BFileChunk under the header's shared_msg_id, +-- to the same recipients. Used by both the owner send and the relay re-serve. +sendRosterBlobChunks :: User -> GroupInfo -> [GroupMember] -> SharedMsgId -> ByteString -> CM () +sendRosterBlobChunks user gInfo members sharedMsgId blob = do + chSize <- fromIntegral <$> asks (fileChunkSize . config) + go chSize 1 blob + where + go chSize chunkNo bytes = do + let (chunk, rest) = B.splitAt chSize bytes + void $ sendGroupMessage' user gInfo members (BFileChunk sharedMsgId (FileChunk chunkNo chunk)) + unless (B.null rest) $ go chSize (chunkNo + 1) rest sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) sendGroupMessages user gInfo scope asGroup members events = do diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 5ca033a30f..dd1fc81f6f 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -24,6 +24,7 @@ import Control.Monad.IO.Unlift import Control.Monad.Reader import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (lefts, partitionEithers, rights) import Data.Foldable (foldr', foldrM) import Data.Functor (($>)) @@ -86,8 +87,10 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR +import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding (smpEncode) import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..), ServiceSub (..), ServiceSubError (..), ServiceSubResult (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) @@ -1029,7 +1032,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure newDeliveryTasks processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> VerifiedMsg e -> CM (Maybe NewMessageDeliveryTask) processEvent gInfo' m' verifiedMsg = do - (m'', conn', msg@RcvMessage {msgId, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta verifiedMsg + (m'', conn', msg@RcvMessage {msgId, sharedMsgId_, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta verifiedMsg let ctx js = DeliveryTaskContext js False checkSendAsGroup :: Maybe Bool -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext) checkSendAsGroup asGroup_ a @@ -1078,7 +1081,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XGrpDel -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' msg brokerTs XGrpInfo p' -> fmap ctx <$> xGrpInfo gInfo' m'' p' msg brokerTs XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs gInfo' m'' ps' msg - XGrpRoster gr -> fmap ctx <$> xGrpRoster gInfo' m'' gr verifiedMsg brokerTs + XGrpRoster gr -> fmap ctx <$> xGrpRoster gInfo' m'' gr verifiedMsg sharedMsgId_ brokerTs XGrpRosterAck ackVer ackErr -> Nothing <$ xGrpRosterAck gInfo' m'' ackVer ackErr -- TODO [knocking] why don't we forward these messages? XGrpDirectInv connReq mContent_ msgScope -> memberCanSend (Just m'') msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs @@ -2466,10 +2469,55 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ft <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId >>= getRcvFileTransfer db user receiveInlineChunk ft chunk meta + -- A group BFileChunk is either a roster blob chunk (located by (group_id, shared_msg_id, + -- file_type = roster)) or a normal inline file chunk (located via its chat item). An + -- orphaned roster chunk that matches no in-flight transfer is ACKed and ignored. bFileChunkGroup :: GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> CM () - bFileChunkGroup GroupInfo {groupId} sharedMsgId chunk meta = do - ft <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId >>= getRcvFileTransfer db user - receiveInlineChunk ft chunk meta + bFileChunkGroup gInfo@GroupInfo {groupId} sharedMsgId chunk meta = do + rosterFileId_ <- withStore' $ \db -> getGroupRosterFileId db userId groupId sharedMsgId + case rosterFileId_ of + Just fileId -> do + ft <- withStore $ \db -> getRcvFileTransfer db user fileId + receiveRosterChunk gInfo ft meta chunk + Nothing -> do + normalFileId_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupFileIdBySharedMsgId db userId groupId sharedMsgId) + case normalFileId_ of + Just fileId -> do + ft <- withStore $ \db -> getRcvFileTransfer db user fileId + receiveInlineChunk ft chunk meta + -- orphaned roster chunk (header short-circuited; version already applied/superseded): + -- ignore so an up-to-date member tolerates the unconditional re-serve (the outer + -- withAckMessage acks the agent message) + Nothing -> pure () + + -- Roster blob receive: reset-on-chunk-1 for a re-driven transfer, then append; the final + -- chunk drives completion (verify, apply, promote). No chat item, so no file-start/complete UI. + receiveRosterChunk :: GroupInfo -> RcvFileTransfer -> MsgMeta -> FileChunk -> CM () + receiveRosterChunk gInfo ft@RcvFileTransfer {chunkSize} MsgMeta {recipient = (msgId, _), integrity} = \case + FileChunkCancel -> cleanupGroupRosterFile user gInfo + FileChunk {chunkNo, chunkBytes = chunk} -> do + case integrity of + MsgOk -> pure () + MsgError MsgDuplicate -> pure () + MsgError e -> badRcvFileChunk ft $ "invalid file chunk number " <> show chunkNo <> ": " <> show e + -- a re-driven transfer (relay restart / re-subscribe / QCONT) restarts from the start; + -- discard partials so stale bytes can't corrupt the reassembled blob + when (chunkNo == 1) $ do + last_ <- withStore' $ \db -> getRcvFileLastChunkNo db ft + when (isJust last_) $ resetRosterPartialChunks ft + -- the outer withAckMessage ("group msg") acks the agent message; roster chunks must NOT + -- ack again (the agent message is already acked -> SEMsgNotFound) + withStore' (\db -> createRcvFileChunk db ft chunkNo msgId) >>= \case + RcvChunkOk + | B.length chunk /= fromInteger chunkSize -> badRcvFileChunk ft "incorrect chunk size" + | otherwise -> appendFileChunk ft chunkNo chunk False + RcvChunkFinal + | B.length chunk > fromInteger chunkSize -> badRcvFileChunk ft "incorrect chunk size" + | otherwise -> do + appendFileChunk ft chunkNo chunk True + rosterCompletion gInfo ft + RcvChunkDuplicate -> pure () + RcvChunkError -> badRcvFileChunk ft ("incorrect chunk number " <> show chunkNo) receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> CM () receiveInlineChunk RcvFileTransfer {fileId, fileStatus = RFSNew} FileChunk {chunkNo} _ @@ -3192,89 +3240,139 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toView CEvtMemberRole {user, groupInfo = gInfo'', byMember = m', member = member {memberRole = memRole}, fromRole, toRole = memRole, msgSigned} pure $ memberEventDeliveryScope member - xGrpRoster :: MsgEncodingI e => GroupInfo -> GroupMember -> GroupRoster -> VerifiedMsg e -> UTCTime -> CM (Maybe DeliveryJobScope) - xGrpRoster gInfo author roster verifiedMsg brokerTs + -- The header only STARTS a transfer: it writes roster_pending_* and creates the + -- chat-item-free rcv file. It never applies the roster or bumps the version (that + -- happens at blob completion, so a withheld/corrupted blob leaves the last roster intact). + xGrpRoster :: GroupInfo -> GroupMember -> GroupRoster -> VerifiedMsg e -> Maybe SharedMsgId -> UTCTime -> CM (Maybe DeliveryJobScope) + xGrpRoster gInfo author GroupRoster {version = newVer, fileInv = InlineFileInvitation {fileSize, fileDigest}} verifiedMsg sharedMsgId_ brokerTs -- only an owner may sign a roster; otherwise a relay could route it as a member whose key it controls | memberRole' author /= GROwner = messageError "x.grp.roster: not signed by an owner" $> Nothing - | length entries > maxGroupRosterSize = messageError ("x.grp.roster: too many entries, max " <> tshow maxGroupRosterSize) $> Nothing - | isUserGrpFwdRelay gInfo = relayApplyRoster - | otherwise = Nothing <$ memberApplyRoster + | otherwise = case (verifiedMsg, sharedMsgId_) of + (VMUnsigned _, _) -> Nothing <$ messageWarning "x.grp.roster: unsigned roster" + (_, Nothing) -> Nothing <$ messageWarning "x.grp.roster: missing shared message id" + (VMSigned _ sm _, Just sharedMsgId) -> do + pendingVer_ <- fmap (\(v, _, _, _, _) -> v) <$> withStore' (\db -> getRosterPending db gInfo) + -- start only for a version strictly greater than BOTH applied and pending (Nothing < 0): + -- a relay's first v0 from NULL applies; a re-receive at Just 0 short-circuits; and an + -- unconditional re-serve of a cached older version cannot supersede a newer in-flight one. + if newVer `aboveRoster` rosterVersion gInfo && newVer `aboveRoster` pendingVer_ + then startRosterTransfer sm sharedMsgId + -- silent: re-serves of the current version are routine (broadcast / SENT / QCONT) + else pure Nothing where - GroupRoster {version = newVer, roster = entries} = validRoster - validRoster = validateGroupRoster roster - relayApplyRoster :: CM (Maybe DeliveryJobScope) - relayApplyRoster - | maybe False (newVer <=) (rosterVersion gInfo) = Nothing <$ messageWarning "x.grp.roster: not newer than saved version" - | otherwise = case verifiedMsg of - VMSigned _ sm _ -> - tryAllErrors (setRoster sm) >>= \case - Right results -> do - emitRosterResults results - -- ack only while still setting up (own status RSAccepted); a serving relay (RSActive) must not ack roster broadcasts - when (relayOwnStatus gInfo == Just RSAccepted) $ sendRosterAck author newVer Nothing - -- always broadcast on a bump: self-healing, and demotions must reach members - pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} - Left e -> do - eToView e - when (relayOwnStatus gInfo == Just RSAccepted) $ sendRosterAck author newVer (Just "relay could not save the roster") - pure Nothing - VMUnsigned _ -> Nothing <$ messageWarning "x.grp.roster: unsigned roster" - setRoster :: SignedMsg -> CM ([MemberId], [(GroupMember, GroupMemberRole)]) - setRoster sm = do - defaultRole <- unknownMemberRole gInfo - withStore $ \db -> do - res <- processRoster db defaultRole - liftIO $ setGroupRoster db gInfo newVer (groupMemberId' author) brokerTs sm - pure res - memberApplyRoster :: CM () - memberApplyRoster - | maybe False (newVer <) (rosterVersion gInfo) = messageWarning "x.grp.roster: older than accepted version" - | maybe False (newVer ==) (rosterVersion gInfo) = pure () - | otherwise = do - defaultRole <- unknownMemberRole gInfo - results <- withStore $ \db -> do - res <- processRoster db defaultRole - liftIO $ setGroupRosterVersion db gInfo newVer - pure res - emitRosterResults results - processRoster :: DB.Connection -> GroupMemberRole -> ExceptT StoreError IO ([MemberId], [(GroupMember, GroupMemberRole)]) - processRoster db defaultRole = do - let rosterIds = map (\RosterMember {memberId} -> memberId) entries - acc <- foldrM applyRosterEntry ([], []) entries - -- absent privileged members revert to the joiner default - currentPriv <- liftIO $ getGroupRosterMembers db vr user gInfo - liftIO $ forM_ currentPriv $ \m -> - when (memberId' m `notElem` rosterIds) $ - updateGroupMemberRole db user m defaultRole - pure acc + startRosterTransfer sm sharedMsgId = do + -- supersede any in-flight roster file (older version or a restart) before the new transfer + cleanupGroupRosterFile user gInfo + let relayHdr = if isUserGrpFwdRelay gInfo then Just sm else Nothing + withStore' $ \db -> setRosterPending db gInfo newVer fileDigest (groupMemberId' author) brokerTs relayHdr + chSize <- asks $ fileChunkSize . config + rft@RcvFileTransfer {fileId} <- withStore' $ \db -> createGroupRosterRcvFile db userId gInfo sharedMsgId fileSize (fromIntegral chSize) + -- accept the chat-item-free file before chunk 1 (FIFO before it) so chunk 1 isn't rejected on RFSNew + filePath <- getRcvFilePath fileId Nothing "roster" False + withStore' $ \db -> startRcvInlineFT db user rft filePath (Just IFMSent) + pure Nothing + + -- Roster version comparison treating Nothing (un-materialized) as below 0. + aboveRoster :: VersionRoster -> Maybe VersionRoster -> Bool + aboveRoster v = maybe True (v >) + + -- The roster blob has fully arrived: verify the owner-attested digest over the plaintext, + -- guard the version (no downgrade), apply, then in one DB transaction promote version + blob + -- (and, on a relay, the live header). On a relay also ack the owner and re-serve to members. + rosterCompletion :: GroupInfo -> RcvFileTransfer -> CM () + rosterCompletion gInfo RcvFileTransfer {fileStatus} = + withStore' (\db -> getRosterPending db gInfo) >>= \case + Nothing -> cleanupGroupRosterFile user gInfo + Just (pendingVer, pendingDigest, ownerGMId, rosterBrokerTs, _) -> do + owner_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupMemberById db vr user ownerGMId) + blob <- readAssembledRoster + let isRelay = isUserGrpFwdRelay gInfo + ackErr err = do + cleanupGroupRosterFile user gInfo + when isRelay $ forM_ owner_ $ \owner -> sendRosterAck gInfo owner pendingVer (Just err) + if FD.FileDigest (LC.sha512Hash (LB.fromStrict blob)) /= pendingDigest + then ackErr "relay could not verify the roster blob" + else case parseAll rosterBlobP blob of + Left _ -> ackErr "relay could not parse the roster blob" + Right entries + -- stale/out-of-order completion: reject, never downgrade + | not (pendingVer `aboveRoster` rosterVersion gInfo) -> cleanupGroupRosterFile user gInfo + | otherwise -> case owner_ of + Nothing -> cleanupGroupRosterFile user gInfo + Just author -> do + defaultRole <- unknownMemberRole gInfo + results <- withStore $ \db -> do + res <- processRosterEntries db gInfo defaultRole (validateGroupRoster entries) + liftIO $ promoteRosterPending db gInfo blob + pure res + cleanupGroupRosterFile user gInfo + emitRosterResults gInfo author rosterBrokerTs results + when isRelay $ do + -- ack only while still setting up (own status RSAccepted); a serving relay must not ack broadcasts + when (relayOwnStatus gInfo == Just RSAccepted) $ sendRosterAck gInfo author pendingVer Nothing + -- broadcast on a bump: self-healing, and demotions must reach members. + -- re-serve via forwardGroupRoster (header + blob), not a delivery task: a + -- BFileChunk body is not a forwardable JSON message. + broadcastRoster gInfo + where + readAssembledRoster = case fileStatus of + RFSAccepted fp -> readAt fp + RFSConnected fp -> readAt fp + RFSComplete fp -> readAt fp + _ -> throwChatError $ CEInternalError "roster file not in progress" + readAt fp = lift (toFSFilePath fp) >>= liftIO . B.readFile + + -- Push the freshly applied roster to the relay's member subscribers (header + blob each). + broadcastRoster :: GroupInfo -> CM () + broadcastRoster gInfo = do + members <- withStore' $ \db -> getGroupMembers db vr user gInfo + forM_ (filter rosterRecipient members) $ \m -> + forwardGroupRoster user gInfo m `catchAllErrors` eToView + where + rosterRecipient m@GroupMember {activeConn} = memberCurrent m && isJust activeConn && not (isRelay m) && memberRole' m /= GROwner + + -- TOFU apply over the parsed roster entries (unchanged logic, lifted from the old header + -- handler): create/find members, pin keys, update roles, revert absent privileged members. + processRosterEntries :: DB.Connection -> GroupInfo -> GroupMemberRole -> [RosterMember] -> ExceptT StoreError IO ([MemberId], [(GroupMember, GroupMemberRole)]) + processRosterEntries db gInfo defaultRole entries = do + let rosterIds = map (\RosterMember {memberId} -> memberId) entries + acc <- foldrM applyRosterEntry ([], []) entries + -- absent privileged members revert to the joiner default + currentPriv <- liftIO $ getGroupRosterMembers db vr user gInfo + liftIO $ forM_ currentPriv $ \m -> + when (memberId' m `notElem` rosterIds) $ + updateGroupMemberRole db user m defaultRole + pure acc + where + -- entry-level failure (StoreError or IO exception) is muted; the entry is dropped + applyRosterEntry RosterMember {memberId, name, key = MemberKey pubKey, role} (cs, as) = + apply `catchAllErrors` \_ -> pure (cs, as) where - -- entry-level failure (StoreError or IO exception) is muted; the entry is dropped - applyRosterEntry RosterMember {memberId, name, key = MemberKey pubKey, role} (cs, as) = - apply `catchAllErrors` \_ -> pure (cs, as) - where - applied m = (cs, ((m :: GroupMember) {memberRole = role}, memberRole' m) : as) - apply = getCreateUnknownGMByMemberId db vr user gInfo memberId name defaultRole True >>= \case - Nothing -> pure (cs, as) - Just (m, _) -> case memberPubKey m of - Just k - | k /= pubKey -> pure (memberId : cs, as) - | memberRole' m == role -> pure (cs, as) - | otherwise -> liftIO (updateGroupMemberRole db user m role) $> applied m - Nothing -> liftIO (setGroupMemberKeyRole db m pubKey role) $> applied m - emitRosterResults :: ([MemberId], [(GroupMember, GroupMemberRole)]) -> CM () - emitRosterResults (conflicts, applied) = do - forM_ conflicts $ \mid' -> - messageWarning $ "x.grp.roster: member key conflict, keeping trusted key, memberId=" <> safeDecodeUtf8 (strEncode mid') - forM_ applied $ \(member, fromRole) -> createItems member fromRole - createItems :: GroupMember -> GroupMemberRole -> CM () + applied m = (cs, ((m :: GroupMember) {memberRole = role}, memberRole' m) : as) + apply = getCreateUnknownGMByMemberId db vr user gInfo memberId name defaultRole True >>= \case + Nothing -> pure (cs, as) + Just (m, _) -> case memberPubKey m of + Just k + | k /= pubKey -> pure (memberId : cs, as) + | memberRole' m == role -> pure (cs, as) + | otherwise -> liftIO (updateGroupMemberRole db user m role) $> applied m + Nothing -> liftIO (setGroupMemberKeyRole db m pubKey role) $> applied m + + emitRosterResults :: GroupInfo -> GroupMember -> UTCTime -> ([MemberId], [(GroupMember, GroupMemberRole)]) -> CM () + emitRosterResults gInfo author rosterBrokerTs (conflicts, applied) = do + forM_ conflicts $ \mid' -> + messageWarning $ "x.grp.roster: member key conflict, keeping trusted key, memberId=" <> safeDecodeUtf8 (strEncode mid') + forM_ applied $ \(member, fromRole) -> createItems member fromRole + where createItems member fromRole = do let toRole = memberRole' member gEvent = RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) toRole (gInfo', author', scopeInfo) <- mkGroupChatScope gInfo author - createInternalChatItem user (CDGroupRcv gInfo' scopeInfo author') (CIRcvGroupEvent gEvent) (Just brokerTs) + createInternalChatItem user (CDGroupRcv gInfo' scopeInfo author') (CIRcvGroupEvent gEvent) (Just rosterBrokerTs) toView CEvtMemberRole {user, groupInfo = gInfo', byMember = author', member, fromRole, toRole, msgSigned = Just MSSVerified} - sendRosterAck :: GroupMember -> VersionRoster -> Maybe Text -> CM () - sendRosterAck owner ackVer err = void $ sendGroupMessage' user gInfo [owner] (XGrpRosterAck ackVer err) + + sendRosterAck :: GroupInfo -> GroupMember -> VersionRoster -> Maybe Text -> CM () + sendRosterAck gInfo owner ackVer err = void $ sendGroupMessage' user gInfo [owner] (XGrpRosterAck ackVer err) xGrpRosterAck :: GroupInfo -> GroupMember -> VersionRoster -> Maybe Text -> CM () xGrpRosterAck gInfo m ackVer err = do @@ -3608,7 +3706,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = processForwardedMsg :: VerifiedMsg 'Json -> Maybe GroupMember -> CM () processForwardedMsg verifiedMsg author_ = do rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author_ verifiedMsg brokerTs - forM_ rcvMsg_ $ \rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} -> case event of + forM_ rcvMsg_ $ \rcvMsg@RcvMessage {sharedMsgId_, chatMsgEvent = ACME _ event} -> case event of XMsgNew mc -> void $ memberCanSend author_ scope $ newGroupContentMessage gInfo author_ mc rcvMsg msgTs True where @@ -3630,7 +3728,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XGrpDel -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author rcvMsg msgTs XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo gInfo author p' rcvMsg msgTs XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs gInfo author ps' rcvMsg - XGrpRoster gr -> withAuthor XGrpRoster_ $ \author -> void $ xGrpRoster gInfo author gr verifiedMsg msgTs + XGrpRoster gr -> withAuthor XGrpRoster_ $ \author -> void $ xGrpRoster gInfo author gr verifiedMsg sharedMsgId_ msgTs _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) where withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM () diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index a7aa3284d9..fc70c66d01 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -48,12 +48,13 @@ import Data.Time.Clock (UTCTime) import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime) import Data.Type.Equality import Data.Typeable (Typeable) -import Data.Word (Word32) +import Data.Word (Word16, Word32) import Simplex.Chat.Call import Simplex.Chat.Options.DB (FromField (..), ToField (..)) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared +import qualified Simplex.FileTransfer.Description as FD import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion) import Simplex.Messaging.Agent.Store.DB (blobFieldDecoder, fromTextField_) import Simplex.Messaging.Compression (Compressed, compress1, decompress1, decompressedSize) @@ -367,11 +368,21 @@ data GrpMsgForward = GrpMsgForward } deriving (Eq, Show) --- | Owner-signed snapshot of the privileged (moderator/admin) set; owners are --- not included, their keys come from the link. +-- | Owner-signed roster header for the privileged (moderator/admin) set; owners +-- are not included, their keys come from the link. The member list itself is not +-- here: it is sent as a binary blob over the inline file transfer, and this header +-- carries only its inline-file invitation (size + owner-attested digest). data GroupRoster = GroupRoster { version :: VersionRoster, - roster :: [RosterMember] + fileInv :: InlineFileInvitation + } + deriving (Eq, Show) + +-- | Lean always-inline file invitation for the roster blob, carried in the signed +-- header. The digest authenticates the unsigned blob; integrity is entirely the digest. +data InlineFileInvitation = InlineFileInvitation + { fileSize :: Integer, + fileDigest :: FD.FileDigest } deriving (Eq, Show) @@ -383,6 +394,13 @@ data RosterMember = RosterMember } deriving (Eq, Show) +-- RosterMember is binary-only: it rides in the roster blob, never in a JSON message. +-- The blob codec (encodeRosterBlob / rosterBlobP) is defined with maxGroupRosterSize below, +-- so rosterBlobP and the bound it references sit in one declaration group (past the TH splices). +instance Encoding RosterMember where + smpEncode RosterMember {memberId, name, key, role} = smpEncode (memberId, name, key, role) + smpP = RosterMember <$> smpP <*> smpP <*> smpP <*> smpP + instance Encoding FwdSender where smpEncode = \case FwdMember memberId memberName -> smpEncode ('M', memberId, memberName) @@ -809,7 +827,7 @@ data MsgMention = MsgMention {memberId :: MemberId} newtype MsgMentions = MsgMentions (Map MemberName MsgMention) deriving (Eq, Show) -$(JQ.deriveJSON defaultJSON ''RosterMember) +$(JQ.deriveJSON defaultJSON ''InlineFileInvitation) $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MCL") ''MsgChatLink) @@ -911,12 +929,23 @@ maxCompressedMsgLength = 13380 maxDecompressedMsgLength :: Int maxDecompressedMsgLength = 65536 --- Bound so the signed roster fits maxEncodedMsgLength (15602 B): ~140 B per --- RosterMember (memberId + Ed25519 key both base64, role, name capped at 16 --- chars by memberShortenedName). Fits 64 entries even with 4-byte-UTF-8 names. +-- Defensive entry-count bound for the roster blob parser (rosterBlobP) and the +-- promotion cap over the privileged (moderator/admin) set. The blob rides over the +-- inline file transfer, so it is no longer bound by maxEncodedMsgLength. maxGroupRosterSize :: Int maxGroupRosterSize = 64 +-- The byte sequence the owner-signed digest is computed over and verified against +-- before parsing. Word16 count (smpEncodeList's 1-byte count is too small for the future cap). +encodeRosterBlob :: [RosterMember] -> ByteString +encodeRosterBlob ms = smpEncode (fromIntegral (length ms) :: Word16) <> B.concat (map smpEncode ms) + +rosterBlobP :: A.Parser [RosterMember] +rosterBlobP = do + n <- fromIntegral <$> smpP @Word16 + when (n > maxGroupRosterSize) $ fail "roster: too many entries" + A.count n smpP + -- maxEncodedMsgLength - delta between MSG and INFO + 100 (returned for forward overhead) -- delta between MSG and INFO = e2eEncUserMsgLength (no PQ) - e2eEncConnInfoLength (no PQ) = 1008 maxEncodedInfoLength :: Int @@ -1398,7 +1427,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XGrpInfo_ -> XGrpInfo <$> p "groupProfile" XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences" XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope" - XGrpRoster_ -> XGrpRoster <$> (GroupRoster <$> p "version" <*> p "roster") + XGrpRoster_ -> XGrpRoster <$> (GroupRoster <$> p "version" <*> p "fileInv") XGrpRosterAck_ -> XGrpRosterAck <$> p "version" <*> opt "error" XGrpMsgForward_ -> do fwdSender <- opt "memberId" >>= \case @@ -1472,7 +1501,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en XGrpInfo p -> o ["groupProfile" .= p] XGrpPrefs p -> o ["groupPreferences" .= p] XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq] - XGrpRoster GroupRoster {version, roster} -> o ["version" .= version, "roster" .= roster] + XGrpRoster GroupRoster {version, fileInv} -> o ["version" .= version, "fileInv" .= fileInv] XGrpRosterAck version err -> o $ ("error" .=? err) ["version" .= version] XGrpMsgForward GrpMsgForward {fwdSender, fwdBrokerTs} msg -> o $ encodeFwdSender fwdSender ["msg" .= msg, "msgTs" .= fwdBrokerTs] where diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index 951fce8958..be97e8a686 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -31,6 +31,11 @@ module Simplex.Chat.Store.Files getSharedMsgIdByFileId, getFileIdBySharedMsgId, getGroupFileIdBySharedMsgId, + getGroupRosterFileId, + createGroupRosterRcvFile, + getGroupRosterFileInfo, + deleteGroupRosterFile, + getRcvFileLastChunkNo, getDirectFileIdBySharedMsgId, getChatRefByFileId, lookupChatRefByFileId, @@ -320,6 +325,79 @@ getGroupFileIdBySharedMsgId db userId groupId sharedMsgId = |] (userId, groupId, sharedMsgId) +-- The roster blob file is located by (group_id, shared_msg_id, file_type = roster), +-- not by a chat item (it has none). Nothing => no in-flight roster transfer (orphaned +-- chunk to an up-to-date member), which the caller ACKs and ignores. +getGroupRosterFileId :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> IO (Maybe Int64) +getGroupRosterFileId db userId groupId sharedMsgId = + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT file_id FROM files + WHERE user_id = ? AND group_id = ? AND shared_msg_id = ? AND file_type = ? + |] + (userId, groupId, sharedMsgId, FTRoster) + +-- Chat-item-free received file for the roster blob: cryptoArgs are never set (the +-- blob is verified as plaintext against the owner-signed digest), file_type = roster, +-- located by the header's shared_msg_id. +createGroupRosterRcvFile :: DB.Connection -> UserId -> GroupInfo -> SharedMsgId -> Integer -> Integer -> IO RcvFileTransfer +createGroupRosterRcvFile db userId GroupInfo {groupId, localDisplayName = gName} sharedMsgId fileSize chunkSize = do + currentTs <- getCurrentTime + fileId <- do + DB.execute + db + [sql| + INSERT INTO files + (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, protocol, file_type, shared_msg_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + (userId, groupId, rosterFileName, fileSize, chunkSize, Just IFMSent, CIFSRcvInvitation, FPSMP, FTRoster, sharedMsgId, currentTs, currentTs) + insertedRowId db + DB.execute + db + "INSERT INTO rcv_files (file_id, file_status, file_inline, rcv_file_inline, created_at, updated_at) VALUES (?,?,?,?,?,?)" + (fileId, FSNew, Just IFMSent, Just IFMSent, currentTs, currentTs) + pure + RcvFileTransfer + { fileId, + xftpRcvFile = Nothing, + fileInvitation = FileInvitation {fileName = rosterFileName, fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Just IFMSent, fileDescr = Nothing}, + fileStatus = RFSNew, + fileType = FTRoster, + rcvFileInline = Just IFMSent, + senderDisplayName = gName, + chunkSize, + cancelled = False, + grpMemberId = Nothing, + cryptoArgs = Nothing + } + where + rosterFileName = "roster" + +-- For roster-file cleanup keyed on the group (not a chat item): the file_id and its +-- on-disk path, so the caller can evict the cached handle and remove the file. +getGroupRosterFileInfo :: DB.Connection -> UserId -> Int64 -> IO (Maybe (Int64, Maybe FilePath)) +getGroupRosterFileInfo db userId groupId = + maybeFirstRow id $ + DB.query + db + "SELECT file_id, file_path FROM files WHERE user_id = ? AND group_id = ? AND file_type = ?" + (userId, groupId, FTRoster) + +-- Deletes the roster files row; rcv_files and rcv_file_chunks cascade on the FK. +deleteGroupRosterFile :: DB.Connection -> UserId -> Int64 -> IO () +deleteGroupRosterFile db userId groupId = + DB.execute db "DELETE FROM files WHERE user_id = ? AND group_id = ? AND file_type = ?" (userId, groupId, FTRoster) + +-- The highest stored chunk number, or Nothing if no partial chunks exist (used to decide +-- whether an arriving chunk 1 is a re-driven transfer that must reset). +getRcvFileLastChunkNo :: DB.Connection -> RcvFileTransfer -> IO (Maybe Integer) +getRcvFileLastChunkNo db RcvFileTransfer {fileId} = + maybeFirstRow fromOnly $ + DB.query db "SELECT chunk_number FROM rcv_file_chunks WHERE file_id = ? ORDER BY chunk_number DESC LIMIT 1" (Only fileId) + getDirectFileIdBySharedMsgId :: DB.Connection -> User -> Contact -> SharedMsgId -> ExceptT StoreError IO Int64 getDirectFileIdBySharedMsgId db User {userId} Contact {contactId} sharedMsgId = ExceptT . firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ @@ -378,7 +456,7 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File db "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs) - pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing} + pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, fileType = FTNormal, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing} createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> Maybe GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do @@ -401,7 +479,7 @@ createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gNam db "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, grpMemberId_, rfdId, currentTs, currentTs) - pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = grpMemberId_, cryptoArgs = Nothing} + pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, fileType = FTNormal, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = grpMemberId_, cryptoArgs = Nothing} createRcvStandaloneFileTransfer :: DB.Connection -> UserId -> CryptoFile -> Int64 -> Word32 -> ExceptT StoreError IO Int64 createRcvStandaloneFileTransfer db userId (CryptoFile filePath cfArgs_) fileSize chunkSize = do @@ -530,7 +608,7 @@ getRcvFileTransfer_ db userId fileId = do SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name, f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name, f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline, - r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name + r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name, f.file_type FROM rcv_files r JOIN files f USING (file_id) LEFT JOIN contacts cs ON cs.contact_id = f.contact_id @@ -544,9 +622,9 @@ getRcvFileTransfer_ db userId fileId = do where rcvFileTransfer :: Maybe RcvFileDescr -> - (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. Only (Maybe ContactName) -> + (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. (Maybe ContactName, FileType) -> ExceptT StoreError IO RcvFileTransfer - rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. Only groupName_) = + rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. (groupName_, fileType)) = case contactName_ <|> memberName_ <|> groupName_ <|> standaloneName_ of Nothing -> throwError $ SERcvFileInvalid fileId Just name -> @@ -564,7 +642,7 @@ getRcvFileTransfer_ db userId fileId = do let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing} cryptoArgs = CFArgs <$> fileKey <*> fileNonce xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId, agentRcvFileDeleted, userApprovedRelays}) <$> rfd_ - in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs} + in RcvFileTransfer {fileId, xftpRcvFile, fileInvitation, fileStatus, fileType, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId, cryptoArgs} filePath = case filePath_ of Nothing -> throwError $ SERcvFileInvalid fileId Just fp -> pure fp diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index d1955d9f59..e744b87114 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -89,6 +89,11 @@ module Simplex.Chat.Store.Groups setGroupRosterVersion, setGroupRoster, getGroupRoster, + getRosterBlob, + setRosterPending, + getRosterPending, + promoteRosterPending, + clearRosterPending, setGroupMemberKeyRole, createRelayForOwner, getCreateRelayForMember, @@ -218,6 +223,7 @@ import Simplex.Chat.Types.Shared import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Protocol (ConfirmationId, ConnId, CreatedConnLink (..), InvitationId, OwnerAuth (..), UserId) import Simplex.Messaging.Agent.Store.AgentStore (firstRow, fromOnlyBI, maybeFirstRow) +import qualified Simplex.FileTransfer.Description as FD import Simplex.Messaging.Encoding (smpDecode, smpEncode) import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) import Simplex.Messaging.Agent.Store.Entity (DBEntityId) @@ -1440,6 +1446,102 @@ getGroupRoster db GroupInfo {groupId} = (\sigs -> (ownerGMId, brokerTs, SignedMsg cb sigs body)) <$> eitherToMaybe (smpDecode sigsBs) toRoster _ = Nothing +-- The durable completed roster blob a relay re-serves to joiners. +getRosterBlob :: DB.Connection -> GroupInfo -> IO (Maybe ByteString) +getRosterBlob db GroupInfo {groupId} = do + r <- maybeFirstRow fromOnly $ DB.query db "SELECT roster_blob FROM groups WHERE group_id = ?" (Only groupId) + pure $ case r of + Just (Just (Binary b)) -> Just b + _ -> Nothing + +-- In-flight roster transfer state. Version, digest, the sending owner's member id and +-- broker ts are always stored (completion needs the owner to attribute chat items and to +-- ack). The signed-header body/binding/signatures are relay-only (Nothing on a member), +-- and are promoted to the live header at completion so the relay can re-forward it. +setRosterPending :: DB.Connection -> GroupInfo -> VersionRoster -> FD.FileDigest -> GroupMemberId -> UTCTime -> Maybe SignedMsg -> IO () +setRosterPending db GroupInfo {groupId} v digest ownerGMId brokerTs sm_ = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE groups + SET roster_pending_version = ?, roster_pending_digest = ?, + roster_pending_sending_owner_gm_id = ?, roster_pending_broker_ts = ?, + roster_pending_msg_chat_binding = ?, roster_pending_msg_signatures = ?, roster_pending_msg_body = ?, + updated_at = ? + WHERE group_id = ? + |] + ((v, Binary (FD.unFileDigest digest), ownerGMId, brokerTs) + :. ((\SignedMsg {chatBinding} -> chatBinding) <$> sm_, (\SignedMsg {signatures} -> Binary (smpEncode signatures)) <$> sm_, (\SignedMsg {signedBody} -> Binary signedBody) <$> sm_, currentTs, groupId)) + +getRosterPending :: DB.Connection -> GroupInfo -> IO (Maybe (VersionRoster, FD.FileDigest, GroupMemberId, UTCTime, Maybe SignedMsg)) +getRosterPending db GroupInfo {groupId} = + (>>= toPending) + <$> maybeFirstRow + id + ( DB.query + db + [sql| + SELECT roster_pending_version, roster_pending_digest, + roster_pending_sending_owner_gm_id, roster_pending_broker_ts, + roster_pending_msg_chat_binding, roster_pending_msg_signatures, roster_pending_msg_body + FROM groups WHERE group_id = ? + |] + (Only groupId) + ) + where + toPending (Just v, Just (Binary d), Just ownerGMId, Just brokerTs, cb_, sigs_, body_) = + Just (v, FD.FileDigest d, ownerGMId, brokerTs, sm_) + where + sm_ = case (cb_, sigs_, body_) of + (Just cb, Just (Binary sigsBs), Just (Binary body)) -> + (\sigs -> SignedMsg cb sigs body) <$> eitherToMaybe (smpDecode sigsBs) + _ -> Nothing + toPending _ = Nothing + +-- Completion promotion in one statement: copy pending header -> live, store the +-- verified blob, bump version, clear pending. roster_blob and live roster_msg_* move together. +promoteRosterPending :: DB.Connection -> GroupInfo -> ByteString -> IO () +promoteRosterPending db GroupInfo {groupId} blob = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE groups SET + roster_version = roster_pending_version, + roster_blob = ?, + roster_sending_owner_gm_id = roster_pending_sending_owner_gm_id, + roster_broker_ts = roster_pending_broker_ts, + roster_msg_chat_binding = roster_pending_msg_chat_binding, + roster_msg_signatures = roster_pending_msg_signatures, + roster_msg_body = roster_pending_msg_body, + roster_pending_version = NULL, + roster_pending_digest = NULL, + roster_pending_sending_owner_gm_id = NULL, + roster_pending_broker_ts = NULL, + roster_pending_msg_chat_binding = NULL, + roster_pending_msg_signatures = NULL, + roster_pending_msg_body = NULL, + updated_at = ? + WHERE group_id = ? + |] + (Binary blob, currentTs, groupId) + +clearRosterPending :: DB.Connection -> GroupInfo -> IO () +clearRosterPending db GroupInfo {groupId} = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE groups SET + roster_pending_version = NULL, roster_pending_digest = NULL, + roster_pending_sending_owner_gm_id = NULL, roster_pending_broker_ts = NULL, + roster_pending_msg_chat_binding = NULL, roster_pending_msg_signatures = NULL, roster_pending_msg_body = NULL, + updated_at = ? + WHERE group_id = ? + |] + (currentTs, groupId) + setGroupMemberKeyRole :: DB.Connection -> GroupMember -> C.PublicKeyEd25519 -> GroupMemberRole -> IO () setGroupMemberKeyRole db GroupMember {groupMemberId} pubKey role = do currentTs <- getCurrentTime diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260601_group_roster.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260601_group_roster.hs index 21858f73e8..d569014c9b 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260601_group_roster.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260601_group_roster.hs @@ -15,11 +15,33 @@ ALTER TABLE groups ADD COLUMN roster_msg_chat_binding TEXT; ALTER TABLE groups ADD COLUMN roster_msg_signatures BYTEA; ALTER TABLE groups ADD COLUMN roster_sending_owner_gm_id BIGINT; ALTER TABLE groups ADD COLUMN roster_broker_ts TIMESTAMPTZ; +ALTER TABLE groups ADD COLUMN roster_blob BYTEA; +ALTER TABLE groups ADD COLUMN roster_pending_version INTEGER; +ALTER TABLE groups ADD COLUMN roster_pending_digest BYTEA; +ALTER TABLE groups ADD COLUMN roster_pending_msg_body BYTEA; +ALTER TABLE groups ADD COLUMN roster_pending_msg_chat_binding TEXT; +ALTER TABLE groups ADD COLUMN roster_pending_msg_signatures BYTEA; +ALTER TABLE groups ADD COLUMN roster_pending_sending_owner_gm_id BIGINT; +ALTER TABLE groups ADD COLUMN roster_pending_broker_ts TIMESTAMPTZ; +ALTER TABLE files ADD COLUMN shared_msg_id BYTEA; +ALTER TABLE files ADD COLUMN file_type TEXT NOT NULL DEFAULT 'normal'; +CREATE INDEX idx_files_group_id_shared_msg_id ON files(group_id, shared_msg_id); |] down_m20260601_group_roster :: Text down_m20260601_group_roster = [r| +DROP INDEX IF EXISTS idx_files_group_id_shared_msg_id; +ALTER TABLE files DROP COLUMN file_type; +ALTER TABLE files DROP COLUMN shared_msg_id; +ALTER TABLE groups DROP COLUMN roster_pending_broker_ts; +ALTER TABLE groups DROP COLUMN roster_pending_sending_owner_gm_id; +ALTER TABLE groups DROP COLUMN roster_pending_msg_signatures; +ALTER TABLE groups DROP COLUMN roster_pending_msg_chat_binding; +ALTER TABLE groups DROP COLUMN roster_pending_msg_body; +ALTER TABLE groups DROP COLUMN roster_pending_digest; +ALTER TABLE groups DROP COLUMN roster_pending_version; +ALTER TABLE groups DROP COLUMN roster_blob; ALTER TABLE groups DROP COLUMN roster_broker_ts; ALTER TABLE groups DROP COLUMN roster_sending_owner_gm_id; ALTER TABLE groups DROP COLUMN roster_msg_signatures; diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260601_group_roster.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260601_group_roster.hs index f23e41ce54..f5179e3a07 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260601_group_roster.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260601_group_roster.hs @@ -14,11 +14,33 @@ ALTER TABLE groups ADD COLUMN roster_msg_chat_binding TEXT; ALTER TABLE groups ADD COLUMN roster_msg_signatures BLOB; ALTER TABLE groups ADD COLUMN roster_sending_owner_gm_id INTEGER; ALTER TABLE groups ADD COLUMN roster_broker_ts TEXT; +ALTER TABLE groups ADD COLUMN roster_blob BLOB; +ALTER TABLE groups ADD COLUMN roster_pending_version INTEGER; +ALTER TABLE groups ADD COLUMN roster_pending_digest BLOB; +ALTER TABLE groups ADD COLUMN roster_pending_msg_body BLOB; +ALTER TABLE groups ADD COLUMN roster_pending_msg_chat_binding TEXT; +ALTER TABLE groups ADD COLUMN roster_pending_msg_signatures BLOB; +ALTER TABLE groups ADD COLUMN roster_pending_sending_owner_gm_id INTEGER; +ALTER TABLE groups ADD COLUMN roster_pending_broker_ts TEXT; +ALTER TABLE files ADD COLUMN shared_msg_id BLOB; +ALTER TABLE files ADD COLUMN file_type TEXT NOT NULL DEFAULT 'normal'; +CREATE INDEX idx_files_group_id_shared_msg_id ON files(group_id, shared_msg_id); |] down_m20260601_group_roster :: Query down_m20260601_group_roster = [sql| +DROP INDEX IF EXISTS idx_files_group_id_shared_msg_id; +ALTER TABLE files DROP COLUMN file_type; +ALTER TABLE files DROP COLUMN shared_msg_id; +ALTER TABLE groups DROP COLUMN roster_pending_broker_ts; +ALTER TABLE groups DROP COLUMN roster_pending_sending_owner_gm_id; +ALTER TABLE groups DROP COLUMN roster_pending_msg_signatures; +ALTER TABLE groups DROP COLUMN roster_pending_msg_chat_binding; +ALTER TABLE groups DROP COLUMN roster_pending_msg_body; +ALTER TABLE groups DROP COLUMN roster_pending_digest; +ALTER TABLE groups DROP COLUMN roster_pending_version; +ALTER TABLE groups DROP COLUMN roster_blob; ALTER TABLE groups DROP COLUMN roster_broker_ts; ALTER TABLE groups DROP COLUMN roster_sending_owner_gm_id; ALTER TABLE groups DROP COLUMN roster_msg_signatures; diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index ed31f10880..81df9730c0 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -188,7 +188,15 @@ CREATE TABLE groups( roster_msg_chat_binding TEXT, roster_msg_signatures BLOB, roster_sending_owner_gm_id INTEGER, - roster_broker_ts TEXT, -- received + roster_broker_ts TEXT, + roster_blob BLOB, + roster_pending_version INTEGER, + roster_pending_digest BLOB, + roster_pending_msg_body BLOB, + roster_pending_msg_chat_binding TEXT, + roster_pending_msg_signatures BLOB, + roster_pending_sending_owner_gm_id INTEGER, + roster_pending_broker_ts TEXT, -- received FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE CASCADE @@ -274,7 +282,9 @@ CREATE TABLE files( file_crypto_key BLOB, file_crypto_nonce BLOB, note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE, - redirect_file_id INTEGER REFERENCES files ON DELETE CASCADE + redirect_file_id INTEGER REFERENCES files ON DELETE CASCADE, + shared_msg_id BLOB, + file_type TEXT NOT NULL DEFAULT 'normal' ) STRICT; CREATE TABLE snd_files( file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE, @@ -1313,6 +1323,10 @@ ON groups( relay_request_group_link ) WHERE relay_request_group_link IS NOT NULL; +CREATE INDEX idx_files_group_id_shared_msg_id ON files( + group_id, + shared_msg_id +); CREATE TRIGGER on_group_members_insert_update_summary AFTER INSERT ON group_members FOR EACH ROW diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 141dceaad1..e78cf03fd2 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -973,6 +973,11 @@ newtype MemberKey = MemberKey C.PublicKeyEd25519 deriving (Eq, Show) deriving newtype (StrEncoding) +-- Binary encoding for the roster blob; delegates to the Ed25519 key. +instance Encoding MemberKey where + smpEncode (MemberKey k) = smpEncode k + smpP = MemberKey <$> smpP + instance FromJSON MemberKey where parseJSON = strParseJSON "MemberKey" @@ -1494,11 +1499,38 @@ instance ToJSON InlineFileMode where toJSON = J.String . textEncode toEncoding = JE.text . textEncode +-- Discriminates ordinary chat files from the roster blob file, so the receive +-- completion / cancel paths branch on the type rather than on chat_item_id (note +-- folders and redirects also lack a chat item). +data FileType = FTNormal | FTRoster + deriving (Eq, Show) + +instance TextEncoding FileType where + textEncode = \case + FTNormal -> "normal" + FTRoster -> "roster" + textDecode = \case + "normal" -> Just FTNormal + "roster" -> Just FTRoster + _ -> Nothing + +instance FromField FileType where fromField = fromTextField_ textDecode + +instance ToField FileType where toField = toField . textEncode + +instance FromJSON FileType where + parseJSON = textParseJSON "FileType" + +instance ToJSON FileType where + toJSON = J.String . textEncode + toEncoding = JE.text . textEncode + data RcvFileTransfer = RcvFileTransfer { fileId :: FileTransferId, xftpRcvFile :: Maybe XFTPRcvFile, fileInvitation :: FileInvitation, fileStatus :: RcvFileStatus, + fileType :: FileType, rcvFileInline :: Maybe InlineFileMode, senderDisplayName :: ContactName, chunkSize :: Integer, diff --git a/src/Simplex/Chat/Types/Shared.hs b/src/Simplex/Chat/Types/Shared.hs index c71f7ce37a..1f3d9dd5a8 100644 --- a/src/Simplex/Chat/Types/Shared.hs +++ b/src/Simplex/Chat/Types/Shared.hs @@ -11,6 +11,7 @@ import qualified Data.ByteString.Char8 as B import Data.Text (Text) import Simplex.Chat.Options.DB (FromField (..), ToField (..)) import Simplex.Messaging.Agent.Store.DB (fromTextField_) +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, enumJSON) import Simplex.Messaging.Util ((<$?>)) @@ -57,6 +58,12 @@ instance ToJSON GroupMemberRole where toJSON = textToJSON toEncoding = textToEncoding +-- Binary encoding for the roster blob; delegates to the canonical TextEncoding +-- (same member/moderator/admin form JSON and the DB use). GRUnknown round-trips. +instance Encoding GroupMemberRole where + smpEncode = smpEncode . textEncode + smpP = maybe (fail "bad GroupMemberRole") pure . textDecode =<< smpP + data GroupAcceptance = GAAccepted | GAPendingApproval | GAPendingReview deriving (Eq, Show) instance StrEncoding GroupAcceptance where diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 131c09cae9..0ff1e49daf 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -293,6 +293,8 @@ chatGroupTests = do it "role transitions update the roster (mod <-> admin, admin -> non-roster)" testChannelRoleTransitionsUpdateRoster it "malicious relay cannot downgrade or re-key a roster-established moderator via XGrpMemNew" testChannelRelayCannotDowngradeRosterMember it "should add relay to channel with roster (relay caches roster before joinable)" testChannelAddRelayWithRoster + it "roster blob spanning multiple chunks reassembles" testChannelRosterMultipartReassembly + it "corrupted roster blob is rejected on digest mismatch" testChannelRosterDigestMismatchRejected describe "channel message operations" $ do it "should update channel message" testChannelMessageUpdate it "should delete channel message" testChannelMessageDelete @@ -10397,6 +10399,69 @@ testChannelAddRelayWithRoster ps = -- the new relay holds the roster (cath is moderator) before it serves joiners checkMemberRow dan "cath" (Just "moderator") +-- With a tiny file chunk size the owner-signed roster blob spans several chunks, exercising +-- split + reassembly both owner->relay and relay->joiner. dan getting cath as moderator means +-- the chunks were reassembled in order and the digest verified over the reassembled blob. +testChannelRosterMultipartReassembly :: HasCallStack => TestParams -> IO () +testChannelRosterMultipartReassembly ps = + withNewTestChatCfgOpts ps cfg testOpts "alice" aliceProfile $ \alice -> + withNewTestChatCfgOpts ps cfg relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChatCfgOpts ps cfg testOpts "cath" cathProfile $ \cath -> + withNewTestChatCfgOpts ps cfg testOpts "dan" danProfile $ \dan -> do + (shortLink, fullLink) <- prepareChannel1Relay "team" alice bob + memberJoinChannel "team" [bob] [alice] shortLink fullLink cath + threadDelay 100000 + alice ##> "/mr #team cath moderator" + alice <## "#team: you changed the role of cath to moderator (signed)" + concurrentlyN_ + [ bob <## "#team: alice changed the role of cath from member to moderator (signed)", + cath <## "#team: alice changed your role from member to moderator (signed)" + ] + threadDelay 100000 + memberJoinChannel "team" [bob] [alice, cath] shortLink fullLink dan + dan <## "#team: alice changed the role of cath from member to moderator (signed)" + threadDelay 100000 + checkMemberRow dan "cath" (Just "moderator") + where + cfg = testCfg {fileChunkSize = 30} + +-- A malicious/garbled relay blob is rejected at the receiver: the owner-signed header carries +-- the digest, so a blob that does not hash to it is discarded and the roster is not applied +-- (the receiver's roster version does not advance to the corrupted roster's version). +testChannelRosterDigestMismatchRejected :: HasCallStack => TestParams -> IO () +testChannelRosterDigestMismatchRejected ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "frank" frankProfile $ \frank -> do + (shortLink, fullLink) <- prepareChannel1Relay "team" alice bob + memberJoinChannel "team" [bob] [alice] shortLink fullLink cath + threadDelay 100000 + alice ##> "/mr #team cath moderator" + alice <## "#team: you changed the role of cath to moderator (signed)" + concurrentlyN_ + [ bob <## "#team: alice changed the role of cath from member to moderator (signed)", + cath <## "#team: alice changed your role from member to moderator (signed)" + ] + threadDelay 100000 + -- corrupt the relay's stored blob (same length, different content) so its digest no + -- longer matches the signed header (DB-agnostic: read it, overwrite with zeroed bytes) + withCCTransaction bob $ \db -> do + rows <- DB.query_ db "SELECT roster_blob FROM groups WHERE roster_blob IS NOT NULL" :: IO [Only (Binary ByteString)] + forM_ rows $ \(Only (Binary blob)) -> + DB.execute db "UPDATE groups SET roster_blob = ? WHERE roster_blob IS NOT NULL" (Only (Binary (B.replicate (B.length blob) '\NUL'))) + -- frank joins; bob re-serves the valid header with the corrupted blob, frank rejects it + threadDelay 100000 + memberJoinChannel "team" [bob] [alice, cath] shortLink fullLink frank + threadDelay 100000 + checkRosterVersionBelow frank 1 + where + checkRosterVersionBelow :: HasCallStack => TestCC -> Int64 -> IO () + checkRosterVersionBelow cc target = do + vs <- withCCTransaction cc $ \db -> + DB.query_ db "SELECT roster_version FROM groups" :: IO [Only (Maybe Int64)] + all (< target) [v | Only (Just v) <- vs] `shouldBe` True + testChannelRemoveRelay :: HasCallStack => TestParams -> IO () testChannelRemoveRelay ps = withNewTestChat ps "alice" aliceProfile $ \alice ->