core: support observers send messages to admins, CLI commands (#5921)

* core: allow observers send messages to admins * improve parser, CLI command to approve members
2026-06-04 12:31:46 +00:00 · 2025-05-19 11:14:43 +01:00
parent 98f35a38e8
commit a2577c3df3
8 changed files with 112 additions and 45 deletions
@@ -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