diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 3db4802aff..f15e789fef 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -2024,11 +2024,18 @@ processChatCommand' vr = \case updateCIGroupInvitationStatus user g CIGISAccepted `catchChatError` (toView . CRChatError (Just user)) pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing Nothing -> throwChatError $ CEContactNotActive ct - -- TODO [knocking] APIAcceptMember - APIAcceptMember groupId gmId memRole -> withUser $ \user -> do - -- Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId - -- pure $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected} -- GSMemApproved? - ok user + APIAcceptMember groupId gmId role -> withUser $ \user -> do + (gInfo, m) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db vr user gmId + assertUserGroupRole gInfo GRAdmin + when (memberStatus m /= GSMemPendingApproval) $ throwChatError $ CECommandError "member is not pending approval" + case memberConn m of + Just mConn -> do + let msg = XGrpLinkAcpt role + void $ sendDirectMemberMessage mConn msg groupId + m' <- withFastStore' $ \db -> updateGroupMemberAccepted db user m role + introduceToGroup vr user gInfo m + pure $ CRJoinedGroupMember user gInfo m' + _ -> throwChatError CEGroupMemberNotActive APIMemberRole groupId memberId memRole -> withUser $ \user -> do Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId if memberId == groupMemberId' membership diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 8638d52ccd..3afd899b28 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -38,7 +38,7 @@ import Data.Functor (($>)) import Data.Functor.Identity import Data.Int (Int64) import Data.List (find, mapAccumL, partition) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -78,7 +78,7 @@ import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.Messaging.Agent as Agent import Simplex.Messaging.Agent.Client (getFastNetworkConfig, ipAddressProtected, withLockMap) -import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..)) +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), ServerCfg (..)) import Simplex.Messaging.Agent.Lock (withLock) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) @@ -930,6 +930,132 @@ profileToSendOnAccept user ip = userProfileToSend user (getIncognitoProfile <$> NewIncognito p -> p ExistingIncognito lp -> fromLocalProfile lp +introduceToGroup :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM () +introduceToGroup _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active" +introduceToGroup vr user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn = Just conn} = do + members <- withStore' $ \db -> getGroupMembers db vr user gInfo + void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m + sendIntroductions members + when (groupFeatureAllowed SGFHistory gInfo) sendHistory + where + sendIntroductions members = do + intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m + shuffledIntros <- liftIO $ shuffleIntros intros + if m `supportsVersion` batchSendVersion + then do + let events = map (memberIntro . reMember) shuffledIntros + forM_ (L.nonEmpty events) $ \events' -> + sendGroupMemberMessages user conn events' groupId + else forM_ shuffledIntros $ \intro -> + processIntro intro `catchChatError` (toView . CRChatError (Just user)) + memberIntro :: GroupMember -> ChatMsgEvent 'Json + memberIntro reMember = + let mInfo = memberInfo reMember + mRestrictions = memberRestrictions reMember + in XGrpMemIntro mInfo mRestrictions + shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro] + shuffleIntros intros = do + let (admins, others) = partition isAdmin intros + (admPics, admNoPics) = partition hasPicture admins + (othPics, othNoPics) = partition hasPicture others + mconcat <$> mapM shuffle [admPics, admNoPics, othPics, othNoPics] + where + isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin + hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image + processIntro intro@GroupMemberIntro {introId} = do + void $ sendDirectMemberMessage conn (memberIntro $ reMember intro) groupId + withStore' $ \db -> updateIntroStatus db introId GMIntroSent + sendHistory = + when (m `supportsVersion` batchSendVersion) $ do + (errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100) + (errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items + let errors = map ChatErrorStore errs <> errs' + unless (null errors) $ toView $ CRChatErrors (Just user) errors + let events' = maybe (concat events) (\x -> concat events <> [x]) descrEvent_ + forM_ (L.nonEmpty events') $ \events'' -> + sendGroupMemberMessages user conn events'' groupId + descrEvent_ :: Maybe (ChatMsgEvent 'Json) + descrEvent_ + | m `supportsVersion` groupHistoryIncludeWelcomeVersion = do + let GroupInfo {groupProfile = GroupProfile {description}} = gInfo + fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description + | otherwise = Nothing + itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json] + itemForwardEvents cci = case cci of + (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) + | not (blockedByAdmin sender) -> do + fInvDescr_ <- join <$> forM file getRcvFileInvDescr + processContentItem sender ci mc fInvDescr_ + (CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do + fInvDescr_ <- join <$> forM file getSndFileInvDescr + processContentItem membership ci mc fInvDescr_ + _ -> pure [] + where + getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText)) + getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do + expired <- fileExpired + 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)) + getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do + expired <- fileExpired + if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired + then pure Nothing + 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 + fileExpired :: CM Bool + fileExpired = do + ttl <- asks $ rcvFilesTTL . agentConfig . config + cutoffTs <- addUTCTime (-ttl) <$> liftIO getCurrentTime + pure $ chatItemTs cci < cutoffTs + invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText) + invCompleteDescr CIFile {fileName, fileSize} RcvFileDescr {fileDescrText, fileDescrComplete} + | fileDescrComplete = + let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} + fInv = xftpFileInvitation fileName fileSize fInvDescr + in Just (fInv, fileDescrText) + | otherwise = Nothing + processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json] + processContentItem sender ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ = + if isNothing fInvDescr_ && not (msgContentHasText mc) + then pure [] + else do + let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta + quotedItemId_ = quoteItemId =<< quotedItem + fInv_ = fst <$> fInvDescr_ + (mc', _, mentions') = updatedMentionNames mc formattedText mentions + mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions' + (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False + let senderVRange = memberChatVRange' sender + xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent} + fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of + (Just fileDescrText, Just msgId) -> do + partSize <- asks $ xftpDescrPartSize . config + let parts = splitFileDescr partSize fileDescrText + pure . L.toList $ L.map (XMsgFileDescr msgId) parts + _ -> pure [] + let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents + GroupMember {memberId} = sender + msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) + pure msgForwardEvents + +splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr +splitFileDescr partSize rfdText = splitParts 1 rfdText + where + splitParts partNo remText = + let (part, rest) = T.splitAt partSize remText + complete = T.null rest + fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete} + in if complete + then fileDescr :| [] + else fileDescr <| splitParts (partNo + 1) rest + deleteGroupLink' :: User -> GroupInfo -> CM () deleteGroupLink' user gInfo = do vr <- chatVersionRange diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 38daba4ffb..08079e0a98 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -27,8 +27,8 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (lefts, partitionEithers, rights) import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (foldl', partition) -import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -36,8 +36,7 @@ import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) -import Data.Time (addUTCTime) -import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, diffUTCTime) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as V4 import Data.Word (Word32) @@ -60,14 +59,12 @@ import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared -import Simplex.Chat.Util (shuffle) import Simplex.FileTransfer.Description (ValidFileDescription) import qualified Simplex.FileTransfer.Description as FD import Simplex.FileTransfer.Protocol (FilePartyI) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId) import Simplex.Messaging.Agent as Agent -import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -296,17 +293,6 @@ agentFileError = \case SMP.TRANSPORT TEVersion -> srvErr SrvErrVersion e -> srvErr . SrvErrOther $ tshow e -splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr -splitFileDescr partSize rfdText = splitParts 1 rfdText - where - splitParts partNo remText = - let (part, rest) = T.splitAt partSize remText - complete = T.null rest - fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete} - in if complete - then fileDescr :| [] - else fileDescr <| splitParts (partNo + 1) rest - processAgentMsgRcvFile :: ACorrId -> RcvFileId -> AEvent 'AERcvFile -> CM () processAgentMsgRcvFile _corrId aFileId msg = do (cRef_, fileId) <- withStore (`getXFTPRcvFileDBIds` AgentRcvFileId aFileId) @@ -805,123 +791,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let Connection {viaUserContactLink} = conn when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem when (connChatVersion < batchSend2Version) sendGroupAutoReply - unless (status' == GSMemPendingApproval) introduceToGroup + unless (status' == GSMemPendingApproval) $ introduceToGroup vr user gInfo m where - introduceToGroup = do - members <- withStore' $ \db -> getGroupMembers db vr user gInfo - void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m - sendIntroductions members - when (groupFeatureAllowed SGFHistory gInfo) sendHistory sendXGrpLinkMem = do let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo profileToSend = profileToSendOnAccept user profileMode True void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId - sendIntroductions members = do - intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m - shuffledIntros <- liftIO $ shuffleIntros intros - if m `supportsVersion` batchSendVersion - then do - let events = map (memberIntro . reMember) shuffledIntros - forM_ (L.nonEmpty events) $ \events' -> - sendGroupMemberMessages user conn events' groupId - else forM_ shuffledIntros $ \intro -> - processIntro intro `catchChatError` (toView . CRChatError (Just user)) - memberIntro :: GroupMember -> ChatMsgEvent 'Json - memberIntro reMember = - let mInfo = memberInfo reMember - mRestrictions = memberRestrictions reMember - in XGrpMemIntro mInfo mRestrictions - shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro] - shuffleIntros intros = do - let (admins, others) = partition isAdmin intros - (admPics, admNoPics) = partition hasPicture admins - (othPics, othNoPics) = partition hasPicture others - mconcat <$> mapM shuffle [admPics, admNoPics, othPics, othNoPics] - where - isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin - hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image - processIntro intro@GroupMemberIntro {introId} = do - void $ sendDirectMemberMessage conn (memberIntro $ reMember intro) groupId - withStore' $ \db -> updateIntroStatus db introId GMIntroSent - sendHistory = - when (m `supportsVersion` batchSendVersion) $ do - (errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100) - (errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items - let errors = map ChatErrorStore errs <> errs' - unless (null errors) $ toView $ CRChatErrors (Just user) errors - let events' = maybe (concat events) (\x -> concat events <> [x]) descrEvent_ - forM_ (L.nonEmpty events') $ \events'' -> - sendGroupMemberMessages user conn events'' groupId - descrEvent_ :: Maybe (ChatMsgEvent 'Json) - descrEvent_ - | m `supportsVersion` groupHistoryIncludeWelcomeVersion = do - let GroupInfo {groupProfile = GroupProfile {description}} = gInfo - fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description - | otherwise = Nothing - itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json] - itemForwardEvents cci = case cci of - (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) - | not (blockedByAdmin sender) -> do - fInvDescr_ <- join <$> forM file getRcvFileInvDescr - processContentItem sender ci mc fInvDescr_ - (CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do - fInvDescr_ <- join <$> forM file getSndFileInvDescr - processContentItem membership ci mc fInvDescr_ - _ -> pure [] - where - getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText)) - getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do - expired <- fileExpired - 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)) - getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do - expired <- fileExpired - if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired - then pure Nothing - 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 - fileExpired :: CM Bool - fileExpired = do - ttl <- asks $ rcvFilesTTL . agentConfig . config - cutoffTs <- addUTCTime (-ttl) <$> liftIO getCurrentTime - pure $ chatItemTs cci < cutoffTs - invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText) - invCompleteDescr CIFile {fileName, fileSize} RcvFileDescr {fileDescrText, fileDescrComplete} - | fileDescrComplete = - let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} - fInv = xftpFileInvitation fileName fileSize fInvDescr - in Just (fInv, fileDescrText) - | otherwise = Nothing - processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json] - processContentItem sender ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ = - if isNothing fInvDescr_ && not (msgContentHasText mc) - then pure [] - else do - let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta - quotedItemId_ = quoteItemId =<< quotedItem - fInv_ = fst <$> fInvDescr_ - (mc', _, mentions') = updatedMentionNames mc formattedText mentions - mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions' - (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False - let senderVRange = memberChatVRange' sender - xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent} - fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of - (Just fileDescrText, Just msgId) -> do - partSize <- asks $ xftpDescrPartSize . config - let parts = splitFileDescr partSize fileDescrText - pure . L.toList $ L.map (XMsgFileDescr msgId) parts - _ -> pure [] - let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents - GroupMember {memberId} = sender - msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) - pure msgForwardEvents _ -> do let memCategory = memberCategory m withStore' (\db -> getViaGroupContact db vr user m) >>= \case @@ -984,6 +859,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName XInfo p -> xInfoMember gInfo m' p brokerTs XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p + XGrpLinkAcpt role -> xGrpLinkAcpt gInfo m' role XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs XGrpMemIntro memInfo memRestrictions_ -> xGrpMemIntro gInfo m' memInfo memRestrictions_ XGrpMemInv memId introInv -> xGrpMemInv gInfo m' memId introInv @@ -2194,10 +2070,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = probeMatchingMemberContact m' connectedIncognito else messageError "x.grp.link.mem error: invalid group link host profile update" - -- TODO [knocking] - -- xGrpLinkAcpt - -- set statuses to GSMemConnected - -- probeMatchingMemberContact + xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupMemberRole -> CM () + xGrpLinkAcpt GroupInfo {membership} m role = do + withStore' $ \db -> do + void $ updateGroupMemberAccepted db user membership role + updateGroupMemberStatus db userId m GSMemConnected + let m' = m {memberStatus = GSMemConnected} + connectedIncognito = memberIncognito membership + probeMatchingMemberContact m' connectedIncognito processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Bool -> Maybe UTCTime -> CM GroupMember processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} p' createItems itemTs_ diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 320d984e32..a145914ce7 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -331,9 +331,9 @@ data ChatMsgEvent (e :: MsgEncoding) where XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json XGrpAcpt :: MemberId -> ChatMsgEvent 'Json XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json - XGrpLinkAcpt :: MemberId -> ChatMsgEvent 'Json XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json XGrpLinkMem :: Profile -> ChatMsgEvent 'Json + XGrpLinkAcpt :: GroupMemberRole -> ChatMsgEvent 'Json XGrpMemNew :: MemberInfo -> ChatMsgEvent 'Json XGrpMemIntro :: MemberInfo -> Maybe MemberRestrictions -> ChatMsgEvent 'Json XGrpMemInv :: MemberId -> IntroInvitation -> ChatMsgEvent 'Json @@ -822,9 +822,9 @@ data CMEventTag (e :: MsgEncoding) where XGrpInv_ :: CMEventTag 'Json XGrpAcpt_ :: CMEventTag 'Json XGrpLinkInv_ :: CMEventTag 'Json - XGrpLinkAcpt_ :: CMEventTag 'Json XGrpLinkReject_ :: CMEventTag 'Json XGrpLinkMem_ :: CMEventTag 'Json + XGrpLinkAcpt_ :: CMEventTag 'Json XGrpMemNew_ :: CMEventTag 'Json XGrpMemIntro_ :: CMEventTag 'Json XGrpMemInv_ :: CMEventTag 'Json @@ -875,9 +875,9 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where XGrpInv_ -> "x.grp.inv" XGrpAcpt_ -> "x.grp.acpt" XGrpLinkInv_ -> "x.grp.link.inv" - XGrpLinkAcpt_ -> "x.grp.link.acpt" XGrpLinkReject_ -> "x.grp.link.reject" XGrpLinkMem_ -> "x.grp.link.mem" + XGrpLinkAcpt_ -> "x.grp.link.acpt" XGrpMemNew_ -> "x.grp.mem.new" XGrpMemIntro_ -> "x.grp.mem.intro" XGrpMemInv_ -> "x.grp.mem.inv" @@ -929,9 +929,9 @@ instance StrEncoding ACMEventTag where "x.grp.inv" -> XGrpInv_ "x.grp.acpt" -> XGrpAcpt_ "x.grp.link.inv" -> XGrpLinkInv_ - "x.grp.link.acpt" -> XGrpLinkAcpt_ "x.grp.link.reject" -> XGrpLinkReject_ "x.grp.link.mem" -> XGrpLinkMem_ + "x.grp.link.acpt" -> XGrpLinkAcpt_ "x.grp.mem.new" -> XGrpMemNew_ "x.grp.mem.intro" -> XGrpMemIntro_ "x.grp.mem.inv" -> XGrpMemInv_ @@ -979,9 +979,9 @@ toCMEventTag msg = case msg of XGrpInv _ -> XGrpInv_ XGrpAcpt _ -> XGrpAcpt_ XGrpLinkInv _ -> XGrpLinkInv_ - XGrpLinkAcpt _ -> XGrpLinkAcpt_ XGrpLinkReject _ -> XGrpLinkReject_ XGrpLinkMem _ -> XGrpLinkMem_ + XGrpLinkAcpt _ -> XGrpLinkAcpt_ XGrpMemNew _ -> XGrpMemNew_ XGrpMemIntro _ _ -> XGrpMemIntro_ XGrpMemInv _ _ -> XGrpMemInv_ @@ -1082,9 +1082,9 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XGrpInv_ -> XGrpInv <$> p "groupInvitation" XGrpAcpt_ -> XGrpAcpt <$> p "memberId" XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation" - XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "memberId" XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection" XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" + XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "role" XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo" <*> opt "memberRestrictions" XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro" @@ -1146,9 +1146,9 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @ XGrpInv groupInv -> o ["groupInvitation" .= groupInv] XGrpAcpt memId -> o ["memberId" .= memId] XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv] - XGrpLinkAcpt memId -> o ["memberId" .= memId] XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct] XGrpLinkMem profile -> o ["profile" .= profile] + XGrpLinkAcpt role -> o ["role" .= role] XGrpMemNew memInfo -> o ["memberInfo" .= memInfo] XGrpMemIntro memInfo memRestrictions -> o $ ("memberRestrictions" .=? memRestrictions) ["memberInfo" .= memInfo] XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro] diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 256c81fe6d..108ed25066 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -78,6 +78,7 @@ module Simplex.Chat.Store.Groups createMemberConnectionAsync, updateGroupMemberStatus, updateGroupMemberStatusById, + updateGroupMemberAccepted, createNewGroupMember, checkGroupMemberHasItems, deleteGroupMember, @@ -1202,6 +1203,19 @@ updateGroupMemberStatusById db userId groupMemberId memStatus = do |] (memStatus, currentTs, userId, groupMemberId) +updateGroupMemberAccepted :: DB.Connection -> User -> GroupMember -> GroupMemberRole -> IO GroupMember +updateGroupMemberAccepted db User {userId} m@GroupMember {groupMemberId} role = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + UPDATE group_members + SET member_status = ?, member_role = ?, updated_at = ? + WHERE user_id = ? AND group_member_id = ? + |] + (GSMemConnected, role, currentTs, userId, groupMemberId) + pure m {memberStatus = GSMemConnected, memberRole = role, updatedAt = currentTs} + -- | add new member with profile createNewGroupMember :: DB.Connection -> User -> GroupInfo -> GroupMember -> MemberInfo -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember createNewGroupMember db user gInfo invitingMember memInfo@MemberInfo {profile} memCategory memStatus = do