mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
621b291da1
* core: member mentions, types and rfc * update * update rfc * save/get mentions (WIP) * markdown * store received mentions and userMention flag * sent mentions * update message with mentions * db queries * CLI mentions, test passes * use maps for mentions * tests * comment * save mentions on sent messages * postresql schema * refactor * M.empty * include both displayName and localAlias into MentionedMemberInfo * fix saving sent mentions * include mentions in previews * update plans
254 lines
11 KiB
Haskell
254 lines
11 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
|
|
module Directory.Events
|
|
( DirectoryEvent (..),
|
|
DirectoryCmd (..),
|
|
ADirectoryCmd (..),
|
|
DirectoryRole (..),
|
|
SDirectoryRole (..),
|
|
crDirectoryEvent,
|
|
directoryCmdTag,
|
|
viewName,
|
|
)
|
|
where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import Data.Attoparsec.Text (Parser)
|
|
import qualified Data.Attoparsec.Text as A
|
|
import Data.Char (isSpace)
|
|
import Data.Either (fromRight)
|
|
import Data.Functor (($>))
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Directory.Store
|
|
import Simplex.Chat.Controller
|
|
import Simplex.Chat.Markdown (displayNameTextP)
|
|
import Simplex.Chat.Messages
|
|
import Simplex.Chat.Messages.CIContent
|
|
import Simplex.Chat.Protocol (MsgContent (..))
|
|
import Simplex.Chat.Types
|
|
import Simplex.Chat.Types.Shared
|
|
import Simplex.Messaging.Agent.Protocol (AgentErrorType (..))
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Protocol (BrokerErrorType (..))
|
|
import Simplex.Messaging.Util (tshow, (<$?>))
|
|
|
|
data DirectoryEvent
|
|
= DEContactConnected Contact
|
|
| DEGroupInvitation {contact :: Contact, groupInfo :: GroupInfo, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
|
|
| DEServiceJoinedGroup {contactId :: ContactId, groupInfo :: GroupInfo, hostMember :: GroupMember}
|
|
| DEGroupUpdated {contactId :: ContactId, fromGroup :: GroupInfo, toGroup :: GroupInfo}
|
|
| DEContactRoleChanged GroupInfo ContactId GroupMemberRole -- contactId here is the contact whose role changed
|
|
| DEServiceRoleChanged GroupInfo GroupMemberRole
|
|
| DEContactRemovedFromGroup ContactId GroupInfo
|
|
| DEContactLeftGroup ContactId GroupInfo
|
|
| DEServiceRemovedFromGroup GroupInfo
|
|
| DEGroupDeleted GroupInfo
|
|
| DEUnsupportedMessage Contact ChatItemId
|
|
| DEItemEditIgnored Contact
|
|
| DEItemDeleteIgnored Contact
|
|
| DEContactCommand Contact ChatItemId ADirectoryCmd
|
|
| DELogChatResponse Text
|
|
deriving (Show)
|
|
|
|
crDirectoryEvent :: ChatResponse -> Maybe DirectoryEvent
|
|
crDirectoryEvent = \case
|
|
CRContactConnected {contact} -> Just $ DEContactConnected contact
|
|
CRReceivedGroupInvitation {contact, groupInfo, fromMemberRole, memberRole} -> Just $ DEGroupInvitation {contact, groupInfo, fromMemberRole, memberRole}
|
|
CRUserJoinedGroup {groupInfo, hostMember} -> (\contactId -> DEServiceJoinedGroup {contactId, groupInfo, hostMember}) <$> memberContactId hostMember
|
|
CRGroupUpdated {fromGroup, toGroup, member_} -> (\contactId -> DEGroupUpdated {contactId, fromGroup, toGroup}) <$> (memberContactId =<< member_)
|
|
CRMemberRole {groupInfo, member, toRole}
|
|
| groupMemberId' member == groupMemberId' (membership groupInfo) -> Just $ DEServiceRoleChanged groupInfo toRole
|
|
| otherwise -> (\ctId -> DEContactRoleChanged groupInfo ctId toRole) <$> memberContactId member
|
|
CRDeletedMember {groupInfo, deletedMember} -> (`DEContactRemovedFromGroup` groupInfo) <$> memberContactId deletedMember
|
|
CRLeftMember {groupInfo, member} -> (`DEContactLeftGroup` groupInfo) <$> memberContactId member
|
|
CRDeletedMemberUser {groupInfo} -> Just $ DEServiceRemovedFromGroup groupInfo
|
|
CRGroupDeleted {groupInfo} -> Just $ DEGroupDeleted groupInfo
|
|
CRChatItemUpdated {chatItem = AChatItem _ SMDRcv (DirectChat ct) _} -> Just $ DEItemEditIgnored ct
|
|
CRChatItemsDeleted {chatItemDeletions = ((ChatItemDeletion (AChatItem _ SMDRcv (DirectChat ct) _) _) : _), byUser = False} -> Just $ DEItemDeleteIgnored ct
|
|
CRNewChatItems {chatItems = (AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc, meta = CIMeta {itemLive}}) : _} ->
|
|
Just $ case (mc, itemLive) of
|
|
(MCText t, Nothing) -> DEContactCommand ct ciId $ fromRight err $ A.parseOnly (directoryCmdP <* A.endOfInput) $ T.dropWhileEnd isSpace t
|
|
_ -> DEUnsupportedMessage ct ciId
|
|
where
|
|
ciId = chatItemId' ci
|
|
err = ADC SDRUser DCUnknownCommand
|
|
CRMessageError {severity, errorMessage} -> Just $ DELogChatResponse $ "message error: " <> severity <> ", " <> errorMessage
|
|
CRChatCmdError {chatError} -> Just $ DELogChatResponse $ "chat cmd error: " <> tshow chatError
|
|
CRChatError {chatError} -> case chatError of
|
|
ChatErrorAgent {agentError = BROKER _ NETWORK} -> Nothing
|
|
ChatErrorAgent {agentError = BROKER _ TIMEOUT} -> Nothing
|
|
_ -> Just $ DELogChatResponse $ "chat error: " <> tshow chatError
|
|
CRChatErrors {chatErrors} -> Just $ DELogChatResponse $ "chat errors: " <> T.intercalate ", " (map tshow chatErrors)
|
|
_ -> Nothing
|
|
|
|
data DirectoryRole = DRUser | DRAdmin | DRSuperUser
|
|
|
|
data SDirectoryRole (r :: DirectoryRole) where
|
|
SDRUser :: SDirectoryRole 'DRUser
|
|
SDRAdmin :: SDirectoryRole 'DRAdmin
|
|
SDRSuperUser :: SDirectoryRole 'DRSuperUser
|
|
|
|
deriving instance Show (SDirectoryRole r)
|
|
|
|
data DirectoryCmdTag (r :: DirectoryRole) where
|
|
DCHelp_ :: DirectoryCmdTag 'DRUser
|
|
DCSearchNext_ :: DirectoryCmdTag 'DRUser
|
|
DCAllGroups_ :: DirectoryCmdTag 'DRUser
|
|
DCRecentGroups_ :: DirectoryCmdTag 'DRUser
|
|
DCSubmitGroup_ :: DirectoryCmdTag 'DRUser
|
|
DCConfirmDuplicateGroup_ :: DirectoryCmdTag 'DRUser
|
|
DCListUserGroups_ :: DirectoryCmdTag 'DRUser
|
|
DCDeleteGroup_ :: DirectoryCmdTag 'DRUser
|
|
DCSetRole_ :: DirectoryCmdTag 'DRUser
|
|
DCApproveGroup_ :: DirectoryCmdTag 'DRAdmin
|
|
DCRejectGroup_ :: DirectoryCmdTag 'DRAdmin
|
|
DCSuspendGroup_ :: DirectoryCmdTag 'DRAdmin
|
|
DCResumeGroup_ :: DirectoryCmdTag 'DRAdmin
|
|
DCListLastGroups_ :: DirectoryCmdTag 'DRAdmin
|
|
DCListPendingGroups_ :: DirectoryCmdTag 'DRAdmin
|
|
DCShowGroupLink_ :: DirectoryCmdTag 'DRAdmin
|
|
DCSendToGroupOwner_ :: DirectoryCmdTag 'DRAdmin
|
|
DCInviteOwnerToGroup_ :: DirectoryCmdTag 'DRAdmin
|
|
DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser
|
|
|
|
deriving instance Show (DirectoryCmdTag r)
|
|
|
|
data ADirectoryCmdTag = forall r. ADCT (SDirectoryRole r) (DirectoryCmdTag r)
|
|
|
|
data DirectoryCmd (r :: DirectoryRole) where
|
|
DCHelp :: DirectoryCmd 'DRUser
|
|
DCSearchGroup :: Text -> DirectoryCmd 'DRUser
|
|
DCSearchNext :: DirectoryCmd 'DRUser
|
|
DCAllGroups :: DirectoryCmd 'DRUser
|
|
DCRecentGroups :: DirectoryCmd 'DRUser
|
|
DCSubmitGroup :: ConnReqContact -> DirectoryCmd 'DRUser
|
|
DCConfirmDuplicateGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
|
|
DCListUserGroups :: DirectoryCmd 'DRUser
|
|
DCDeleteGroup :: UserGroupRegId -> GroupName -> DirectoryCmd 'DRUser
|
|
DCSetRole :: GroupId -> GroupName -> GroupMemberRole -> DirectoryCmd 'DRUser
|
|
DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRAdmin
|
|
DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
|
|
DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
|
|
DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
|
|
DCListLastGroups :: Int -> DirectoryCmd 'DRAdmin
|
|
DCListPendingGroups :: Int -> DirectoryCmd 'DRAdmin
|
|
DCShowGroupLink :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
|
|
DCSendToGroupOwner :: GroupId -> GroupName -> Text -> DirectoryCmd 'DRAdmin
|
|
DCInviteOwnerToGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin
|
|
DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser
|
|
DCUnknownCommand :: DirectoryCmd 'DRUser
|
|
DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r
|
|
|
|
deriving instance Show (DirectoryCmd r)
|
|
|
|
data ADirectoryCmd = forall r. ADC (SDirectoryRole r) (DirectoryCmd r)
|
|
|
|
deriving instance Show ADirectoryCmd
|
|
|
|
directoryCmdP :: Parser ADirectoryCmd
|
|
directoryCmdP =
|
|
(A.char '/' *> cmdStrP)
|
|
<|> (A.char '.' $> ADC SDRUser DCSearchNext)
|
|
<|> (ADC SDRUser . DCSearchGroup <$> A.takeText)
|
|
where
|
|
cmdStrP =
|
|
(tagP >>= \(ADCT u t) -> ADC u <$> (cmdP t <|> pure (DCCommandError t)))
|
|
<|> pure (ADC SDRUser DCUnknownCommand)
|
|
tagP =
|
|
A.takeTill (== ' ') >>= \case
|
|
"help" -> u DCHelp_
|
|
"h" -> u DCHelp_
|
|
"next" -> u DCSearchNext_
|
|
"all" -> u DCAllGroups_
|
|
"new" -> u DCRecentGroups_
|
|
"submit" -> u DCSubmitGroup_
|
|
"confirm" -> u DCConfirmDuplicateGroup_
|
|
"list" -> u DCListUserGroups_
|
|
"ls" -> u DCListUserGroups_
|
|
"delete" -> u DCDeleteGroup_
|
|
"role" -> u DCSetRole_
|
|
"approve" -> au DCApproveGroup_
|
|
"reject" -> au DCRejectGroup_
|
|
"suspend" -> au DCSuspendGroup_
|
|
"resume" -> au DCResumeGroup_
|
|
"last" -> au DCListLastGroups_
|
|
"pending" -> au DCListPendingGroups_
|
|
"link" -> au DCShowGroupLink_
|
|
"owner" -> au DCSendToGroupOwner_
|
|
"invite" -> au DCInviteOwnerToGroup_
|
|
"exec" -> su DCExecuteCommand_
|
|
"x" -> su DCExecuteCommand_
|
|
_ -> fail "bad command tag"
|
|
where
|
|
u = pure . ADCT SDRUser
|
|
au = pure . ADCT SDRAdmin
|
|
su = pure . ADCT SDRSuperUser
|
|
cmdP :: DirectoryCmdTag r -> Parser (DirectoryCmd r)
|
|
cmdP = \case
|
|
DCHelp_ -> pure DCHelp
|
|
DCSearchNext_ -> pure DCSearchNext
|
|
DCAllGroups_ -> pure DCAllGroups
|
|
DCRecentGroups_ -> pure DCRecentGroups
|
|
DCSubmitGroup_ -> fmap DCSubmitGroup . strDecode . encodeUtf8 <$?> (A.takeWhile1 isSpace *> A.takeText)
|
|
DCConfirmDuplicateGroup_ -> gc DCConfirmDuplicateGroup
|
|
DCListUserGroups_ -> pure DCListUserGroups
|
|
DCDeleteGroup_ -> gc DCDeleteGroup
|
|
DCSetRole_ -> do
|
|
(groupId, displayName) <- gc (,)
|
|
memberRole <- A.space *> ("member" $> GRMember <|> "observer" $> GRObserver)
|
|
pure $ DCSetRole groupId displayName memberRole
|
|
DCApproveGroup_ -> do
|
|
(groupId, displayName) <- gc (,)
|
|
groupApprovalId <- A.space *> A.decimal
|
|
pure DCApproveGroup {groupId, displayName, groupApprovalId}
|
|
DCRejectGroup_ -> gc DCRejectGroup
|
|
DCSuspendGroup_ -> gc DCSuspendGroup
|
|
DCResumeGroup_ -> gc DCResumeGroup
|
|
DCListLastGroups_ -> DCListLastGroups <$> (A.space *> A.decimal <|> pure 10)
|
|
DCListPendingGroups_ -> DCListPendingGroups <$> (A.space *> A.decimal <|> pure 10)
|
|
DCShowGroupLink_ -> gc DCShowGroupLink
|
|
DCSendToGroupOwner_ -> do
|
|
(groupId, displayName) <- gc (,)
|
|
msg <- A.space *> A.takeText
|
|
pure $ DCSendToGroupOwner groupId displayName msg
|
|
DCInviteOwnerToGroup_ -> gc DCInviteOwnerToGroup
|
|
DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (A.space *> A.takeText)
|
|
where
|
|
gc f = f <$> (A.space *> A.decimal <* A.char ':') <*> displayNameTextP
|
|
|
|
viewName :: Text -> Text
|
|
viewName n = if any (== ' ') (T.unpack n) then "'" <> n <> "'" else n
|
|
|
|
directoryCmdTag :: DirectoryCmd r -> Text
|
|
directoryCmdTag = \case
|
|
DCHelp -> "help"
|
|
DCSearchGroup _ -> "search"
|
|
DCSearchNext -> "next"
|
|
DCAllGroups -> "all"
|
|
DCRecentGroups -> "new"
|
|
DCSubmitGroup _ -> "submit"
|
|
DCConfirmDuplicateGroup {} -> "confirm"
|
|
DCListUserGroups -> "list"
|
|
DCDeleteGroup {} -> "delete"
|
|
DCApproveGroup {} -> "approve"
|
|
DCSetRole {} -> "role"
|
|
DCRejectGroup {} -> "reject"
|
|
DCSuspendGroup {} -> "suspend"
|
|
DCResumeGroup {} -> "resume"
|
|
DCListLastGroups _ -> "last"
|
|
DCListPendingGroups _ -> "pending"
|
|
DCShowGroupLink {} -> "link"
|
|
DCSendToGroupOwner {} -> "owner"
|
|
DCInviteOwnerToGroup {} -> "invite"
|
|
DCExecuteCommand _ -> "exec"
|
|
DCUnknownCommand -> "unknown"
|
|
DCCommandError _ -> "error"
|