mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-14 21:15:37 +00:00
core: support observers send messages to admins, CLI commands (#5921)
* core: allow observers send messages to admins * improve parser, CLI command to approve members
This commit is contained in:
@@ -469,7 +469,7 @@ data ChatCommand
|
||||
| ForwardMessage {toChatName :: ChatName, fromContactName :: ContactName, forwardedMsg :: Text}
|
||||
| ForwardGroupMessage {toChatName :: ChatName, fromGroupName :: GroupName, fromMemberName_ :: Maybe ContactName, forwardedMsg :: Text}
|
||||
| ForwardLocalMessage {toChatName :: ChatName, forwardedMsg :: Text}
|
||||
| SendMessage ChatName Text
|
||||
| SendMessage SendName Text
|
||||
| SendMemberContactMessage GroupName ContactName Text
|
||||
| SendLiveMessage ChatName Text
|
||||
| SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: Text, message :: Text}
|
||||
@@ -483,6 +483,7 @@ data ChatCommand
|
||||
| NewGroup IncognitoEnabled GroupProfile
|
||||
| AddMember GroupName ContactName GroupMemberRole
|
||||
| JoinGroup {groupName :: GroupName, enableNtfs :: MsgFilter}
|
||||
| AcceptMember GroupName ContactName GroupMemberRole
|
||||
| MemberRole GroupName ContactName GroupMemberRole
|
||||
| BlockForAll GroupName ContactName Bool
|
||||
| RemoveMembers {groupName :: GroupName, members :: Set ContactName, withMessages :: Bool}
|
||||
|
||||
@@ -27,6 +27,7 @@ import Control.Monad.Reader
|
||||
import qualified Data.Aeson as J
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.Attoparsec.Combinator as A
|
||||
import qualified Data.ByteString.Base64 as B64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
@@ -1848,10 +1849,10 @@ processChatCommand' vr = \case
|
||||
forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg
|
||||
toChatRef <- getChatRef user toChatName
|
||||
processChatCommand $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing
|
||||
SendMessage (ChatName cType name) msg -> withUser $ \user -> do
|
||||
SendMessage sendName msg -> withUser $ \user -> do
|
||||
let mc = MCText msg
|
||||
case cType of
|
||||
CTDirect ->
|
||||
case sendName of
|
||||
SNDirect name ->
|
||||
withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case
|
||||
Right ctId -> do
|
||||
let sendRef = SRDirect ctId
|
||||
@@ -1866,18 +1867,18 @@ processChatCommand' vr = \case
|
||||
throwChatError $ CEContactNotFound name (Just suspectedMember)
|
||||
_ ->
|
||||
throwChatError $ CEContactNotFound name Nothing
|
||||
CTGroup -> do
|
||||
(gId, mentions) <- withFastStore $ \db -> do
|
||||
SNGroup name scope_ -> do
|
||||
(gId, cScope_, mentions) <- withFastStore $ \db -> do
|
||||
gId <- getGroupIdByName db user name
|
||||
(gId,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let sendRef = SRGroup gId Nothing
|
||||
cScope_ <-
|
||||
forM scope_ $ \(GSNMemberSupport mName_) ->
|
||||
GCSMemberSupport <$> mapM (getGroupMemberIdByName db user gId) mName_
|
||||
(gId,cScope_,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let sendRef = SRGroup gId cScope_
|
||||
processChatCommand $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
CTLocal
|
||||
| name == "" -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
processChatCommand $ APICreateChatItems folderId [composedMessage Nothing mc]
|
||||
| otherwise -> throwCmdError "not supported"
|
||||
_ -> throwCmdError "not supported"
|
||||
SNLocal -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
processChatCommand $ APICreateChatItems folderId [composedMessage Nothing mc]
|
||||
SendMemberContactMessage gName mName msg -> withUser $ \user -> do
|
||||
(gId, mId) <- getGroupAndMemberId user gName mName
|
||||
m <- withFastStore $ \db -> getGroupMember db vr user gId mId
|
||||
@@ -2331,6 +2332,7 @@ processChatCommand' vr = \case
|
||||
JoinGroup gName enableNtfs -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIJoinGroup groupId enableNtfs
|
||||
AcceptMember gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIAcceptMember gId gMemberId memRole
|
||||
MemberRole gName gMemberName memRole -> withMemberName gName gMemberName $ \gId gMemberId -> APIMembersRole gId [gMemberId] memRole
|
||||
BlockForAll gName gMemberName blocked -> withMemberName gName gMemberName $ \gId gMemberId -> APIBlockMembersForAll gId [gMemberId] blocked
|
||||
RemoveMembers gName gMemberNames withMessages -> withUser $ \user -> do
|
||||
@@ -2421,7 +2423,8 @@ processChatCommand' vr = \case
|
||||
when (contactGrpInvSent ct) $ throwCmdError "x.grp.direct.inv already sent"
|
||||
case memberConn m of
|
||||
Just mConn -> do
|
||||
let msg = XGrpDirectInv cReq msgContent_
|
||||
-- TODO [knocking] send in correct scope - modiy API
|
||||
let msg = XGrpDirectInv cReq msgContent_ Nothing
|
||||
(sndMsg, _, _) <- sendDirectMemberMessage mConn msg groupId
|
||||
withFastStore' $ \db -> setContactGrpInvSent db ct True
|
||||
let ct' = ct {contactGrpInvSent = True}
|
||||
@@ -3372,7 +3375,7 @@ processChatCommand' vr = \case
|
||||
Nothing -> Just GRAuthor
|
||||
Just (GCSMemberSupport Nothing)
|
||||
| memberPending membership -> Nothing
|
||||
| otherwise -> Just GRAuthor
|
||||
| otherwise -> Just GRObserver
|
||||
Just (GCSMemberSupport (Just _gmId)) -> Just GRModerator
|
||||
assertGroupContentAllowed :: CM ()
|
||||
assertGroupContentAllowed =
|
||||
@@ -4190,6 +4193,7 @@ chatCommandP =
|
||||
"/_group " *> (APINewGroup <$> A.decimal <*> incognitoOnOffP <* A.space <*> jsonP),
|
||||
("/add " <|> "/a ") *> char_ '#' *> (AddMember <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <*> (memberRole <|> pure GRMember)),
|
||||
("/join " <|> "/j ") *> char_ '#' *> (JoinGroup <$> displayNameP <*> (" mute" $> MFNone <|> pure MFAll)),
|
||||
"/accept member " *> char_ '#' *> (AcceptMember <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <*> (memberRole <|> pure GRMember)),
|
||||
("/member role " <|> "/mr ") *> char_ '#' *> (MemberRole <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <*> memberRole),
|
||||
"/block for all #" *> (BlockForAll <$> displayNameP <* A.space <*> (char_ '@' *> displayNameP) <*> pure True),
|
||||
"/unblock for all #" *> (BlockForAll <$> displayNameP <* A.space <*> (char_ '@' *> displayNameP) <*> pure False),
|
||||
@@ -4236,8 +4240,7 @@ chatCommandP =
|
||||
ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayNameP <* A.space <* A.char '@' <*> (Just <$> displayNameP) <* A.space <*> msgTextP,
|
||||
ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayNameP <*> pure Nothing <* A.space <*> msgTextP,
|
||||
ForwardLocalMessage <$> chatNameP <* " <- * " <*> msgTextP,
|
||||
SendMessage <$> chatNameP <* A.space <*> msgTextP,
|
||||
"/* " *> (SendMessage (ChatName CTLocal "") <$> msgTextP),
|
||||
SendMessage <$> sendNameP <* A.space <*> msgTextP,
|
||||
"@#" *> (SendMemberContactMessage <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <* A.space <*> msgTextP),
|
||||
"/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")),
|
||||
(">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv),
|
||||
@@ -4440,14 +4443,27 @@ chatCommandP =
|
||||
chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayNameP
|
||||
chatRefP = do
|
||||
chatTypeP >>= \case
|
||||
CTGroup -> ChatRef CTGroup <$> A.decimal <*> (Just <$> gcScopeP <|> pure Nothing)
|
||||
CTGroup -> ChatRef CTGroup <$> A.decimal <*> optional gcScopeP
|
||||
cType -> (\chatId -> ChatRef cType chatId Nothing) <$> A.decimal
|
||||
sendRefP =
|
||||
(A.char '@' $> SRDirect <*> A.decimal)
|
||||
<|> (A.char '#' $> SRGroup <*> A.decimal <*> (Just <$> gcScopeP <|> pure Nothing))
|
||||
gcScopeP =
|
||||
("(_support:" *> (GCSMemberSupport . Just <$> A.decimal) <* ")")
|
||||
<|> ("(_support)" $> (GCSMemberSupport Nothing))
|
||||
<|> (A.char '#' $> SRGroup <*> A.decimal <*> optional gcScopeP)
|
||||
gcScopeP = "(_support" *> (GCSMemberSupport <$> optional (A.char ':' *> A.decimal)) <* A.char ')'
|
||||
sendNameP =
|
||||
(A.char '@' $> SNDirect <*> displayNameP)
|
||||
<|> (A.char '#' $> SNGroup <*> displayNameP <*> gScopeNameP)
|
||||
<|> ("/*" $> SNLocal)
|
||||
gScopeNameP =
|
||||
(supportPfx *> (Just . GSNMemberSupport <$> optional supportMember) <* A.char ')')
|
||||
-- this branch fails on "(support" followed by incorrect syntax,
|
||||
-- to avoid sending message to the whole group as `optional gScopeNameP` would do
|
||||
<|> (optional supportPfx >>= mapM (\_ -> fail "bad chat scope"))
|
||||
where
|
||||
supportPfx = A.takeWhile isSpace *> "(support"
|
||||
supportMember = safeDecodeUtf8 <$> (A.char ':' *> A.takeWhile isSpace *> (A.take . lengthTillLastParen =<< A.lookAhead displayNameP_))
|
||||
lengthTillLastParen s = case B.unsnoc s of
|
||||
Just (_, ')') -> B.length s - 1
|
||||
_ -> B.length s
|
||||
msgCountP = A.space *> A.decimal <|> pure 10
|
||||
ciTTLDecimal = ("default" $> Nothing) <|> (Just <$> A.decimal)
|
||||
ciTTL =
|
||||
@@ -4513,7 +4529,11 @@ chatCommandP =
|
||||
char_ = optional . A.char
|
||||
|
||||
displayNameP :: Parser Text
|
||||
displayNameP = safeDecodeUtf8 <$> (quoted '\'' <|> takeNameTill (\c -> isSpace c || c == ','))
|
||||
displayNameP = safeDecodeUtf8 <$> displayNameP_
|
||||
{-# INLINE displayNameP #-}
|
||||
|
||||
displayNameP_ :: Parser ByteString
|
||||
displayNameP_ = quoted '\'' <|> takeNameTill (\c -> isSpace c || c == ',')
|
||||
where
|
||||
takeNameTill p =
|
||||
A.peekChar' >>= \c ->
|
||||
|
||||
@@ -871,9 +871,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
logInfo $ "group msg=" <> tshow tag <> " " <> eInfo
|
||||
(m'', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta msgBody chatMsg
|
||||
case event of
|
||||
XMsgNew mc -> memberCanSend m'' $ newGroupContentMessage gInfo' m'' mc msg brokerTs False
|
||||
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m'' $ groupMessageFileDescription gInfo' m'' sharedMsgId fileDescr
|
||||
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend m'' $ groupMessageUpdate gInfo' m'' sharedMsgId mContent mentions msgScope msg brokerTs ttl live
|
||||
XMsgNew mc -> memberCanSend m'' scope $ newGroupContentMessage gInfo' m'' mc msg brokerTs False
|
||||
where ExtMsgContent {scope} = mcExtMsgContent mc
|
||||
-- file description is always allowed, to allow sending files to support scope
|
||||
XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' m'' sharedMsgId fileDescr
|
||||
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend m'' msgScope $ groupMessageUpdate gInfo' m'' sharedMsgId mContent mentions msgScope msg brokerTs ttl live
|
||||
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo' m'' sharedMsgId memberId msg brokerTs
|
||||
XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId reaction add msg brokerTs
|
||||
-- TODO discontinue XFile
|
||||
@@ -895,7 +897,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
XGrpDel -> xGrpDel gInfo' m'' msg brokerTs
|
||||
XGrpInfo p' -> xGrpInfo gInfo' m'' p' msg brokerTs
|
||||
XGrpPrefs ps' -> xGrpPrefs gInfo' m'' ps'
|
||||
XGrpDirectInv connReq mContent_ -> memberCanSend m'' $ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs
|
||||
-- TODO [knocking] why don't we forward these messages?
|
||||
XGrpDirectInv connReq mContent_ msgScope -> memberCanSend m'' msgScope $ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs
|
||||
XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo' m'' memberId msg' msgTs
|
||||
XInfoProbe probe -> xInfoProbe (COMGroupMember m'') probe
|
||||
XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m'') probeHash
|
||||
@@ -1252,10 +1255,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
toViewTE $ TERejectingGroupJoinRequestMember user gInfo mem rjctReason
|
||||
_ -> toView $ CEvtReceivedContactRequest user cReq
|
||||
|
||||
memberCanSend :: GroupMember -> CM () -> CM ()
|
||||
memberCanSend m@GroupMember {memberRole} a
|
||||
| memberRole > GRObserver || memberPending m = a
|
||||
| otherwise = messageError "member is not allowed to send messages"
|
||||
memberCanSend :: GroupMember -> Maybe MsgScope -> CM () -> CM ()
|
||||
memberCanSend m@GroupMember {memberRole} msgScope a = case msgScope of
|
||||
Just MSMember {} -> a
|
||||
Nothing
|
||||
| memberRole > GRObserver || memberPending m -> a
|
||||
| otherwise -> messageError "member is not allowed to send messages"
|
||||
|
||||
processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
|
||||
processConnMERR connEntity conn err = do
|
||||
@@ -2839,9 +2844,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let body = LB.toStrict $ J.encode msg
|
||||
rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg
|
||||
case event of
|
||||
XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs True
|
||||
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
|
||||
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live
|
||||
XMsgNew mc -> memberCanSend author scope $ newGroupContentMessage gInfo author mc rcvMsg msgTs True
|
||||
where ExtMsgContent {scope} = mcExtMsgContent mc
|
||||
-- file description is always allowed, to allow sending files to support scope
|
||||
XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo author sharedMsgId fileDescr
|
||||
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend author msgScope $ groupMessageUpdate gInfo author sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live
|
||||
XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs
|
||||
XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs
|
||||
XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId
|
||||
|
||||
@@ -83,6 +83,16 @@ instance TextEncoding GroupChatScopeTag where
|
||||
data ChatName = ChatName {chatType :: ChatType, chatName :: Text}
|
||||
deriving (Show)
|
||||
|
||||
data SendName
|
||||
= SNDirect ContactName
|
||||
| SNGroup GroupName (Maybe GroupScopeName)
|
||||
| SNLocal
|
||||
deriving (Show)
|
||||
|
||||
data GroupScopeName
|
||||
= GSNMemberSupport (Maybe ContactName)
|
||||
deriving (Show)
|
||||
|
||||
chatTypeStr :: ChatType -> Text
|
||||
chatTypeStr = \case
|
||||
CTDirect -> "@"
|
||||
|
||||
@@ -361,7 +361,7 @@ data ChatMsgEvent (e :: MsgEncoding) where
|
||||
XGrpDel :: ChatMsgEvent 'Json
|
||||
XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json
|
||||
XGrpPrefs :: GroupPreferences -> ChatMsgEvent 'Json
|
||||
XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> ChatMsgEvent 'Json
|
||||
XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> Maybe MsgScope -> ChatMsgEvent 'Json
|
||||
XGrpMsgForward :: MemberId -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json
|
||||
XInfoProbe :: Probe -> ChatMsgEvent 'Json
|
||||
XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json
|
||||
@@ -1011,7 +1011,7 @@ toCMEventTag msg = case msg of
|
||||
XGrpDel -> XGrpDel_
|
||||
XGrpInfo _ -> XGrpInfo_
|
||||
XGrpPrefs _ -> XGrpPrefs_
|
||||
XGrpDirectInv _ _ -> XGrpDirectInv_
|
||||
XGrpDirectInv {} -> XGrpDirectInv_
|
||||
XGrpMsgForward {} -> XGrpMsgForward_
|
||||
XInfoProbe _ -> XInfoProbe_
|
||||
XInfoProbeCheck _ -> XInfoProbeCheck_
|
||||
@@ -1083,7 +1083,14 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
msg = \case
|
||||
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
|
||||
XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr"
|
||||
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> (fromMaybe M.empty <$> opt "mentions") <*> opt "ttl" <*> opt "live" <*> opt "scope"
|
||||
XMsgUpdate_ -> do
|
||||
msgId' <- p "msgId"
|
||||
content <- p "content"
|
||||
mentions <- fromMaybe M.empty <$> opt "mentions"
|
||||
ttl <- opt "ttl"
|
||||
live <- opt "live"
|
||||
scope <- opt "scope"
|
||||
pure XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope}
|
||||
XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId"
|
||||
XMsgDeleted_ -> pure XMsgDeleted
|
||||
XMsgReact_ -> XMsgReact <$> p "msgId" <*> opt "memberId" <*> p "reaction" <*> p "add"
|
||||
@@ -1114,7 +1121,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
XGrpDel_ -> pure XGrpDel
|
||||
XGrpInfo_ -> XGrpInfo <$> p "groupProfile"
|
||||
XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences"
|
||||
XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content"
|
||||
XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope"
|
||||
XGrpMsgForward_ -> XGrpMsgForward <$> p "memberId" <*> p "msg" <*> p "msgTs"
|
||||
XInfoProbe_ -> XInfoProbe <$> p "probe"
|
||||
XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash"
|
||||
@@ -1147,7 +1154,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
|
||||
params = \case
|
||||
XMsgNew container -> msgContainerJSON container
|
||||
XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr]
|
||||
XMsgUpdate msgId' content mentions ttl live scope -> o $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content]
|
||||
XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope} -> o $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content]
|
||||
XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId']
|
||||
XMsgDeleted -> JM.empty
|
||||
XMsgReact msgId' memberId reaction add -> o $ ("memberId" .=? memberId) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add]
|
||||
@@ -1178,7 +1185,7 @@ chatToAppMessage ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @
|
||||
XGrpDel -> JM.empty
|
||||
XGrpInfo p -> o ["groupProfile" .= p]
|
||||
XGrpPrefs p -> o ["groupPreferences" .= p]
|
||||
XGrpDirectInv connReq content -> o $ ("content" .=? content) ["connReq" .= connReq]
|
||||
XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq]
|
||||
XGrpMsgForward memberId msg msgTs -> o ["memberId" .= memberId, "msg" .= msg, "msgTs" .= msgTs]
|
||||
XInfoProbe probe -> o ["probe" .= probe]
|
||||
XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash]
|
||||
|
||||
@@ -192,7 +192,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
|
||||
CRSentConfirmation u _ -> ttyUser u ["confirmation sent!"]
|
||||
CRSentInvitation u _ customUserProfile -> ttyUser u $ viewSentInvitation customUserProfile testView
|
||||
CRSentInvitationToContact u _c customUserProfile -> ttyUser u $ viewSentInvitation customUserProfile testView
|
||||
CRItemsReadForChat u chatId -> ttyUser u ["items read for chat"]
|
||||
CRItemsReadForChat u _chatId -> ttyUser u ["items read for chat"]
|
||||
CRContactDeleted u c -> ttyUser u [ttyContact' c <> ": contact is deleted"]
|
||||
CRChatCleared u chatInfo -> ttyUser u $ viewChatCleared chatInfo
|
||||
CRAcceptingContactRequest u c -> ttyUser u $ viewAcceptingContactRequest c
|
||||
|
||||
@@ -195,6 +195,7 @@ chatGroupTests = do
|
||||
describe "group scoped messages" $ do
|
||||
it "should send scoped messages to support (single moderator)" testScopedSupportSingleModerator
|
||||
it "should send scoped messages to support (many moderators)" testScopedSupportManyModerators
|
||||
it "should send messages to admins and members" testSupportCLISendCommand
|
||||
it "should correctly maintain unread stats for support chats" testScopedSupportUnreadStats
|
||||
|
||||
testGroupCheckMessages :: HasCallStack => TestParams -> IO ()
|
||||
@@ -3009,7 +3010,7 @@ testGLinkApproveMember =
|
||||
alice <# "#team (support: cath) cath> proofs"
|
||||
|
||||
-- accept member
|
||||
alice ##> "/_accept member #1 3 member"
|
||||
alice ##> "/accept member #team cath"
|
||||
concurrentlyN_
|
||||
[ alice <## "#team: cath accepted",
|
||||
cath
|
||||
@@ -6980,6 +6981,27 @@ testScopedSupportManyModerators =
|
||||
cath ##> "/member support chats #team"
|
||||
cath <## "bob (Bob) (id 3): unread: 0, require attention: 0, mentions: 0"
|
||||
|
||||
testSupportCLISendCommand :: HasCallStack => TestParams -> IO ()
|
||||
testSupportCLISendCommand =
|
||||
testChat2 aliceProfile bobProfile $ \alice bob -> do
|
||||
createGroup2' "team" alice (bob, GRObserver) True
|
||||
|
||||
alice #> "#team 1"
|
||||
bob <# "#team alice> 1"
|
||||
|
||||
bob ##> "#team 2"
|
||||
bob <## "#team: you don't have permission to send messages"
|
||||
(alice </)
|
||||
|
||||
alice #> "#team (support: bob) 3"
|
||||
bob <# "#team (support) alice> 3"
|
||||
|
||||
bob #> "#team (support) 4"
|
||||
alice <# "#team (support: bob) bob> 4"
|
||||
|
||||
bob ##> "#team (support 4"
|
||||
bob <## "bad chat command: Failed reading: empty"
|
||||
|
||||
testScopedSupportUnreadStats :: HasCallStack => TestParams -> IO ()
|
||||
testScopedSupportUnreadStats =
|
||||
testChatOpts4 opts aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do
|
||||
|
||||
@@ -292,10 +292,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
||||
==# XGrpDel
|
||||
it "x.grp.direct.inv" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.direct.inv\",\"params\":{\"connReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
|
||||
#==# XGrpDirectInv testConnReq (Just $ MCText "hello")
|
||||
#==# XGrpDirectInv testConnReq (Just $ MCText "hello") Nothing
|
||||
it "x.grp.direct.inv without content" $
|
||||
"{\"v\":\"1\",\"event\":\"x.grp.direct.inv\",\"params\":{\"connReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}"
|
||||
#==# XGrpDirectInv testConnReq Nothing
|
||||
#==# XGrpDirectInv testConnReq Nothing Nothing
|
||||
-- it "x.grp.msg.forward"
|
||||
-- $ "{\"v\":\"1\",\"event\":\"x.grp.msg.forward\",\"params\":{\"msgForward\":{\"memberId\":\"AQIDBA==\",\"msg\":\"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}\",\"msgTs\":\"1970-01-01T00:00:01.000000001Z\"}}}"
|
||||
-- #==# XGrpMsgForward
|
||||
|
||||
Reference in New Issue
Block a user