mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-10-23 15:03:16 +00:00
core: member acceptance (#5678)
* core: member acceptance * migration * move hook * core: support sending direct messages to members (#5680) * fix compilation, todos * fix test * predicates * comment * extend hook * wip * wip * wip * wip * fix test * mute output * schema * better query * plans * fix test * directory * captcha * captcha works * remove column, add UI types and group status icon * fix test * query plans * exclude messages of pending members from history * commands for filter settings * core: separately delete pending approval members; other apis validation (#5699) * accepted status * send captcha messages as replies * fix blocked words * simpler filter info * info about /filter and /role after group registration * update query plans --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgenyandspaced4ndy authored and GitHub committed
1 parent
27bf19c2b1
commit
b2de37a9fb
32 files changed
+1188
-525
No files matched your search
@@ -112,9 +112,6 @@ defaultChatConfig =
|
||||
ntf = _defaultNtfServers,
|
||||
netCfg = defaultNetworkConfig
|
||||
},
|
||||
allowedProfileName = Nothing,
|
||||
profileNameLimit = maxBound,
|
||||
acceptAsObserver = Nothing,
|
||||
tbqSize = 1024,
|
||||
fileChunkSize = 15780, -- do not change
|
||||
xftpDescrPartSize = 14000,
|
||||
|
||||
+13
-4
@@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Chat.Bot where
|
||||
|
||||
@@ -11,6 +12,8 @@ import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@@ -68,10 +71,16 @@ sendComposedMessage :: ChatController -> Contact -> Maybe ChatItemId -> MsgConte
|
||||
sendComposedMessage cc = sendComposedMessage' cc . contactId'
|
||||
|
||||
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
|
||||
sendComposedMessage' cc ctId quotedItemId msgContent = do
|
||||
let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent, mentions = M.empty}
|
||||
sendChatCmd cc (APISendMessages (ChatRef CTDirect ctId) False Nothing [cm]) >>= \case
|
||||
CRNewChatItems {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
|
||||
sendComposedMessage' cc ctId qiId mc = sendComposedMessages_ cc (SRDirect ctId) [(qiId, mc)]
|
||||
|
||||
sendComposedMessages :: ChatController -> SendRef -> NonEmpty MsgContent -> IO ()
|
||||
sendComposedMessages cc sendRef = sendComposedMessages_ cc sendRef . L.map (Nothing,)
|
||||
|
||||
sendComposedMessages_ :: ChatController -> SendRef -> NonEmpty (Maybe ChatItemId, MsgContent) -> IO ()
|
||||
sendComposedMessages_ cc sendRef qmcs = do
|
||||
let cms = L.map (\(qiId, mc) -> ComposedMessage {fileSource = Nothing, quotedItemId = qiId, msgContent = mc, mentions = M.empty}) qmcs
|
||||
sendChatCmd cc (APISendMessages sendRef False Nothing cms) >>= \case
|
||||
CRNewChatItems {} -> printLog cc CLLInfo $ "sent " <> show (length cms) <> " messages to " <> show sendRef
|
||||
r -> putStrLn $ "unexpected send message response: " <> show r
|
||||
|
||||
deleteMessage :: ChatController -> Contact -> ChatItemId -> IO ()
|
||||
|
||||
@@ -19,7 +19,8 @@ module Simplex.Chat.Controller where
|
||||
|
||||
import Control.Concurrent (ThreadId)
|
||||
import Control.Concurrent.Async (Async)
|
||||
import Control.Exception
|
||||
import Control.Exception (Exception, SomeException)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
@@ -60,7 +61,7 @@ import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Remote.AppVersion
|
||||
import Simplex.Chat.Remote.Types
|
||||
import Simplex.Chat.Stats (PresentedServersSummary)
|
||||
import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserContactLink, UserMsgReceiptSettings)
|
||||
import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserContactLink, GroupLinkInfo, UserMsgReceiptSettings)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
@@ -93,7 +94,6 @@ import Simplex.RemoteControl.Invitation (RCSignedInvitation, RCVerifiedInvitatio
|
||||
import Simplex.RemoteControl.Types
|
||||
import System.IO (Handle)
|
||||
import System.Mem.Weak (Weak)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
#if !defined(dbPostgres)
|
||||
import Database.SQLite.Simple (SQLError)
|
||||
@@ -137,9 +137,6 @@ data ChatConfig = ChatConfig
|
||||
chatVRange :: VersionRangeChat,
|
||||
confirmMigrations :: MigrationConfirmation,
|
||||
presetServers :: PresetServers,
|
||||
allowedProfileName :: Maybe (ContactName -> Bool),
|
||||
profileNameLimit :: Int,
|
||||
acceptAsObserver :: Maybe AcceptAsObserver,
|
||||
tbqSize :: Natural,
|
||||
fileChunkSize :: Integer,
|
||||
xftpDescrPartSize :: Int,
|
||||
@@ -161,11 +158,6 @@ data ChatConfig = ChatConfig
|
||||
chatHooks :: ChatHooks
|
||||
}
|
||||
|
||||
data AcceptAsObserver
|
||||
= AOAll -- all members
|
||||
| AONameOnly -- members without image
|
||||
| AOIncognito -- members with incognito-style names and without image
|
||||
|
||||
data RandomAgentServers = RandomAgentServers
|
||||
{ smpServers :: NonEmpty (ServerCfg 'PSMP),
|
||||
xftpServers :: NonEmpty (ServerCfg 'PXFTP)
|
||||
@@ -177,18 +169,16 @@ data ChatHooks = ChatHooks
|
||||
{ -- preCmdHook can be used to process or modify the commands before they are processed.
|
||||
-- This hook should be used to process CustomChatCommand.
|
||||
-- if this hook returns ChatResponse, the command processing will be skipped.
|
||||
preCmdHook :: ChatController -> ChatCommand -> IO (Either ChatResponse ChatCommand),
|
||||
preCmdHook :: Maybe (ChatController -> ChatCommand -> IO (Either ChatResponse ChatCommand)),
|
||||
-- eventHook can be used to additionally process or modify events,
|
||||
-- it is called before the event is sent to the user (or to the UI).
|
||||
eventHook :: ChatController -> ChatResponse -> IO ChatResponse
|
||||
eventHook :: Maybe (ChatController -> ChatResponse -> IO ChatResponse),
|
||||
-- acceptMember hook can be used to accept or reject member connecting via group link without API calls
|
||||
acceptMember :: Maybe (GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)))
|
||||
}
|
||||
|
||||
defaultChatHooks :: ChatHooks
|
||||
defaultChatHooks =
|
||||
ChatHooks
|
||||
{ preCmdHook = \_ -> pure . Right,
|
||||
eventHook = \_ -> pure
|
||||
}
|
||||
defaultChatHooks = ChatHooks Nothing Nothing Nothing
|
||||
|
||||
data PresetServers = PresetServers
|
||||
{ operators :: NonEmpty PresetOperator,
|
||||
@@ -313,7 +303,7 @@ data ChatCommand
|
||||
| APIGetChat ChatRef (Maybe MsgContentTag) ChatPagination (Maybe String)
|
||||
| APIGetChatItems ChatPagination (Maybe String)
|
||||
| APIGetChatItemInfo ChatRef ChatItemId
|
||||
| APISendMessages {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage}
|
||||
| APISendMessages {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage}
|
||||
| APICreateChatTag ChatTagData
|
||||
| APISetChatTags ChatRef (Maybe (NonEmpty ChatTagId))
|
||||
| APIDeleteChatTag ChatTagId
|
||||
@@ -366,6 +356,7 @@ data ChatCommand
|
||||
| ApiGetConnNtfMessages {connIds :: NonEmpty AgentConnId}
|
||||
| APIAddMember GroupId ContactId GroupMemberRole
|
||||
| APIJoinGroup {groupId :: GroupId, enableNtfs :: MsgFilter}
|
||||
| APIAcceptMember GroupId GroupMemberId GroupMemberRole
|
||||
| APIMembersRole GroupId (NonEmpty GroupMemberId) GroupMemberRole
|
||||
| APIBlockMembersForAll GroupId (NonEmpty GroupMemberId) Bool
|
||||
| APIRemoveMembers GroupId (NonEmpty GroupMemberId)
|
||||
@@ -906,6 +897,17 @@ logResponseToFile = \case
|
||||
CRMessageError {} -> True
|
||||
_ -> False
|
||||
|
||||
-- (Maybe GroupMemberId) can later be changed to GroupSndScope = GSSAll | GSSAdmins | GSSMember GroupMemberId
|
||||
data SendRef
|
||||
= SRDirect ContactId
|
||||
| SRGroup GroupId (Maybe GroupMemberId)
|
||||
deriving (Eq, Show)
|
||||
|
||||
sendToChatRef :: SendRef -> ChatRef
|
||||
sendToChatRef = \case
|
||||
SRDirect cId -> ChatRef CTDirect cId
|
||||
SRGroup gId _ -> ChatRef CTGroup gId
|
||||
|
||||
data ChatPagination
|
||||
= CPLast Int
|
||||
| CPAfter ChatItemId Int
|
||||
@@ -1509,7 +1511,9 @@ toView = lift . toView'
|
||||
toView' :: ChatResponse -> CM' ()
|
||||
toView' ev = do
|
||||
cc@ChatController {outputQ = localQ, remoteCtrlSession = session, config = ChatConfig {chatHooks}} <- ask
|
||||
event <- liftIO $ eventHook chatHooks cc ev
|
||||
event <- case eventHook chatHooks of
|
||||
Just hook -> liftIO $ hook cc ev
|
||||
Nothing -> pure ev
|
||||
atomically $
|
||||
readTVar session >>= \case
|
||||
Just (_, RCSessionConnected {remoteOutputQ})
|
||||
@@ -1544,7 +1548,7 @@ withStoreBatch actions = do
|
||||
liftIO $ withTransaction chatStore $ mapM (`E.catches` handleDBErrors) . actions
|
||||
|
||||
-- TODO [postgres] postgres specific error handling
|
||||
handleDBErrors :: [E.Handler IO (Either ChatError a)]
|
||||
handleDBErrors :: [E.Handler (Either ChatError a)]
|
||||
handleDBErrors =
|
||||
#if !defined(dbPostgres)
|
||||
( E.Handler $ \(e :: SQLError) ->
|
||||
|
||||
@@ -277,7 +277,9 @@ execChatCommand rh s = do
|
||||
| otherwise -> pure $ CRChatCmdError u $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand
|
||||
_ -> do
|
||||
cc@ChatController {config = ChatConfig {chatHooks}} <- ask
|
||||
liftIO (preCmdHook chatHooks cc cmd) >>= either pure (execChatCommand_ u)
|
||||
case preCmdHook chatHooks of
|
||||
Just hook -> liftIO (hook cc cmd) >>= either pure (execChatCommand_ u)
|
||||
Nothing -> execChatCommand_ u cmd
|
||||
|
||||
execChatCommand' :: ChatCommand -> CM' ChatResponse
|
||||
execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)
|
||||
@@ -536,20 +538,17 @@ processChatCommand' vr = \case
|
||||
Just (CIFFGroup _ _ (Just gId) (Just fwdItemId)) ->
|
||||
Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId)
|
||||
_ -> pure Nothing
|
||||
APISendMessages (ChatRef cType chatId) live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case cType of
|
||||
CTDirect -> do
|
||||
APISendMessages sendRef live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case sendRef of
|
||||
SRDirect chatId -> do
|
||||
mapM_ assertNoMentions cms
|
||||
withContactLock "sendMessage" chatId $
|
||||
sendContactContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
|
||||
CTGroup ->
|
||||
SRGroup chatId directMemId_ ->
|
||||
withGroupLock "sendMessage" chatId $ do
|
||||
(gInfo, cmrs) <- withFastStore $ \db -> do
|
||||
g <- getGroupInfo db vr user chatId
|
||||
(g,) <$> mapM (composedMessageReqMentions db user g) cms
|
||||
sendGroupContentMessages user gInfo live itemTTL cmrs
|
||||
CTLocal -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
sendGroupContentMessages user gInfo directMemId_ live itemTTL cmrs
|
||||
APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do
|
||||
_ <- createChatTag db user emoji text
|
||||
CRChatTags user <$> getUserChatTags db user
|
||||
@@ -583,7 +582,8 @@ processChatCommand' vr = \case
|
||||
mc = MCReport reportText reportReason
|
||||
cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc, mentions = M.empty}
|
||||
when (null ms') $ throwChatError $ CECommandError "no moderators support receiving reports"
|
||||
sendGroupContentMessages_ user gInfo ms' False Nothing [composedMessageReq cm]
|
||||
let numFileInvs = length $ filter memberCurrent ms'
|
||||
sendGroupContentMessages_ user gInfo Nothing ms' numFileInvs False Nothing [composedMessageReq cm]
|
||||
where
|
||||
compatibleModerator GroupMember {activeConn, memberChatVRange} =
|
||||
maxVersion (maybe memberChatVRange peerChatVRange activeConn) >= contentReportsVersion
|
||||
@@ -633,6 +633,7 @@ processChatCommand' vr = \case
|
||||
then do
|
||||
ciMentions <- withFastStore $ \db -> getCIMentions db user gInfo ft_ mentions
|
||||
let mentions' = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions
|
||||
-- TODO [knocking] send separately to pending approval member
|
||||
SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
|
||||
ci' <- withFastStore' $ \db -> do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
@@ -687,6 +688,7 @@ processChatCommand' vr = \case
|
||||
assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier
|
||||
let msgIds = itemsMsgIds items
|
||||
events = L.nonEmpty $ map (`XMsgDel` Nothing) msgIds
|
||||
-- TODO [knocking] validate: only current members or only single pending approval member
|
||||
mapM_ (sendGroupMessages user gInfo ms) events
|
||||
delGroupChatItems user gInfo items False
|
||||
CTLocal -> do
|
||||
@@ -764,6 +766,7 @@ processChatCommand' vr = \case
|
||||
let GroupMember {memberId = itemMemberId} = chatItemMember g ci
|
||||
rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True
|
||||
checkReactionAllowed rs
|
||||
-- TODO [knocking] send separately to pending approval member
|
||||
SndMessage {msgId} <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add)
|
||||
createdAt <- liftIO getCurrentTime
|
||||
reactions <- withFastStore' $ \db -> do
|
||||
@@ -847,7 +850,7 @@ processChatCommand' vr = \case
|
||||
Just cmrs' ->
|
||||
withGroupLock "forwardChatItem, to group" toChatId $ do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db vr user toChatId
|
||||
sendGroupContentMessages user gInfo False itemTTL cmrs'
|
||||
sendGroupContentMessages user gInfo Nothing False itemTTL cmrs'
|
||||
Nothing -> pure $ CRNewChatItems user []
|
||||
CTLocal -> do
|
||||
cmrs <- prepareForward user
|
||||
@@ -1084,6 +1087,7 @@ processChatCommand' vr = \case
|
||||
cancelFilesInProgress user filesInfo
|
||||
deleteFilesLocally filesInfo
|
||||
let doSendDel = memberActive membership && isOwner
|
||||
-- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites)
|
||||
when doSendDel . void $ sendGroupMessage' user gInfo members XGrpDel
|
||||
deleteGroupLinkIfExists user gInfo
|
||||
deleteMembersConnections' user members doSendDel
|
||||
@@ -1127,7 +1131,7 @@ processChatCommand' vr = \case
|
||||
(user@User {userId}, cReq) <- withFastStore $ \db -> getContactRequest' db connReqId
|
||||
(ct, conn@Connection {connId}, sqSecured) <- acceptContactRequest user cReq incognito
|
||||
ucl <- withFastStore $ \db -> getUserContactLinkById db userId userContactLinkId
|
||||
let contactUsed = (\(_, groupId_, _) -> isNothing groupId_) ucl
|
||||
let contactUsed = (\(_, gLinkInfo_) -> isNothing gLinkInfo_) ucl
|
||||
ct' <- withStore' $ \db -> do
|
||||
deleteContactRequestRec db user cReq
|
||||
updateContactAccepted db user ct contactUsed
|
||||
@@ -1838,8 +1842,8 @@ processChatCommand' vr = \case
|
||||
CTDirect ->
|
||||
withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case
|
||||
Right ctId -> do
|
||||
let chatRef = ChatRef CTDirect ctId
|
||||
processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc]
|
||||
let sendRef = SRDirect ctId
|
||||
processChatCommand $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
Left _ ->
|
||||
withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
|
||||
Right [(gInfo, member)] -> do
|
||||
@@ -1854,8 +1858,8 @@ processChatCommand' vr = \case
|
||||
(gId, mentions) <- withFastStore $ \db -> do
|
||||
gId <- getGroupIdByName db user name
|
||||
(gId,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let chatRef = ChatRef CTGroup gId
|
||||
processChatCommand $ APISendMessages chatRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
let sendRef = SRGroup gId Nothing
|
||||
processChatCommand $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
CTLocal
|
||||
| name == "" -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
@@ -1877,12 +1881,13 @@ processChatCommand' vr = \case
|
||||
processChatCommand $ APISendMemberContactInvitation contactId (Just mc)
|
||||
cr -> pure cr
|
||||
Just ctId -> do
|
||||
let chatRef = ChatRef CTDirect ctId
|
||||
processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc]
|
||||
let sendRef = SRDirect ctId
|
||||
processChatCommand $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
SendLiveMessage chatName msg -> withUser $ \user -> do
|
||||
(chatRef, mentions) <- getChatRefAndMentions user chatName msg
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APISendMessages chatRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
withSendRef chatRef $ \sendRef -> do
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APISendMessages sendRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
SendMessageBroadcast msg -> withUser $ \user -> do
|
||||
contacts <- withFastStore' $ \db -> getUserContacts db vr user
|
||||
withChatLock "sendMessageBroadcast" . procCmd $ do
|
||||
@@ -1922,12 +1927,12 @@ processChatCommand' vr = \case
|
||||
combineResults _ _ (Left e) = Left e
|
||||
createCI :: DB.Connection -> User -> UTCTime -> (Contact, SndMessage) -> IO ()
|
||||
createCI db user createdAt (ct, sndMsg) =
|
||||
void $ createNewSndChatItem db user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False createdAt
|
||||
void $ createNewSndChatItem db user (CDDirectSnd ct) Nothing sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False createdAt
|
||||
SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do
|
||||
contactId <- withFastStore $ \db -> getContactIdByName db user cName
|
||||
quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
|
||||
processChatCommand $ APISendMessages (SRDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
|
||||
DeleteMessage chatName deletedMsg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg
|
||||
@@ -2023,14 +2028,27 @@ 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
|
||||
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
|
||||
APIMembersRole groupId memberIds newRole -> withUser $ \user ->
|
||||
withGroupLock "memberRole" groupId . procCmd $ do
|
||||
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
when (selfSelected gInfo) $ throwChatError $ CECommandError "can't change role for self"
|
||||
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin) = selectMembers members
|
||||
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members
|
||||
when (length invitedMems + length currentMems + length unchangedMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
|
||||
when (length memberIds > 1 && (anyAdmin || newRole >= GRAdmin)) $
|
||||
throwChatError $ CECommandError "can't change role of multiple members when admins selected, or new role is admin"
|
||||
when anyPending $ throwChatError $ CECommandError "can't change role of members pending approval"
|
||||
assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole])
|
||||
(errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems
|
||||
(errs2, changed2, acis) <- changeRoleCurrentMems user g currentMems
|
||||
@@ -2040,19 +2058,20 @@ processChatCommand' vr = \case
|
||||
pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole} -- same order is not guaranteed
|
||||
where
|
||||
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
|
||||
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool)
|
||||
selectMembers = foldr' addMember ([], [], [], GRObserver, False)
|
||||
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
|
||||
selectMembers = foldr' addMember ([], [], [], GRObserver, False, False)
|
||||
where
|
||||
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin)
|
||||
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, unchanged, maxRole, anyAdmin, anyPending)
|
||||
| groupMemberId `elem` memberIds =
|
||||
let maxRole' = max maxRole memberRole
|
||||
anyAdmin' = anyAdmin || memberRole >= GRAdmin
|
||||
anyPending' = anyPending || memberStatus == GSMemPendingApproval
|
||||
in
|
||||
if
|
||||
| memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin')
|
||||
| memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin')
|
||||
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin')
|
||||
| otherwise = (invited, current, unchanged, maxRole, anyAdmin)
|
||||
| memberRole == newRole -> (invited, current, m : unchanged, maxRole', anyAdmin', anyPending')
|
||||
| memberStatus == GSMemInvited -> (m : invited, current, unchanged, maxRole', anyAdmin', anyPending')
|
||||
| otherwise -> (invited, m : current, unchanged, maxRole', anyAdmin', anyPending')
|
||||
| otherwise = (invited, current, unchanged, maxRole, anyAdmin, anyPending)
|
||||
changeRoleInvitedMems :: User -> GroupInfo -> [GroupMember] -> CM ([ChatError], [GroupMember])
|
||||
changeRoleInvitedMems user gInfo memsToChange = do
|
||||
-- not batched, as we need to send different invitations to different connections anyway
|
||||
@@ -2074,7 +2093,7 @@ processChatCommand' vr = \case
|
||||
let events = L.map (\GroupMember {memberId} -> XGrpMemRole memberId newRole) memsToChange'
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo members events
|
||||
let itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData Nothing False
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) Nothing itemsData Nothing False
|
||||
when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch"
|
||||
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
|
||||
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) $ rights cis_
|
||||
@@ -2084,7 +2103,7 @@ processChatCommand' vr = \case
|
||||
sndItemData GroupMember {groupMemberId, memberProfile} msg =
|
||||
let content = CISndGroupEvent $ SGEMemberRole groupMemberId (fromLocalProfile memberProfile) newRole
|
||||
ts = ciContentTexts content
|
||||
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
|
||||
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
|
||||
updMember db m = do
|
||||
updateGroupMemberRole db user m newRole
|
||||
pure (m :: GroupMember) {memberRole = newRole}
|
||||
@@ -2092,22 +2111,24 @@ processChatCommand' vr = \case
|
||||
withGroupLock "blockForAll" groupId . procCmd $ do
|
||||
Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
when (selfSelected gInfo) $ throwChatError $ CECommandError "can't block/unblock self"
|
||||
let (blockMems, remainingMems, maxRole, anyAdmin) = selectMembers members
|
||||
let (blockMems, remainingMems, maxRole, anyAdmin, anyPending) = selectMembers members
|
||||
when (length blockMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
|
||||
when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't block/unblock multiple members when admins selected"
|
||||
when anyPending $ throwChatError $ CECommandError "can't block/unblock members pending approval"
|
||||
assertUserGroupRole gInfo $ max GRModerator maxRole
|
||||
blockMembers user gInfo blockMems remainingMems
|
||||
where
|
||||
selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds
|
||||
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool)
|
||||
selectMembers = foldr' addMember ([], [], GRObserver, False)
|
||||
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool, Bool)
|
||||
selectMembers = foldr' addMember ([], [], GRObserver, False, False)
|
||||
where
|
||||
addMember m@GroupMember {groupMemberId, memberRole} (block, remaining, maxRole, anyAdmin)
|
||||
addMember m@GroupMember {groupMemberId, memberRole, memberStatus} (block, remaining, maxRole, anyAdmin, anyPending)
|
||||
| groupMemberId `elem` memberIds =
|
||||
let maxRole' = max maxRole memberRole
|
||||
anyAdmin' = anyAdmin || memberRole >= GRAdmin
|
||||
in (m : block, remaining, maxRole', anyAdmin')
|
||||
| otherwise = (block, m : remaining, maxRole, anyAdmin)
|
||||
anyPending' = anyPending || memberStatus == GSMemPendingApproval
|
||||
in (m : block, remaining, maxRole', anyAdmin', anyPending')
|
||||
| otherwise = (block, m : remaining, maxRole, anyAdmin, anyPending)
|
||||
blockMembers :: User -> GroupInfo -> [GroupMember] -> [GroupMember] -> CM ChatResponse
|
||||
blockMembers user gInfo blockMems remainingMems = case L.nonEmpty blockMems of
|
||||
Nothing -> throwChatError $ CECommandError "no members to block/unblock"
|
||||
@@ -2116,7 +2137,7 @@ processChatCommand' vr = \case
|
||||
events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId MemberRestrictions {restriction = mrs}) blockMems'
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo remainingMems events
|
||||
let itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData Nothing False
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) Nothing itemsData Nothing False
|
||||
when (length cis_ /= length blockMems) $ logError "blockMembers: blockMems and cis_ length mismatch"
|
||||
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo)) $ rights cis_
|
||||
unless (null acis) $ toView $ CRNewChatItems user acis
|
||||
@@ -2130,33 +2151,37 @@ processChatCommand' vr = \case
|
||||
sndItemData GroupMember {groupMemberId, memberProfile} msg =
|
||||
let content = CISndGroupEvent $ SGEMemberBlocked groupMemberId (fromLocalProfile memberProfile) blockFlag
|
||||
ts = ciContentTexts content
|
||||
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
|
||||
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
|
||||
APIRemoveMembers groupId memberIds -> withUser $ \user ->
|
||||
withGroupLock "removeMembers" groupId . procCmd $ do
|
||||
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
let (invitedMems, currentMems, maxRole, anyAdmin) = selectMembers members
|
||||
when (length invitedMems + length currentMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
|
||||
Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
let (invitedMems, pendingMems, currentMems, maxRole, anyAdmin) = selectMembers members
|
||||
when (length invitedMems + length pendingMems + length currentMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
|
||||
when (length memberIds > 1 && anyAdmin) $ throwChatError $ CECommandError "can't remove multiple members when admins selected"
|
||||
assertUserGroupRole gInfo $ max GRAdmin maxRole
|
||||
(errs1, deleted1) <- deleteInvitedMems user invitedMems
|
||||
(errs2, deleted2, acis) <- deleteCurrentMems user g currentMems
|
||||
(errs2, deleted2, acis2) <- deleteMemsSend user gInfo members currentMems
|
||||
rs <- forM pendingMems $ \m -> deleteMemsSend user gInfo [m] [m]
|
||||
let (errs3, deleted3, acis3) = concatTuples rs
|
||||
acis = acis2 <> acis3
|
||||
errs = errs1 <> errs2 <> errs3
|
||||
unless (null acis) $ toView $ CRNewChatItems user acis
|
||||
let errs = errs1 <> errs2
|
||||
unless (null errs) $ toView $ CRChatErrors (Just user) errs
|
||||
pure $ CRUserDeletedMembers user gInfo (deleted1 <> deleted2) -- same order is not guaranteed
|
||||
pure $ CRUserDeletedMembers user gInfo (deleted1 <> deleted2 <> deleted3) -- same order is not guaranteed
|
||||
where
|
||||
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], GroupMemberRole, Bool)
|
||||
selectMembers = foldr' addMember ([], [], GRObserver, False)
|
||||
selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool)
|
||||
selectMembers = foldr' addMember ([], [], [], GRObserver, False)
|
||||
where
|
||||
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, current, maxRole, anyAdmin)
|
||||
addMember m@GroupMember {groupMemberId, memberStatus, memberRole} (invited, pending, current, maxRole, anyAdmin)
|
||||
| groupMemberId `elem` memberIds =
|
||||
let maxRole' = max maxRole memberRole
|
||||
anyAdmin' = anyAdmin || memberRole >= GRAdmin
|
||||
in
|
||||
if memberStatus == GSMemInvited
|
||||
then (m : invited, current, maxRole', anyAdmin')
|
||||
else (invited, m : current, maxRole', anyAdmin')
|
||||
| otherwise = (invited, current, maxRole, anyAdmin)
|
||||
case memberStatus of
|
||||
GSMemInvited -> (m : invited, pending, current, maxRole', anyAdmin')
|
||||
GSMemPendingApproval -> (invited, m : pending, current, maxRole', anyAdmin')
|
||||
_ -> (invited, pending, m : current, maxRole', anyAdmin')
|
||||
| otherwise = (invited, pending, current, maxRole, anyAdmin)
|
||||
deleteInvitedMems :: User -> [GroupMember] -> CM ([ChatError], [GroupMember])
|
||||
deleteInvitedMems user memsToDelete = do
|
||||
deleteMembersConnections user memsToDelete
|
||||
@@ -2165,14 +2190,14 @@ processChatCommand' vr = \case
|
||||
delMember db m = do
|
||||
deleteGroupMember db user m
|
||||
pure m {memberStatus = GSMemRemoved}
|
||||
deleteCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem])
|
||||
deleteCurrentMems user (Group gInfo members) memsToDelete = case L.nonEmpty memsToDelete of
|
||||
deleteMemsSend :: User -> GroupInfo -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem])
|
||||
deleteMemsSend user gInfo sendToMems memsToDelete = case L.nonEmpty memsToDelete of
|
||||
Nothing -> pure ([], [], [])
|
||||
Just memsToDelete' -> do
|
||||
let events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId) memsToDelete'
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo members events
|
||||
(msgs_, _gsr) <- sendGroupMessages user gInfo sendToMems events
|
||||
let itemsData = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData Nothing False
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) Nothing itemsData Nothing False
|
||||
when (length cis_ /= length memsToDelete) $ logError "deleteCurrentMems: memsToDelete and cis_ length mismatch"
|
||||
deleteMembersConnections' user memsToDelete True
|
||||
(errs, deleted) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (delMember db) memsToDelete)
|
||||
@@ -2183,15 +2208,19 @@ processChatCommand' vr = \case
|
||||
sndItemData GroupMember {groupMemberId, memberProfile} msg =
|
||||
let content = CISndGroupEvent $ SGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)
|
||||
ts = ciContentTexts content
|
||||
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
|
||||
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
|
||||
delMember db m = do
|
||||
deleteOrUpdateMemberRecordIO db user m
|
||||
pure m {memberStatus = GSMemRemoved}
|
||||
concatTuples :: [([a], [b], [c])] -> ([a], [b], [c])
|
||||
concatTuples xs = (concat as, concat bs, concat cs)
|
||||
where (as, bs, cs) = unzip3 xs
|
||||
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do
|
||||
Group gInfo@GroupInfo {membership} members <- withFastStore $ \db -> getGroup db vr user groupId
|
||||
filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
|
||||
withGroupLock "leaveGroup" groupId . procCmd $ do
|
||||
cancelFilesInProgress user filesInfo
|
||||
-- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites)
|
||||
msg <- sendGroupMessage' user gInfo members XGrpLeave
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft)
|
||||
toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci]
|
||||
@@ -2320,7 +2349,7 @@ processChatCommand' vr = \case
|
||||
qiId <- getGroupChatItemIdByText db user gId cName quotedMsg
|
||||
(gId, qiId,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
|
||||
processChatCommand $ APISendMessages (SRGroup groupId Nothing) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
|
||||
ClearNoteFolder -> withUser $ \user -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
processChatCommand $ APIClearChat (ChatRef CTLocal folderId)
|
||||
@@ -2361,15 +2390,16 @@ processChatCommand' vr = \case
|
||||
chatRef <- getChatRef user chatName
|
||||
case chatRef of
|
||||
ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")]
|
||||
_ -> processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCFile "")]
|
||||
_ -> withSendRef chatRef $ \sendRef -> processChatCommand $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")]
|
||||
SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
filePath <- lift $ toFSFilePath fPath
|
||||
unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath}
|
||||
fileSize <- getFileSize filePath
|
||||
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
|
||||
-- TODO include file description for preview
|
||||
processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)]
|
||||
withSendRef chatRef $ \sendRef -> do
|
||||
filePath <- lift $ toFSFilePath fPath
|
||||
unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath}
|
||||
fileSize <- getFileSize filePath
|
||||
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
|
||||
-- TODO include file description for preview
|
||||
processChatCommand $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)]
|
||||
ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
|
||||
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
|
||||
SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
|
||||
@@ -2403,6 +2433,7 @@ processChatCommand' vr = \case
|
||||
void . sendDirectContactMessage user contact $ XFileCancel sharedMsgId
|
||||
Just (ChatRef CTGroup groupId) -> do
|
||||
(Group gInfo ms, sharedMsgId) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getSharedMsgIdByFileId db userId fileId
|
||||
-- TODO [knocking] send separately to pending approval member
|
||||
void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId
|
||||
Just _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
|
||||
ci <- withFastStore $ \db -> lookupChatItemByFileId db vr user fileId
|
||||
@@ -2795,6 +2826,7 @@ processChatCommand' vr = \case
|
||||
GroupMember {memberProfile = LocalProfile {displayName, fullName, image}} <-
|
||||
withStore $ \db -> getGroupMemberByMemberId db vr user g businessId
|
||||
let p'' = p' {displayName, fullName, image} :: GroupProfile
|
||||
-- TODO [knocking] send to pending approval members (move `memberCurrent` filter from sendGroupMessages_ to call sites)
|
||||
void $ sendGroupMessage user g' oldMs (XGrpInfo p'')
|
||||
let ps' = fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
|
||||
sendGroupMessage user g' newMs $ XGrpPrefs ps'
|
||||
@@ -2823,6 +2855,8 @@ processChatCommand' vr = \case
|
||||
assertUserGroupRole gInfo GRAdmin -- TODO GRModerator when most users migrate
|
||||
let msgMemIds = itemsMsgMemIds gInfo items
|
||||
events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId)) msgMemIds
|
||||
-- TODO [knocking] validate: only current members or only single pending approval member,
|
||||
-- TODO or prohibit pending approval members (only moderation and reports use this)
|
||||
mapM_ (sendGroupMessages user gInfo ms) events
|
||||
delGroupChatItems user gInfo items True
|
||||
where
|
||||
@@ -3115,7 +3149,7 @@ processChatCommand' vr = \case
|
||||
msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers
|
||||
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) msgs_
|
||||
when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch"
|
||||
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live
|
||||
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) Nothing itemsData timed_ live
|
||||
processSendErrs user r
|
||||
forM_ (timed_ >>= timedDeleteAt') $ \deleteAt ->
|
||||
forM_ cis $ \ci ->
|
||||
@@ -3151,14 +3185,26 @@ processChatCommand' vr = \case
|
||||
quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
|
||||
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
|
||||
quoteData _ = throwError SEInvalidQuote
|
||||
sendGroupContentMessages :: User -> GroupInfo -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages user gInfo live itemTTL cmrs = do
|
||||
sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupMemberId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages user gInfo@GroupInfo {membership} directMemId_ live itemTTL cmrs = do
|
||||
assertMultiSendable live cmrs
|
||||
ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
|
||||
sendGroupContentMessages_ user gInfo ms live itemTTL cmrs
|
||||
sendGroupContentMessages_ :: User -> GroupInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} ms live itemTTL cmrs = do
|
||||
assertUserGroupRole gInfo GRAuthor
|
||||
(ms, numFileInvs, notInHistory_) <- case directMemId_ of
|
||||
Nothing -> do
|
||||
ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
|
||||
pure (ms, length $ filter memberCurrent ms, Nothing)
|
||||
Just dmId -> do
|
||||
when (dmId == groupMemberId' membership) $ throwChatError $ CECommandError "cannot send to self"
|
||||
dm <- withFastStore $ \db -> getGroupMemberById db vr user dmId
|
||||
unless (memberStatus dm == GSMemPendingApproval) $ throwChatError $ CECommandError "cannot send directly to member not pending approval"
|
||||
pure ([dm], 1, Just NotInHistory)
|
||||
sendGroupContentMessages_ user gInfo notInHistory_ ms numFileInvs live itemTTL cmrs
|
||||
sendGroupContentMessages_ :: User -> GroupInfo -> Maybe NotInHistory -> [GroupMember] -> Int -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
|
||||
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} notInHistory_ ms numFileInvs live itemTTL cmrs = do
|
||||
-- TODO [knocking] pass GroupSndScope?
|
||||
let allowedRole = case ms of
|
||||
[m] | memberCategory m == GCHostMember && memberStatus membership == GSMemPendingApproval -> Nothing
|
||||
_ -> Just GRAuthor
|
||||
forM_ allowedRole $ assertUserGroupRole gInfo
|
||||
assertGroupContentAllowed
|
||||
processComposedMessages
|
||||
where
|
||||
@@ -3175,12 +3221,12 @@ processChatCommand' vr = \case
|
||||
Nothing
|
||||
processComposedMessages :: CM ChatResponse
|
||||
processComposedMessages = do
|
||||
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length $ filter memberCurrent ms)
|
||||
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers numFileInvs
|
||||
timed_ <- sndGroupCITimed live gInfo itemTTL
|
||||
(chatMsgEvents, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_
|
||||
(msgs_, gsr) <- sendGroupMessages user gInfo ms chatMsgEvents
|
||||
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) itemsData timed_ live
|
||||
cis_ <- saveSndChatItems user (CDGroupSnd gInfo) notInHistory_ itemsData timed_ live
|
||||
when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
|
||||
createMemberSndStatuses cis_ msgs_ gsr
|
||||
let r@(_, cis) = partitionEithers cis_
|
||||
@@ -3351,6 +3397,11 @@ processChatCommand' vr = \case
|
||||
getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do
|
||||
msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId)
|
||||
CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId)
|
||||
withSendRef :: ChatRef -> (SendRef -> CM ChatResponse) -> CM ChatResponse
|
||||
withSendRef chatRef a = case chatRef of
|
||||
ChatRef CTDirect cId -> a $ SRDirect cId
|
||||
ChatRef CTGroup gId -> a $ SRGroup gId Nothing
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
|
||||
protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
|
||||
protocolServers p (operators, smpServers, xftpServers) = case p of
|
||||
@@ -3833,7 +3884,7 @@ chatCommandP =
|
||||
"/_get chat " *> (APIGetChat <$> chatRefP <*> optional (" content=" *> strP) <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)),
|
||||
"/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)),
|
||||
"/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal),
|
||||
"/_send " *> (APISendMessages <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
|
||||
"/_send " *> (APISendMessages <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
|
||||
"/_create tag " *> (APICreateChatTag <$> jsonP),
|
||||
"/_tags " *> (APISetChatTags <$> chatRefP <*> optional _strP),
|
||||
"/_delete tag " *> (APIDeleteChatTag <$> A.decimal),
|
||||
@@ -3886,6 +3937,7 @@ chatCommandP =
|
||||
"/_ntf conn messages " *> (ApiGetConnNtfMessages <$> strP),
|
||||
"/_add #" *> (APIAddMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole),
|
||||
"/_join #" *> (APIJoinGroup <$> A.decimal <*> pure MFAll), -- needs to be changed to support in UI
|
||||
"/_accept member #" *> (APIAcceptMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole),
|
||||
"/_member role #" *> (APIMembersRole <$> A.decimal <*> _strP <*> memberRole),
|
||||
"/_block #" *> (APIBlockMembersForAll <$> A.decimal <*> _strP <* A.space <* "blocked=" <*> onOffP),
|
||||
"/_remove #" *> (APIRemoveMembers <$> A.decimal <*> _strP),
|
||||
@@ -4206,6 +4258,9 @@ chatCommandP =
|
||||
ct -> ChatName ct <$> displayNameP
|
||||
chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayNameP
|
||||
chatRefP = ChatRef <$> chatTypeP <*> A.decimal
|
||||
sendRefP =
|
||||
(A.char '@' $> SRDirect <*> A.decimal)
|
||||
<|> (A.char '#' $> SRGroup <*> A.decimal <*> optional (" @" *> A.decimal))
|
||||
msgCountP = A.space *> A.decimal <|> pure 10
|
||||
ciTTLDecimal = ("default" $> Nothing) <|> (Just <$> A.decimal)
|
||||
ciTTL =
|
||||
|
||||
@@ -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 (..))
|
||||
@@ -820,17 +820,19 @@ acceptContactRequestAsync user cReq@UserContactRequest {agentInvitationId = Agen
|
||||
setCommandConnId db user cmdId connId
|
||||
pure ct
|
||||
|
||||
acceptGroupJoinRequestAsync :: User -> GroupInfo -> UserContactRequest -> GroupMemberRole -> Maybe IncognitoProfile -> CM GroupMember
|
||||
acceptGroupJoinRequestAsync :: User -> GroupInfo -> UserContactRequest -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> CM GroupMember
|
||||
acceptGroupJoinRequestAsync
|
||||
user
|
||||
gInfo@GroupInfo {groupProfile, membership, businessChat}
|
||||
ucr@UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange}
|
||||
gAccepted
|
||||
gLinkMemRole
|
||||
incognitoProfile = do
|
||||
gVar <- asks random
|
||||
let initialStatus = acceptanceToStatus gAccepted
|
||||
(groupMemberId, memberId) <- withStore $ \db -> do
|
||||
liftIO $ deleteContactRequestRec db user ucr
|
||||
createJoiningMember db gVar user gInfo ucr gLinkMemRole GSMemAccepted
|
||||
createJoiningMember db gVar user gInfo ucr gLinkMemRole initialStatus
|
||||
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
|
||||
let Profile {displayName} = profileToSendOnAccept user incognitoProfile True
|
||||
GroupMember {memberRole = userRole, memberId = userMemberId} = membership
|
||||
@@ -841,6 +843,7 @@ acceptGroupJoinRequestAsync
|
||||
fromMemberName = displayName,
|
||||
invitedMember = MemberIdRole memberId gLinkMemRole,
|
||||
groupProfile,
|
||||
accepted = Just gAccepted,
|
||||
business = businessChat,
|
||||
groupSize = Just currentMemCount
|
||||
}
|
||||
@@ -900,6 +903,7 @@ acceptBusinessJoinRequestAsync
|
||||
fromMemberName = displayName,
|
||||
invitedMember = MemberIdRole memberId GRMember,
|
||||
groupProfile = businessGroupProfile userProfile groupPreferences,
|
||||
accepted = Just GAAccepted,
|
||||
-- This refers to the "title member" that defines the group name and profile.
|
||||
-- This coincides with fromMember to be current user when accepting the connecting user,
|
||||
-- but it will be different when inviting somebody else.
|
||||
@@ -926,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
|
||||
@@ -1459,6 +1589,7 @@ sendGroupMessage' user gInfo members chatMsgEvent =
|
||||
|
||||
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
|
||||
sendGroupMessages user gInfo members events = do
|
||||
-- TODO [knocking] when sending to all, send profile update to pending approval members too, then filter for next step?
|
||||
when shouldSendProfileUpdate $
|
||||
sendProfileUpdate `catchChatError` (toView . CRChatError (Just user))
|
||||
sendGroupMessages_ user gInfo members events
|
||||
@@ -1489,7 +1620,10 @@ sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> No
|
||||
sendGroupMessages_ _user gInfo@GroupInfo {groupId} members events = do
|
||||
let idsEvts = L.map (GroupId groupId,) events
|
||||
sndMsgs_ <- lift $ createSndMessages idsEvts
|
||||
recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members)
|
||||
-- TODO [knocking] Possibly we need to pass GroupSndScope through all functions to here to avoid ad-hoc filtering.
|
||||
recipientMembers <- case members of
|
||||
[m] | memberStatus m == GSMemPendingApproval -> pure [m]
|
||||
_ -> liftIO $ shuffleMembers (filter memberCurrent members)
|
||||
let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events}
|
||||
(toSendSeparate, toSendBatched, toPending, forwarded, _, dups) =
|
||||
foldr' addMember ([], [], [], [], S.empty, 0 :: Int) recipientMembers
|
||||
@@ -1691,7 +1825,7 @@ saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothi
|
||||
saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd)
|
||||
saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = do
|
||||
let itemTexts = ciContentTexts content
|
||||
saveSndChatItems user cd [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case
|
||||
saveSndChatItems user cd Nothing [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case
|
||||
[Right ci] -> pure ci
|
||||
_ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item"
|
||||
|
||||
@@ -1710,11 +1844,12 @@ saveSndChatItems ::
|
||||
ChatTypeI c =>
|
||||
User ->
|
||||
ChatDirection c 'MDSnd ->
|
||||
Maybe NotInHistory ->
|
||||
[Either ChatError (NewSndChatItemData c)] ->
|
||||
Maybe CITimed ->
|
||||
Bool ->
|
||||
CM [Either ChatError (ChatItem c 'MDSnd)]
|
||||
saveSndChatItems user cd itemsData itemTimed live = do
|
||||
saveSndChatItems user cd notInHistory_ itemsData itemTimed live = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $
|
||||
withStore' (\db -> updateChatTs db user cd createdAt)
|
||||
@@ -1722,7 +1857,7 @@ saveSndChatItems user cd itemsData itemTimed live = do
|
||||
where
|
||||
createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd))
|
||||
createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do
|
||||
ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt
|
||||
ciId <- createNewSndChatItem db user cd notInHistory_ msg content quotedItem itemForwarded itemTimed live createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
let ci = mkChatItem_ cd ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False createdAt Nothing createdAt
|
||||
Right <$> case cd of
|
||||
@@ -1734,13 +1869,13 @@ saveRcvChatItemNoParse user cd msg brokerTs = saveRcvChatItem user cd msg broker
|
||||
|
||||
saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> CM (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content =
|
||||
saveRcvChatItem' user cd msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
|
||||
saveRcvChatItem' user cd Nothing msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
|
||||
|
||||
ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe MarkdownList))
|
||||
ciContentNoParse content = (content, (ciContentToText content, Nothing))
|
||||
|
||||
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
|
||||
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> Maybe NotInHistory -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem' user cd notInHistory_ msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
withStore' $ \db -> do
|
||||
when (ciRequiresAttention content || contactChatDeleted cd) $ updateChatTs db user cd createdAt
|
||||
@@ -1753,7 +1888,7 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} shared
|
||||
userMention' = userReply || any (\CIMention {memberId} -> sameMemberId memberId membership) mentions'
|
||||
in pure (mentions', userMention')
|
||||
CDDirectRcv _ -> pure (M.empty, False)
|
||||
(ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention brokerTs createdAt
|
||||
(ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd notInHistory_ msg sharedMsgId_ content itemTimed live userMention brokerTs createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
let ci = mkChatItem_ cd ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention brokerTs forwardedByMember createdAt
|
||||
case cd of
|
||||
@@ -1999,7 +2134,7 @@ createLocalChatItems user cd itemsData createdAt = do
|
||||
where
|
||||
createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd)
|
||||
createItem db (content, ciFile, itemForwarded, ts) = do
|
||||
ciId <- createNewChatItem_ db user cd Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False createdAt Nothing createdAt
|
||||
ciId <- createNewChatItem_ db user cd Nothing Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False createdAt Nothing createdAt
|
||||
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
|
||||
pure $ mkChatItem_ cd ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False createdAt Nothing createdAt
|
||||
|
||||
|
||||
@@ -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)
|
||||
@@ -47,7 +46,7 @@ import Simplex.Chat.Library.Internal
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Messages.CIContent.Events
|
||||
import Simplex.Chat.ProfileGenerator (generateRandomProfile, isRandomName)
|
||||
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Connections
|
||||
@@ -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)
|
||||
@@ -592,14 +578,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
withStore' $ \db -> resetContactConnInitiated db user conn'
|
||||
forM_ viaUserContactLink $ \userContactLinkId -> do
|
||||
ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId
|
||||
let (UserContactLink {autoAccept}, groupId_, gLinkMemRole) = ucl
|
||||
let (UserContactLink {autoAccept}, gli_) = ucl
|
||||
when (connChatVersion < batchSend2Version) $ sendAutoReply ct' autoAccept
|
||||
forM_ groupId_ $ \groupId -> do
|
||||
-- TODO REMOVE LEGACY vvv
|
||||
forM_ gli_ $ \GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
|
||||
groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
|
||||
gVar <- asks random
|
||||
withStore $ \db -> createNewContactMemberAsync db gVar user groupInfo ct' gLinkMemRole groupConnIds connChatVersion peerChatVRange subMode
|
||||
-- TODO REMOVE LEGACY ^^^
|
||||
Just (gInfo, m@GroupMember {activeConn}) ->
|
||||
when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
|
||||
notifyMemberConnected gInfo m $ Just ct
|
||||
@@ -658,7 +646,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
toView $ CRContactSndReady user ct
|
||||
forM_ viaUserContactLink $ \userContactLinkId -> do
|
||||
ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId
|
||||
let (UserContactLink {autoAccept}, _, _) = ucl
|
||||
let (UserContactLink {autoAccept}, _) = ucl
|
||||
when (connChatVersion >= batchSend2Version) $ sendAutoReply ct autoAccept
|
||||
QCONT ->
|
||||
void $ continueSending connEntity conn
|
||||
@@ -703,6 +691,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
liftIO $ setConnConnReqInv db user connId cReq
|
||||
getHostConnId db user groupId
|
||||
sendXGrpMemInv hostConnId Nothing XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
|
||||
-- TODO REMOVE LEGACY vvv
|
||||
-- [async agent commands] group link auto-accept continuation on receiving INV
|
||||
CFCreateConnGrpInv -> do
|
||||
ct <- withStore $ \db -> getContactViaMember db vr user m
|
||||
@@ -728,6 +717,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(_msg, _) <- sendDirectContactMessage user ct $ XGrpInv groupInv
|
||||
-- we could link chat item with sent group invitation message (_msg)
|
||||
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
|
||||
-- TODO REMOVE LEGACY ^^^
|
||||
_ -> throwChatError $ CECommandError "unexpected cmdFunction"
|
||||
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
|
||||
CONF confId _pqSupport _ connInfo -> do
|
||||
@@ -765,7 +755,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
||||
-- sent when connecting via group link
|
||||
XInfo _ ->
|
||||
-- TODO [group rejection] Keep rejected member record and connection for ability to start dialogue.
|
||||
-- TODO Keep rejected member to allow them to appeal against rejection.
|
||||
when (memberStatus m == GSMemRejected) $ do
|
||||
deleteMemberConnection' user m True
|
||||
withStore' $ \db -> deleteGroupMember db user m
|
||||
@@ -773,16 +763,20 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
_ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok"
|
||||
pure ()
|
||||
CON _pqEnc -> unless (memberStatus m == GSMemRejected) $ do
|
||||
withStore' $ \db -> do
|
||||
updateGroupMemberStatus db userId m GSMemConnected
|
||||
unless (memberActive membership) $
|
||||
updateGroupMemberStatus db userId membership GSMemConnected
|
||||
-- possible improvement: check for each pending message, requires keeping track of connection state
|
||||
unless (connDisabled conn) $ sendPendingGroupMessages user m conn
|
||||
status' <- case memberStatus m of
|
||||
GSMemPendingApproval -> pure GSMemPendingApproval
|
||||
_ -> do
|
||||
withStore' $ \db -> do
|
||||
updateGroupMemberStatus db userId m GSMemConnected
|
||||
unless (memberActive membership) $
|
||||
updateGroupMemberStatus db userId membership GSMemConnected
|
||||
-- possible improvement: check for each pending message, requires keeping track of connection state
|
||||
unless (connDisabled conn) $ sendPendingGroupMessages user m conn
|
||||
pure GSMemConnected
|
||||
withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ chatHasNtfs chatSettings
|
||||
case memberCategory m of
|
||||
GCHostMember -> do
|
||||
toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected}
|
||||
toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = status'}} m {memberStatus = status'}
|
||||
let cd = CDGroupRcv gInfo m
|
||||
createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing
|
||||
createGroupFeatureItems user cd CIRcvGroupFeature gInfo
|
||||
@@ -793,125 +787,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
expectHistory = groupFeatureAllowed SGFHistory gInfo && m `supportsVersion` groupHistoryIncludeWelcomeVersion
|
||||
GCInviteeMember -> do
|
||||
memberConnectedChatItem gInfo m
|
||||
toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected}
|
||||
toView $ CRJoinedGroupMember user gInfo m {memberStatus = status'}
|
||||
let Connection {viaUserContactLink} = conn
|
||||
when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem
|
||||
members <- withStore' $ \db -> getGroupMembers db vr user gInfo
|
||||
void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
|
||||
sendIntroductions members
|
||||
when (groupFeatureAllowed SGFHistory gInfo) sendHistory
|
||||
when (connChatVersion < batchSend2Version) sendGroupAutoReply
|
||||
unless (status' == GSMemPendingApproval) $ introduceToGroup vr user gInfo m
|
||||
where
|
||||
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
|
||||
@@ -974,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
|
||||
@@ -1294,13 +1180,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
_ -> pure ()
|
||||
where
|
||||
profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> CM ()
|
||||
profileContactRequest invId chatVRange p@Profile {displayName, image} xContactId_ reqPQSup = do
|
||||
profileContactRequest invId chatVRange p@Profile {displayName} xContactId_ reqPQSup = do
|
||||
withStore (\db -> createOrUpdateContactRequest db vr user userContactLinkId invId chatVRange p xContactId_ reqPQSup) >>= \case
|
||||
CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact
|
||||
CORGroup gInfo -> toView $ CRBusinessRequestAlreadyAccepted user gInfo
|
||||
CORRequest cReq -> do
|
||||
ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId
|
||||
let (UserContactLink {connReqContact, autoAccept}, groupId_, gLinkMemRole) = ucl
|
||||
let (UserContactLink {connReqContact, autoAccept}, gLinkInfo_) = ucl
|
||||
isSimplexTeam = sameConnReqContact connReqContact adminContactReq
|
||||
v = maxVersion chatVRange
|
||||
case autoAccept of
|
||||
@@ -1313,49 +1199,37 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
else do
|
||||
gInfo <- acceptBusinessJoinRequestAsync user cReq
|
||||
toView $ CRAcceptingBusinessRequest user gInfo
|
||||
| otherwise -> case groupId_ of
|
||||
| otherwise -> case gLinkInfo_ of
|
||||
Nothing -> do
|
||||
-- [incognito] generate profile to send, create connection with incognito profile
|
||||
incognitoProfile <- if acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
|
||||
ct <- acceptContactRequestAsync user cReq incognitoProfile reqPQSup
|
||||
toView $ CRAcceptingContactRequest user ct
|
||||
Just groupId -> do
|
||||
Just gli@GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
cfg <- asks config
|
||||
case rejectionReason cfg of
|
||||
Nothing
|
||||
acceptMember_ <- asks $ acceptMember . chatHooks . config
|
||||
maybe (pure $ Right (GAAccepted, gLinkMemRole)) (\am -> liftIO $ am gInfo gli p) acceptMember_ >>= \case
|
||||
Right (acceptance, useRole)
|
||||
| v < groupFastLinkJoinVersion ->
|
||||
messageError "processUserContactRequest: chat version range incompatible for accepting group join request"
|
||||
| otherwise -> do
|
||||
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
|
||||
useRole = userMemberRole gLinkMemRole $ acceptAsObserver cfg
|
||||
mem <- acceptGroupJoinRequestAsync user gInfo cReq useRole profileMode
|
||||
mem <- acceptGroupJoinRequestAsync user gInfo cReq acceptance useRole profileMode
|
||||
createInternalChatItem user (CDGroupRcv gInfo mem) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
|
||||
toView $ CRAcceptingGroupJoinRequestMember user gInfo mem
|
||||
Just rjctReason
|
||||
Left rjctReason
|
||||
| v < groupJoinRejectVersion ->
|
||||
messageWarning $ "processUserContactRequest (group " <> groupName' gInfo <> "): joining of " <> displayName <> " is blocked"
|
||||
| otherwise -> do
|
||||
mem <- acceptGroupJoinSendRejectAsync user gInfo cReq rjctReason
|
||||
toViewTE $ TERejectingGroupJoinRequestMember user gInfo mem rjctReason
|
||||
_ -> toView $ CRReceivedContactRequest user cReq
|
||||
where
|
||||
rejectionReason ChatConfig {profileNameLimit, allowedProfileName}
|
||||
| T.length displayName > profileNameLimit = Just GRRLongName
|
||||
| maybe False (\f -> not $ f displayName) allowedProfileName = Just GRRBlockedName
|
||||
| otherwise = Nothing
|
||||
userMemberRole linkRole = \case
|
||||
Just AOAll -> GRObserver
|
||||
Just AONameOnly | noImage -> GRObserver
|
||||
Just AOIncognito | noImage && isRandomName displayName -> GRObserver
|
||||
_ -> linkRole
|
||||
where
|
||||
noImage = maybe True (\(ImageData i) -> i == "") image
|
||||
|
||||
-- TODO [knocking] review
|
||||
memberCanSend :: GroupMember -> CM () -> CM ()
|
||||
memberCanSend GroupMember {memberRole} a
|
||||
| memberRole <= GRObserver = messageError "member is not allowed to send messages"
|
||||
| otherwise = a
|
||||
memberCanSend GroupMember {memberRole, memberStatus} a
|
||||
| memberRole > GRObserver || memberStatus == GSMemPendingApproval = a
|
||||
| otherwise = messageError "member is not allowed to send messages"
|
||||
|
||||
processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
|
||||
processConnMERR connEntity conn err = do
|
||||
@@ -1576,7 +1450,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
where
|
||||
brokerTs = metaBrokerTs msgMeta
|
||||
newChatItem content ciFile_ timed_ live = do
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile_ timed_ live M.empty
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) Nothing msg sharedMsgId_ brokerTs content ciFile_ timed_ live M.empty
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
|
||||
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}]
|
||||
|
||||
@@ -1643,7 +1517,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- Chat item and update message which created it will have different sharedMsgId in this case...
|
||||
let timed_ = rcvContactCITimed ct ttl
|
||||
ts = ciContentTexts content
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) Nothing msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateDirectChatItem' db user contactId ci content True live Nothing Nothing
|
||||
@@ -1760,10 +1634,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
live' = fromMaybe False live_
|
||||
ExtMsgContent content mentions fInv_ itemTTL live_ = mcExtMsgContent mc
|
||||
ts@(_, ft_) = msgContentTexts content
|
||||
saveRcvCI = saveRcvChatItem' user (CDGroupRcv gInfo m) (memberNotInHistory m) msg sharedMsgId_ brokerTs
|
||||
createBlockedByAdmin
|
||||
| groupFeatureAllowed SGFFullDelete gInfo = do
|
||||
-- ignores member role when blocked by admin
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvBlocked) Nothing timed' False M.empty
|
||||
ci <- saveRcvCI (ciContentNoParse CIRcvBlocked) Nothing timed' False M.empty
|
||||
ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs
|
||||
groupMsgToView gInfo ci'
|
||||
| otherwise = do
|
||||
@@ -1775,7 +1650,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
| moderatorRole < GRModerator || moderatorRole < memberRole =
|
||||
createContentItem
|
||||
| groupFeatureMemberAllowed SGFFullDelete moderator gInfo = do
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvModerated) Nothing timed' False M.empty
|
||||
ci <- saveRcvCI (ciContentNoParse CIRcvModerated) Nothing timed' False M.empty
|
||||
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
|
||||
groupMsgToView gInfo ci'
|
||||
| otherwise = do
|
||||
@@ -1783,7 +1658,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
ci <- createNonLive file_
|
||||
toView =<< markGroupCIsDeleted user gInfo [CChatItem SMDRcv ci] False (Just moderator) moderatedAt
|
||||
createNonLive file_ =
|
||||
saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content, ts) (snd <$> file_) timed' False mentions
|
||||
saveRcvCI (CIRcvMsgContent content, ts) (snd <$> file_) timed' False mentions
|
||||
createContentItem = do
|
||||
file_ <- processFileInv
|
||||
newChatItem (CIRcvMsgContent content, ts) (snd <$> file_) timed' live'
|
||||
@@ -1792,7 +1667,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
newChatItem ciContent ciFile_ timed_ live = do
|
||||
let mentions' = if showMessages (memberSettings m) then mentions else []
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live mentions'
|
||||
ci <- saveRcvCI ciContent ciFile_ timed_ live mentions'
|
||||
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
|
||||
groupMsgToView gInfo ci' {reactions}
|
||||
@@ -1808,7 +1683,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- Chat item and update message which created it will have different sharedMsgId in this case...
|
||||
let timed_ = rcvGroupCITimed gInfo ttl_
|
||||
mentions' = if showMessages (memberSettings m) then mentions else []
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions'
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) (memberNotInHistory m) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions'
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
ci' <- updateGroupChatItem db user groupId ci content True live Nothing
|
||||
@@ -1841,6 +1716,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
else messageError "x.msg.update: group member attempted to update a message of another member"
|
||||
_ -> messageError "x.msg.update: group member attempted invalid message update"
|
||||
|
||||
memberNotInHistory :: GroupMember -> Maybe NotInHistory
|
||||
memberNotInHistory = \case
|
||||
GroupMember {memberStatus = GSMemPendingApproval} -> Just NotInHistory
|
||||
_ -> Nothing
|
||||
|
||||
groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> UTCTime -> CM ()
|
||||
groupMessageDelete gInfo@GroupInfo {membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} brokerTs = do
|
||||
let msgMemberId = fromMaybe memberId sndMemberId_
|
||||
@@ -1896,7 +1776,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
||||
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) Nothing msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
||||
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
|
||||
where
|
||||
brokerTs = metaBrokerTs msgMeta
|
||||
@@ -1910,7 +1790,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
||||
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) Nothing msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
||||
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
|
||||
groupMsgToView gInfo ci'
|
||||
|
||||
@@ -2173,16 +2053,27 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
xInfoMember gInfo m p' brokerTs = void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs)
|
||||
|
||||
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM ()
|
||||
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do
|
||||
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory, memberStatus} Connection {viaGroupLink} p' = do
|
||||
xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId
|
||||
if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived
|
||||
then do
|
||||
m' <- processMemberProfileUpdate gInfo m p' False Nothing
|
||||
withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True
|
||||
let connectedIncognito = memberIncognito membership
|
||||
probeMatchingMemberContact m' connectedIncognito
|
||||
unless (memberStatus == GSMemPendingApproval) $ do
|
||||
let connectedIncognito = memberIncognito membership
|
||||
probeMatchingMemberContact m' connectedIncognito
|
||||
else messageError "x.grp.link.mem error: invalid group link host profile update"
|
||||
|
||||
xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupMemberRole -> CM ()
|
||||
xGrpLinkAcpt gInfo@GroupInfo {membership} m role = do
|
||||
membership' <- withStore' $ \db -> do
|
||||
updateGroupMemberStatus db userId m GSMemConnected
|
||||
updateGroupMemberAccepted db user membership role
|
||||
let m' = m {memberStatus = GSMemConnected}
|
||||
toView $ CRUserJoinedGroup user gInfo {membership = membership'} m'
|
||||
let 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_
|
||||
| redactedMemberProfile (fromLocalProfile p) /= redactedMemberProfile p' = do
|
||||
@@ -2330,7 +2221,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
saveCallItem status = saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0)
|
||||
featureRejected f = do
|
||||
let content = ciContentNoParse $ CIRcvChatFeatureRejected f
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) Nothing msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
|
||||
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
|
||||
|
||||
-- to party initiating call
|
||||
|
||||
@@ -162,6 +162,8 @@ data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data NotInHistory = NotInHistory
|
||||
|
||||
data CIMention = CIMention
|
||||
{ memberId :: MemberId,
|
||||
-- member record can be created later than the mention is received
|
||||
|
||||
@@ -2,8 +2,6 @@
|
||||
|
||||
module Simplex.Chat.ProfileGenerator where
|
||||
|
||||
import qualified Data.Attoparsec.Text as A
|
||||
import Data.Either (isRight)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Chat.Types (Profile (..))
|
||||
import System.Random (randomRIO)
|
||||
@@ -25,15 +23,6 @@ generateRandomProfile = do
|
||||
then pickNoun adjective (n - 1)
|
||||
else pure noun
|
||||
|
||||
-- This function does not check for exact match with this disctionary,
|
||||
-- it only checks for the WordWord style.
|
||||
isRandomName :: Text -> Bool
|
||||
isRandomName = isRight . A.parseOnly randomNameP
|
||||
where
|
||||
randomNameP = A.satisfy upper >> A.takeWhile1 lower >> A.satisfy upper >> A.takeWhile1 lower >> A.endOfInput
|
||||
upper c = c >= 'A' && c <= 'Z'
|
||||
lower c = c >= 'a' && c <= 'z'
|
||||
|
||||
adjectives :: [Text]
|
||||
adjectives =
|
||||
[ "Abatic",
|
||||
@@ -1503,7 +1492,6 @@ adjectives =
|
||||
"Recommendable",
|
||||
"Rectangular",
|
||||
"Recuperative",
|
||||
"Red",
|
||||
"Refined",
|
||||
"Reflecting",
|
||||
"Reflective",
|
||||
@@ -2940,7 +2928,6 @@ nouns =
|
||||
"Sister",
|
||||
"Size",
|
||||
"Skill",
|
||||
"Skin",
|
||||
"Skipper",
|
||||
"Sleek",
|
||||
"Slick",
|
||||
|
||||
@@ -333,6 +333,7 @@ data ChatMsgEvent (e :: MsgEncoding) where
|
||||
XGrpLinkInv :: GroupLinkInvitation -> 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
|
||||
@@ -823,6 +824,7 @@ data CMEventTag (e :: MsgEncoding) where
|
||||
XGrpLinkInv_ :: CMEventTag 'Json
|
||||
XGrpLinkReject_ :: CMEventTag 'Json
|
||||
XGrpLinkMem_ :: CMEventTag 'Json
|
||||
XGrpLinkAcpt_ :: CMEventTag 'Json
|
||||
XGrpMemNew_ :: CMEventTag 'Json
|
||||
XGrpMemIntro_ :: CMEventTag 'Json
|
||||
XGrpMemInv_ :: CMEventTag 'Json
|
||||
@@ -875,6 +877,7 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where
|
||||
XGrpLinkInv_ -> "x.grp.link.inv"
|
||||
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"
|
||||
@@ -928,6 +931,7 @@ instance StrEncoding ACMEventTag where
|
||||
"x.grp.link.inv" -> XGrpLinkInv_
|
||||
"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_
|
||||
@@ -977,6 +981,7 @@ toCMEventTag msg = case msg of
|
||||
XGrpLinkInv _ -> XGrpLinkInv_
|
||||
XGrpLinkReject _ -> XGrpLinkReject_
|
||||
XGrpLinkMem _ -> XGrpLinkMem_
|
||||
XGrpLinkAcpt _ -> XGrpLinkAcpt_
|
||||
XGrpMemNew _ -> XGrpMemNew_
|
||||
XGrpMemIntro _ _ -> XGrpMemIntro_
|
||||
XGrpMemInv _ _ -> XGrpMemInv_
|
||||
@@ -1079,6 +1084,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation"
|
||||
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"
|
||||
@@ -1142,6 +1148,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
|
||||
XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv]
|
||||
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]
|
||||
|
||||
@@ -6,6 +6,7 @@ module Simplex.Chat.Store
|
||||
ChatLockEntity (..),
|
||||
UserMsgReceiptSettings (..),
|
||||
UserContactLink (..),
|
||||
GroupLinkInfo (..),
|
||||
AutoAccept (..),
|
||||
createChatStore,
|
||||
migrations, -- used in tests
|
||||
|
||||
@@ -78,6 +78,7 @@ module Simplex.Chat.Store.Groups
|
||||
createMemberConnectionAsync,
|
||||
updateGroupMemberStatus,
|
||||
updateGroupMemberStatusById,
|
||||
updateGroupMemberAccepted,
|
||||
createNewGroupMember,
|
||||
checkGroupMemberHasItems,
|
||||
deleteGroupMember,
|
||||
@@ -520,9 +521,10 @@ deleteContactCardKeepConn db connId Contact {contactId, profile = LocalProfile {
|
||||
DB.execute db "DELETE FROM contact_profiles WHERE contact_profile_id = ?" (Only profileId)
|
||||
|
||||
createGroupInvitedViaLink :: DB.Connection -> VersionRangeChat -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupInvitedViaLink db vr user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, business} = do
|
||||
createGroupInvitedViaLink db vr user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
|
||||
let fromMemberProfile = profileFromName fromMemberName
|
||||
createGroupViaLink' db vr user conn fromMember fromMemberProfile invitedMember groupProfile business GSMemAccepted
|
||||
initialStatus = maybe GSMemAccepted acceptanceToStatus accepted
|
||||
createGroupViaLink' db vr user conn fromMember fromMemberProfile invitedMember groupProfile business initialStatus
|
||||
|
||||
createGroupRejectedViaLink :: DB.Connection -> VersionRangeChat -> User -> Connection -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupRejectedViaLink db vr user conn GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
|
||||
@@ -1201,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
|
||||
|
||||
@@ -142,7 +142,7 @@ import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.Ord (Down (..), comparing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@@ -372,9 +372,9 @@ updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirecti
|
||||
(chatTs, userId, noteFolderId)
|
||||
_ -> pure ()
|
||||
|
||||
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId
|
||||
createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live createdAt =
|
||||
createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False createdAt Nothing createdAt
|
||||
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> Maybe NotInHistory -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId
|
||||
createNewSndChatItem db user chatDirection notInHistory_ SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live createdAt =
|
||||
createNewChatItem_ db user chatDirection notInHistory_ createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False createdAt Nothing createdAt
|
||||
where
|
||||
createdByMsgId = if msgId == 0 then Nothing else Just msgId
|
||||
quoteRow :: NewQuoteRow
|
||||
@@ -388,9 +388,9 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
|
||||
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
|
||||
CIQGroupRcv Nothing -> (Just False, Nothing)
|
||||
|
||||
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live userMention itemTs createdAt = do
|
||||
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt
|
||||
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> Maybe NotInHistory -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
|
||||
createNewRcvChatItem db user chatDirection notInHistory_ RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live userMention itemTs createdAt = do
|
||||
ciId <- createNewChatItem_ db user chatDirection notInHistory_ (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt
|
||||
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
|
||||
pure (ciId, quotedItem, itemForwarded)
|
||||
where
|
||||
@@ -407,13 +407,13 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw
|
||||
|
||||
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
|
||||
createNewChatItemNoMsg db user chatDirection ciContent itemTs =
|
||||
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing Nothing False False itemTs Nothing
|
||||
createNewChatItem_ db user chatDirection Nothing Nothing Nothing ciContent quoteRow Nothing Nothing False False itemTs Nothing
|
||||
where
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
|
||||
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId
|
||||
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt = do
|
||||
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe NotInHistory -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId
|
||||
createNewChatItem_ db User {userId} chatDirection notInHistory_ msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention itemTs forwardedByMember createdAt = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -448,7 +448,7 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
|
||||
includeInHistory :: Bool
|
||||
includeInHistory =
|
||||
let (_, groupId_, _, _) = idsRow
|
||||
in isJust groupId_ && isJust (ciMsgContent ciContent) && ((msgContentTag <$> ciMsgContent ciContent) /= Just MCReport_)
|
||||
in isJust groupId_ && isNothing notInHistory_ && isJust (ciMsgContent ciContent) && ((msgContentTag <$> ciMsgContent ciContent) /= Just MCReport_)
|
||||
forwardedFromRow :: (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64)
|
||||
forwardedFromRow = case itemForwarded of
|
||||
Nothing ->
|
||||
@@ -2319,9 +2319,9 @@ updateGroupCIMentions db g ci@ChatItem {mentions} mentions'
|
||||
unless (null mentions) $ deleteMentions
|
||||
if null mentions'
|
||||
then pure ci
|
||||
-- This is a fallback for the error that should not happen in practice.
|
||||
else -- This is a fallback for the error that should not happen in practice.
|
||||
-- In theory, it may happen in item mentions in database are different from item record.
|
||||
else createMentions `E.catch` \e -> if constraintError e then deleteMentions >> createMentions else E.throwIO e
|
||||
createMentions `E.catch` \e -> if constraintError e then deleteMentions >> createMentions else E.throwIO e
|
||||
where
|
||||
deleteMentions = DB.execute db "DELETE FROM chat_item_mentions WHERE chat_item_id = ?" (Only $ chatItemId' ci)
|
||||
createMentions = createGroupCIMentions db g ci mentions'
|
||||
@@ -3138,6 +3138,7 @@ getGroupSndStatusCounts db itemId =
|
||||
|]
|
||||
(Only itemId)
|
||||
|
||||
-- TODO [knocking] filter out messages sent to member only
|
||||
getGroupHistoryItems :: DB.Connection -> User -> GroupInfo -> GroupMember -> Int -> IO [Either StoreError (CChatItem 'CTGroup)]
|
||||
getGroupHistoryItems db user@User {userId} g@GroupInfo {groupId} m count = do
|
||||
ciIds <- getLastItemIds_
|
||||
|
||||
@@ -18,6 +18,7 @@ module Simplex.Chat.Store.Profiles
|
||||
( AutoAccept (..),
|
||||
UserMsgReceiptSettings (..),
|
||||
UserContactLink (..),
|
||||
GroupLinkInfo (..),
|
||||
createUserRecord,
|
||||
createUserRecordAt,
|
||||
getUsersInfo,
|
||||
@@ -47,6 +48,7 @@ module Simplex.Chat.Store.Profiles
|
||||
deleteUserAddress,
|
||||
getUserAddress,
|
||||
getUserContactLinkById,
|
||||
getGroupLinkInfo,
|
||||
getUserContactLinkByConnReq,
|
||||
getContactWithoutConnViaAddress,
|
||||
updateUserAddressAutoAccept,
|
||||
@@ -453,6 +455,12 @@ data UserContactLink = UserContactLink
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data GroupLinkInfo = GroupLinkInfo
|
||||
{ groupId :: GroupId,
|
||||
memberRole :: GroupMemberRole
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data AutoAccept = AutoAccept
|
||||
{ businessAddress :: Bool, -- possibly, it can be wrapped together with acceptIncognito, or AutoAccept made sum type
|
||||
acceptIncognito :: IncognitoEnabled,
|
||||
@@ -481,18 +489,28 @@ getUserAddress db User {userId} =
|
||||
|]
|
||||
(Only userId)
|
||||
|
||||
getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupId, GroupMemberRole)
|
||||
getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO (UserContactLink, Maybe GroupLinkInfo)
|
||||
getUserContactLinkById db userId userContactLinkId =
|
||||
ExceptT . firstRow (\(ucl :. (groupId_, mRole_)) -> (toUserContactLink ucl, groupId_, fromMaybe GRMember mRole_)) SEUserContactLinkNotFound $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ?
|
||||
AND user_contact_link_id = ?
|
||||
|]
|
||||
(userId, userContactLinkId)
|
||||
ExceptT . firstRow (\(ucl :. gli) -> (toUserContactLink ucl, toGroupLinkInfo gli)) SEUserContactLinkNotFound $
|
||||
DB.query db (groupLinkInfoQuery <> " AND user_contact_link_id = ?") (userId, userContactLinkId)
|
||||
|
||||
groupLinkInfoQuery :: Query
|
||||
groupLinkInfoQuery =
|
||||
[sql|
|
||||
SELECT conn_req_contact, auto_accept, business_address, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ?
|
||||
|]
|
||||
|
||||
toGroupLinkInfo :: (Maybe GroupId, Maybe GroupMemberRole) -> Maybe GroupLinkInfo
|
||||
toGroupLinkInfo (groupId_, mRole_) =
|
||||
(\groupId -> GroupLinkInfo {groupId, memberRole = fromMaybe GRMember mRole_})
|
||||
<$> groupId_
|
||||
|
||||
getGroupLinkInfo :: DB.Connection -> UserId -> GroupId -> IO (Maybe GroupLinkInfo)
|
||||
getGroupLinkInfo db userId groupId =
|
||||
fmap join $ maybeFirstRow toGroupLinkInfo $
|
||||
DB.query db (groupLinkInfoQuery <> " AND group_id = ?") (userId, groupId)
|
||||
|
||||
getUserContactLinkByConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe UserContactLink)
|
||||
getUserContactLinkByConnReq db User {userId} (cReqSchema1, cReqSchema2) =
|
||||
|
||||
@@ -4870,7 +4870,7 @@ Query:
|
||||
Plan:
|
||||
SCAN usage_conditions
|
||||
|
||||
Query: SELECT chat_item_id FROM chat_items WHERE ( user_id = ? AND group_id = ? AND item_ts < ? ) OR ( user_id = ? AND group_id = ? AND item_ts = ? AND chat_item_id < ? ) ORDER BY item_ts DESC, chat_item_id DESC LIMIT ?
|
||||
Query: SELECT chat_item_id FROM chat_items WHERE (( user_id = ? AND group_id = ? AND item_ts < ? ) OR ( user_id = ? AND group_id = ? AND item_ts = ? AND chat_item_id < ? )) ORDER BY item_ts DESC, chat_item_id DESC LIMIT ?
|
||||
Plan:
|
||||
MULTI-INDEX OR
|
||||
INDEX 1
|
||||
@@ -4879,7 +4879,7 @@ INDEX 2
|
||||
SEARCH chat_items USING COVERING INDEX idx_chat_items_groups_item_ts (user_id=? AND group_id=? AND item_ts=? AND rowid<?)
|
||||
USE TEMP B-TREE FOR ORDER BY
|
||||
|
||||
Query: SELECT chat_item_id FROM chat_items WHERE ( user_id = ? AND group_id = ? AND item_ts > ? ) OR ( user_id = ? AND group_id = ? AND item_ts = ? AND chat_item_id > ? ) ORDER BY item_ts ASC, chat_item_id ASC LIMIT ?
|
||||
Query: SELECT chat_item_id FROM chat_items WHERE (( user_id = ? AND group_id = ? AND item_ts > ? ) OR ( user_id = ? AND group_id = ? AND item_ts = ? AND chat_item_id > ? )) ORDER BY item_ts ASC, chat_item_id ASC LIMIT ?
|
||||
Plan:
|
||||
MULTI-INDEX OR
|
||||
INDEX 1
|
||||
|
||||
@@ -668,6 +668,7 @@ data GroupLinkInvitation = GroupLinkInvitation
|
||||
fromMemberName :: ContactName,
|
||||
invitedMember :: MemberIdRole,
|
||||
groupProfile :: GroupProfile,
|
||||
accepted :: Maybe GroupAcceptance,
|
||||
business :: Maybe BusinessChatInfo,
|
||||
groupSize :: Maybe Int
|
||||
}
|
||||
@@ -997,6 +998,7 @@ data GroupMemberStatus
|
||||
| GSMemGroupDeleted -- user member of the deleted group
|
||||
| GSMemUnknown -- unknown member, whose message was forwarded by an admin (likely member wasn't introduced due to not being a current member, but message was included in history)
|
||||
| GSMemInvited -- member is sent to or received invitation to join the group
|
||||
| GSMemPendingApproval -- member is connected to host but pending host approval before connecting to other members ("knocking")
|
||||
| GSMemIntroduced -- user received x.grp.mem.intro for this member (only with GCPreMember)
|
||||
| GSMemIntroInvited -- member is sent to or received from intro invitation
|
||||
| GSMemAccepted -- member accepted invitation (only User and Invitee)
|
||||
@@ -1017,6 +1019,11 @@ instance ToJSON GroupMemberStatus where
|
||||
toJSON = J.String . textEncode
|
||||
toEncoding = JE.text . textEncode
|
||||
|
||||
acceptanceToStatus :: GroupAcceptance -> GroupMemberStatus
|
||||
acceptanceToStatus = \case
|
||||
GAAccepted -> GSMemAccepted
|
||||
GAPending -> GSMemPendingApproval
|
||||
|
||||
memberActive :: GroupMember -> Bool
|
||||
memberActive m = case memberStatus m of
|
||||
GSMemRejected -> False
|
||||
@@ -1025,6 +1032,7 @@ memberActive m = case memberStatus m of
|
||||
GSMemGroupDeleted -> False
|
||||
GSMemUnknown -> False
|
||||
GSMemInvited -> False
|
||||
GSMemPendingApproval -> True
|
||||
GSMemIntroduced -> False
|
||||
GSMemIntroInvited -> False
|
||||
GSMemAccepted -> False
|
||||
@@ -1045,6 +1053,7 @@ memberCurrent' = \case
|
||||
GSMemGroupDeleted -> False
|
||||
GSMemUnknown -> False
|
||||
GSMemInvited -> False
|
||||
GSMemPendingApproval -> False
|
||||
GSMemIntroduced -> True
|
||||
GSMemIntroInvited -> True
|
||||
GSMemAccepted -> True
|
||||
@@ -1061,6 +1070,7 @@ memberRemoved m = case memberStatus m of
|
||||
GSMemGroupDeleted -> True
|
||||
GSMemUnknown -> False
|
||||
GSMemInvited -> False
|
||||
GSMemPendingApproval -> False
|
||||
GSMemIntroduced -> False
|
||||
GSMemIntroInvited -> False
|
||||
GSMemAccepted -> False
|
||||
@@ -1077,6 +1087,7 @@ instance TextEncoding GroupMemberStatus where
|
||||
"deleted" -> Just GSMemGroupDeleted
|
||||
"unknown" -> Just GSMemUnknown
|
||||
"invited" -> Just GSMemInvited
|
||||
"pending_approval" -> Just GSMemPendingApproval
|
||||
"introduced" -> Just GSMemIntroduced
|
||||
"intro-inv" -> Just GSMemIntroInvited
|
||||
"accepted" -> Just GSMemAccepted
|
||||
@@ -1092,6 +1103,7 @@ instance TextEncoding GroupMemberStatus where
|
||||
GSMemGroupDeleted -> "deleted"
|
||||
GSMemUnknown -> "unknown"
|
||||
GSMemInvited -> "invited"
|
||||
GSMemPendingApproval -> "pending_approval"
|
||||
GSMemIntroduced -> "introduced"
|
||||
GSMemIntroInvited -> "intro-inv"
|
||||
GSMemAccepted -> "accepted"
|
||||
|
||||
@@ -48,3 +48,27 @@ instance FromJSON GroupMemberRole where
|
||||
instance ToJSON GroupMemberRole where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data GroupAcceptance = GAAccepted | GAPending deriving (Eq, Show)
|
||||
|
||||
-- TODO [knocking] encoding doesn't match field type
|
||||
instance FromField GroupAcceptance where fromField = blobFieldDecoder strDecode
|
||||
|
||||
instance ToField GroupAcceptance where toField = toField . strEncode
|
||||
|
||||
instance StrEncoding GroupAcceptance where
|
||||
strEncode = \case
|
||||
GAAccepted -> "accepted"
|
||||
GAPending -> "pending"
|
||||
strDecode = \case
|
||||
"accepted" -> Right GAAccepted
|
||||
"pending" -> Right GAPending
|
||||
r -> Left $ "bad GroupAcceptance " <> B.unpack r
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
|
||||
instance FromJSON GroupAcceptance where
|
||||
parseJSON = strParseJSON "GroupAcceptance"
|
||||
|
||||
instance ToJSON GroupAcceptance where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
@@ -1076,14 +1076,22 @@ viewNetworkStatuses = map viewStatuses . L.groupBy ((==) `on` netStatus) . sortO
|
||||
viewStatuses ss@(s :| _) = plain $ show (L.length ss) <> " connections " <> netStatusStr (netStatus s)
|
||||
|
||||
viewUserJoinedGroup :: GroupInfo -> [StyledString]
|
||||
viewUserJoinedGroup g =
|
||||
viewUserJoinedGroup g@GroupInfo {membership} =
|
||||
case incognitoMembershipProfile g of
|
||||
Just mp -> [ttyGroup' g <> ": you joined the group incognito as " <> incognitoProfile' (fromLocalProfile mp)]
|
||||
Nothing -> [ttyGroup' g <> ": you joined the group"]
|
||||
Just mp -> [ttyGroup' g <> ": you joined the group incognito as " <> incognitoProfile' (fromLocalProfile mp) <> pendingApproval_]
|
||||
Nothing -> [ttyGroup' g <> ": you joined the group" <> pendingApproval_]
|
||||
where
|
||||
pendingApproval_ = case memberStatus membership of
|
||||
GSMemPendingApproval -> ", pending approval"
|
||||
_ -> ""
|
||||
|
||||
viewJoinedGroupMember :: GroupInfo -> GroupMember -> [StyledString]
|
||||
viewJoinedGroupMember g m =
|
||||
[ttyGroup' g <> ": " <> ttyMember m <> " joined the group "]
|
||||
viewJoinedGroupMember g@GroupInfo {groupId} m@GroupMember {groupMemberId, memberStatus} = case memberStatus of
|
||||
GSMemPendingApproval ->
|
||||
[ (ttyGroup' g <> ": " <> ttyMember m <> " connected and pending approval, ")
|
||||
<> ("use " <> highlight ("/_accept member #" <> show groupId <> " " <> show groupMemberId <> " <role>") <> " to accept member")
|
||||
]
|
||||
_ -> [ttyGroup' g <> ": " <> ttyMember m <> " joined the group "]
|
||||
|
||||
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
|
||||
viewReceivedGroupInvitation g c role =
|
||||
|
||||
Reference in new issue
Block a user