mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: additional group preferences: prohibit SimpleX links, restrict some features to specific roles (#3964)
* core: additional group preferences: prohibit SimpleX links, restrict some features to specific roles * add role to group preference items, tests
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
069395c2a0
commit
18efc28d16
20 changed files with 384 additions and 109 deletions
|
|
@ -31,6 +31,7 @@ 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.Encoding.String
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
import Data.Char (isSpace)
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@ import Simplex.Chat.Messages
|
|||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Protocol (MsgContent (..))
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.View (serializeChatResponse, simplexChatContact)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
|
|
|
|||
|
|
@ -174,6 +174,7 @@ library
|
|||
Simplex.Chat.Terminal.Output
|
||||
Simplex.Chat.Types
|
||||
Simplex.Chat.Types.Preferences
|
||||
Simplex.Chat.Types.Shared
|
||||
Simplex.Chat.Types.Util
|
||||
Simplex.Chat.Util
|
||||
Simplex.Chat.View
|
||||
|
|
|
|||
|
|
@ -80,6 +80,7 @@ import Simplex.Chat.Store.Profiles
|
|||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Chat.Util (encryptFile, shuffle)
|
||||
import Simplex.FileTransfer.Client.Main (maxFileSize, maxFileSizeHard)
|
||||
|
|
@ -748,10 +749,10 @@ processChatCommand' vr = \case
|
|||
assertUserGroupRole gInfo GRAuthor
|
||||
send g
|
||||
where
|
||||
send g@(Group gInfo@GroupInfo {groupId} ms)
|
||||
| isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice
|
||||
| not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles
|
||||
| otherwise = do
|
||||
send g@(Group gInfo@GroupInfo {groupId, membership} ms) =
|
||||
case prohibitedGroupContent gInfo membership mc file_ of
|
||||
Just f -> notAllowedError f
|
||||
Nothing -> do
|
||||
(fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer g (length $ filter memberCurrent ms)
|
||||
timed_ <- sndGroupCITimed live gInfo itemTTL
|
||||
(msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ fInv_ timed_ live
|
||||
|
|
@ -1587,8 +1588,9 @@ processChatCommand' vr = \case
|
|||
let mc = MCText msg
|
||||
case memberContactId m of
|
||||
Nothing -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user gId
|
||||
toView $ CRNoMemberContactCreating user gInfo m
|
||||
g <- withStore $ \db -> getGroupInfo db vr user gId
|
||||
unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed"
|
||||
toView $ CRNoMemberContactCreating user g m
|
||||
processChatCommand (APICreateMemberContact gId mId) >>= \case
|
||||
cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do
|
||||
toView cr
|
||||
|
|
@ -1872,7 +1874,7 @@ processChatCommand' vr = \case
|
|||
APICreateMemberContact gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db vr user gId gMemberId
|
||||
assertUserGroupRole g GRAuthor
|
||||
unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed"
|
||||
unless (groupFeatureMemberAllowed SGFDirectMessages (membership g) g) $ throwChatError $ CECommandError "direct messages not allowed"
|
||||
case memberConn m of
|
||||
Just mConn@Connection {peerChatVRange} -> do
|
||||
unless (maxVersion peerChatVRange >= groupDirectInvVersion) $ throwChatError CEPeerChatVRangeIncompatible
|
||||
|
|
@ -2053,9 +2055,12 @@ processChatCommand' vr = \case
|
|||
ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db vr user cName
|
||||
let prefs' = setPreference f allowed_ $ Just userPreferences
|
||||
updateContactPrefs user ct prefs'
|
||||
SetGroupFeature (AGF f) gName enabled ->
|
||||
SetGroupFeature (AGFNR f) gName enabled ->
|
||||
updateGroupProfileByName gName $ \p ->
|
||||
p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p}
|
||||
SetGroupFeatureRole (AGFR f) gName enabled role ->
|
||||
updateGroupProfileByName gName $ \p ->
|
||||
p {groupPreferences = Just . setGroupPreferenceRole f enabled role $ groupPreferences p}
|
||||
SetUserTimedMessages onOff -> withUser $ \user@User {profile} -> do
|
||||
let allowed = if onOff then FAYes else FANo
|
||||
pref = TimedMessagesPreference allowed Nothing
|
||||
|
|
@ -2645,7 +2650,7 @@ assertDirectAllowed user dir ct event =
|
|||
unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $
|
||||
throwChatError (CEDirectMessagesProhibited dir ct)
|
||||
where
|
||||
directMessagesAllowed = any (groupFeatureAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct)
|
||||
directMessagesAllowed = any (uncurry $ groupFeatureMemberAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct)
|
||||
allowedChatEvent = case event of
|
||||
XMsgNew_ -> False
|
||||
XMsgUpdate_ -> False
|
||||
|
|
@ -2655,6 +2660,13 @@ assertDirectAllowed user dir ct event =
|
|||
XCallInv_ -> False
|
||||
_ -> True
|
||||
|
||||
prohibitedGroupContent :: GroupInfo -> GroupMember -> MsgContent -> Maybe f -> Maybe GroupFeature
|
||||
prohibitedGroupContent gInfo m mc file_
|
||||
| isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) = Just GFVoice
|
||||
| not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles
|
||||
| not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo) && containsFormat isSimplexLink (parseMarkdown $ msgContentText mc) = Just GFSimplexLinks
|
||||
| otherwise = Nothing
|
||||
|
||||
roundedFDCount :: Int -> Int
|
||||
roundedFDCount n
|
||||
| n <= 0 = 4
|
||||
|
|
@ -4739,14 +4751,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM ()
|
||||
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded
|
||||
| blockedByAdmin m = createBlockedByAdmin
|
||||
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
|
||||
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
|
||||
| otherwise =
|
||||
withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
|
||||
Nothing -> createContentItem
|
||||
| otherwise = case prohibitedGroupContent gInfo m content fInv_ of
|
||||
Just f -> rejected f
|
||||
Nothing ->
|
||||
withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
|
||||
Nothing -> createContentItem
|
||||
where
|
||||
rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False
|
||||
timed' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo itemTTL
|
||||
|
|
@ -5189,8 +5201,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
createGroupFeatureItems g@GroupInfo {fullGroupPreferences} m =
|
||||
forM_ allGroupFeatures $ \(AGF f) -> do
|
||||
let p = getGroupPreference f fullGroupPreferences
|
||||
(_, param) = groupFeatureState p
|
||||
createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing
|
||||
(_, param, role) = groupFeatureState p
|
||||
createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param role) Nothing
|
||||
|
||||
xInfoProbe :: ContactOrMember -> Probe -> CM ()
|
||||
xInfoProbe cgm2 probe = do
|
||||
|
|
@ -5701,7 +5713,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
|
||||
xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> CM ()
|
||||
xGrpDirectInv g m mConn connReq mContent_ msg brokerTs = do
|
||||
unless (groupFeatureAllowed SGFDirectMessages g) $ messageError "x.grp.direct.inv: direct messages not allowed"
|
||||
unless (groupFeatureMemberAllowed SGFDirectMessages m g) $ messageError "x.grp.direct.inv: direct messages not allowed"
|
||||
let GroupMember {memberContactId} = m
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
case memberContactId of
|
||||
|
|
@ -6681,14 +6693,14 @@ createContactsFeatureItems user cts chatDir ciFeature ciOffer getPref = do
|
|||
cup = getContactUserPreference f cups
|
||||
cup' = getContactUserPreference f cups'
|
||||
|
||||
createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> CIContent d) -> GroupInfo -> GroupInfo -> CM ()
|
||||
createGroupFeatureChangedItems :: MsgDirectionI d => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent d) -> GroupInfo -> GroupInfo -> CM ()
|
||||
createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} =
|
||||
forM_ allGroupFeatures $ \(AGF f) -> do
|
||||
let state = groupFeatureState $ getGroupPreference f gps
|
||||
pref' = getGroupPreference f gps'
|
||||
state'@(_, int') = groupFeatureState pref'
|
||||
state'@(_, param', role') = groupFeatureState pref'
|
||||
when (state /= state') $
|
||||
createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') int') Nothing
|
||||
createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') param' role') Nothing
|
||||
|
||||
sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool
|
||||
sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing}
|
||||
|
|
@ -7046,20 +7058,22 @@ chatCommandP =
|
|||
"/show profile image" $> ShowProfileImage,
|
||||
("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> profileNames),
|
||||
("/profile" <|> "/p") $> ShowProfile,
|
||||
"/set voice #" *> (SetGroupFeature (AGF SGFVoice) <$> displayName <*> (A.space *> strP)),
|
||||
"/set voice #" *> (SetGroupFeatureRole (AGFR SGFVoice) <$> displayName <*> _strP <*> optional memberRole),
|
||||
"/set voice @" *> (SetContactFeature (ACF SCFVoice) <$> displayName <*> optional (A.space *> strP)),
|
||||
"/set voice " *> (SetUserFeature (ACF SCFVoice) <$> strP),
|
||||
"/set files #" *> (SetGroupFeature (AGF SGFFiles) <$> displayName <*> (A.space *> strP)),
|
||||
"/set history #" *> (SetGroupFeature (AGF SGFHistory) <$> displayName <*> (A.space *> strP)),
|
||||
"/set files #" *> (SetGroupFeatureRole (AGFR SGFFiles) <$> displayName <*> _strP <*> optional memberRole),
|
||||
"/set history #" *> (SetGroupFeature (AGFNR SGFHistory) <$> displayName <*> (A.space *> strP)),
|
||||
"/set reactions #" *> (SetGroupFeature (AGFNR SGFReactions) <$> displayName <*> (A.space *> strP)),
|
||||
"/set calls @" *> (SetContactFeature (ACF SCFCalls) <$> displayName <*> optional (A.space *> strP)),
|
||||
"/set calls " *> (SetUserFeature (ACF SCFCalls) <$> strP),
|
||||
"/set delete #" *> (SetGroupFeature (AGF SGFFullDelete) <$> displayName <*> (A.space *> strP)),
|
||||
"/set delete #" *> (SetGroupFeature (AGFNR SGFFullDelete) <$> displayName <*> (A.space *> strP)),
|
||||
"/set delete @" *> (SetContactFeature (ACF SCFFullDelete) <$> displayName <*> optional (A.space *> strP)),
|
||||
"/set delete " *> (SetUserFeature (ACF SCFFullDelete) <$> strP),
|
||||
"/set direct #" *> (SetGroupFeature (AGF SGFDirectMessages) <$> displayName <*> (A.space *> strP)),
|
||||
"/set direct #" *> (SetGroupFeatureRole (AGFR SGFDirectMessages) <$> displayName <*> _strP <*> optional memberRole),
|
||||
"/set disappear #" *> (SetGroupTimedMessages <$> displayName <*> (A.space *> timedTTLOnOffP)),
|
||||
"/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)),
|
||||
"/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))),
|
||||
"/set links #" *> (SetGroupFeatureRole (AGFR SGFSimplexLinks) <$> displayName <*> _strP <*> optional memberRole),
|
||||
("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito,
|
||||
"/set device name " *> (SetLocalDeviceName <$> textP),
|
||||
"/list remote hosts" $> ListRemoteHosts,
|
||||
|
|
@ -7147,7 +7161,7 @@ chatCommandP =
|
|||
let groupPreferences =
|
||||
Just
|
||||
(emptyGroupPrefs :: GroupPreferences)
|
||||
{ directMessages = Just DirectMessagesGroupPreference {enable = FEOn},
|
||||
{ directMessages = Just DirectMessagesGroupPreference {enable = FEOn, role = Nothing},
|
||||
history = Just HistoryGroupPreference {enable = FEOn}
|
||||
}
|
||||
pure GroupProfile {displayName = gName, fullName, description = Nothing, image = Nothing, groupPreferences}
|
||||
|
|
|
|||
|
|
@ -62,6 +62,7 @@ import Simplex.Chat.Remote.Types
|
|||
import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserContactLink, UserMsgReceiptSettings)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Util (liftIOEither)
|
||||
import Simplex.FileTransfer.Description (FileDescriptionURI)
|
||||
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
|
||||
|
|
@ -461,7 +462,8 @@ data ChatCommand
|
|||
| ShowProfileImage
|
||||
| SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI)
|
||||
| SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)
|
||||
| SetGroupFeature AGroupFeature GroupName GroupFeatureEnabled
|
||||
| SetGroupFeature AGroupFeatureNoRole GroupName GroupFeatureEnabled
|
||||
| SetGroupFeatureRole AGroupFeatureRole GroupName GroupFeatureEnabled (Maybe GroupMemberRole)
|
||||
| SetUserTimedMessages Bool -- UserId (not used in UI)
|
||||
| SetContactTimedMessages ContactName (Maybe TimedMessagesEnabled)
|
||||
| SetGroupTimedMessages GroupName (Maybe Int)
|
||||
|
|
|
|||
|
|
@ -144,6 +144,15 @@ markdownToList (m1 :|: m2) = markdownToList m1 <> markdownToList m2
|
|||
parseMarkdown :: Text -> Markdown
|
||||
parseMarkdown s = fromRight (unmarked s) $ A.parseOnly (markdownP <* A.endOfInput) s
|
||||
|
||||
containsFormat :: (Format -> Bool) -> Markdown -> Bool
|
||||
containsFormat p (Markdown f _) = maybe False p f
|
||||
containsFormat p (m1 :|: m2) = containsFormat p m1 || containsFormat p m2
|
||||
|
||||
isSimplexLink :: Format -> Bool
|
||||
isSimplexLink = \case
|
||||
SimplexLink {} -> True;
|
||||
_ -> False
|
||||
|
||||
markdownP :: Parser Markdown
|
||||
markdownP = mconcat <$> A.many' fragmentP
|
||||
where
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ import Simplex.Chat.Messages.CIContent.Events
|
|||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Messaging.Agent.Protocol (MsgErrorType (..), RatchetSyncState (..), SwitchPhase (..))
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption, pattern PQEncOn, pattern PQEncOff)
|
||||
|
|
@ -134,8 +135,8 @@ data CIContent (d :: MsgDirection) where
|
|||
CISndChatFeature :: ChatFeature -> PrefEnabled -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvChatPreference :: ChatFeature -> FeatureAllowed -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndChatPreference :: ChatFeature -> FeatureAllowed -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDRcv
|
||||
CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDSnd
|
||||
CIRcvGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent 'MDRcv
|
||||
CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> Maybe GroupMemberRole -> CIContent 'MDSnd
|
||||
CIRcvChatFeatureRejected :: ChatFeature -> CIContent 'MDRcv
|
||||
CIRcvGroupFeatureRejected :: GroupFeature -> CIContent 'MDRcv
|
||||
CISndModerated :: CIContent 'MDSnd
|
||||
|
|
@ -255,8 +256,8 @@ ciContentToText = \case
|
|||
CISndChatFeature feature enabled param -> featureStateText feature enabled param
|
||||
CIRcvChatPreference feature allowed param -> prefStateText feature allowed param
|
||||
CISndChatPreference feature allowed param -> "you " <> prefStateText feature allowed param
|
||||
CIRcvGroupFeature feature pref param -> groupPrefStateText feature pref param
|
||||
CISndGroupFeature feature pref param -> groupPrefStateText feature pref param
|
||||
CIRcvGroupFeature feature pref param role -> groupPrefStateText feature pref param role
|
||||
CISndGroupFeature feature pref param role -> groupPrefStateText feature pref param role
|
||||
CIRcvChatFeatureRejected feature -> chatFeatureNameText feature <> ": received, prohibited"
|
||||
CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited"
|
||||
CISndModerated -> ciModeratedText
|
||||
|
|
@ -413,8 +414,8 @@ data JSONCIContent
|
|||
| JCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| JCIRcvChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| JCISndChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| JCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| JCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int, memberRole_ :: Maybe GroupMemberRole}
|
||||
| JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int, memberRole_ :: Maybe GroupMemberRole}
|
||||
| JCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| JCISndModerated
|
||||
|
|
@ -447,8 +448,8 @@ jsonCIContent = \case
|
|||
CISndChatFeature feature enabled param -> JCISndChatFeature {feature, enabled, param}
|
||||
CIRcvChatPreference feature allowed param -> JCIRcvChatPreference {feature, allowed, param}
|
||||
CISndChatPreference feature allowed param -> JCISndChatPreference {feature, allowed, param}
|
||||
CIRcvGroupFeature groupFeature preference param -> JCIRcvGroupFeature {groupFeature, preference, param}
|
||||
CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvGroupFeature groupFeature preference param memberRole_ -> JCIRcvGroupFeature {groupFeature, preference, param, memberRole_}
|
||||
CISndGroupFeature groupFeature preference param memberRole_ -> JCISndGroupFeature {groupFeature, preference, param, memberRole_}
|
||||
CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> JCISndModerated
|
||||
|
|
@ -481,8 +482,8 @@ aciContentJSON = \case
|
|||
JCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param
|
||||
JCIRcvChatPreference {feature, allowed, param} -> ACIContent SMDRcv $ CIRcvChatPreference feature allowed param
|
||||
JCISndChatPreference {feature, allowed, param} -> ACIContent SMDSnd $ CISndChatPreference feature allowed param
|
||||
JCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param
|
||||
JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
JCIRcvGroupFeature {groupFeature, preference, param, memberRole_} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param memberRole_
|
||||
JCISndGroupFeature {groupFeature, preference, param, memberRole_} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param memberRole_
|
||||
JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
JCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
|
|
@ -516,8 +517,8 @@ data DBJSONCIContent
|
|||
| DBJCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int}
|
||||
| DBJCIRcvChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| DBJCISndChatPreference {feature :: ChatFeature, allowed :: FeatureAllowed, param :: Maybe Int}
|
||||
| DBJCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
|
||||
| DBJCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int, memberRole_ :: Maybe GroupMemberRole}
|
||||
| DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int, memberRole_ :: Maybe GroupMemberRole}
|
||||
| DBJCIRcvChatFeatureRejected {feature :: ChatFeature}
|
||||
| DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
|
||||
| DBJCISndModerated
|
||||
|
|
@ -550,8 +551,8 @@ dbJsonCIContent = \case
|
|||
CISndChatFeature feature enabled param -> DBJCISndChatFeature {feature, enabled, param}
|
||||
CIRcvChatPreference feature allowed param -> DBJCIRcvChatPreference {feature, allowed, param}
|
||||
CISndChatPreference feature allowed param -> DBJCISndChatPreference {feature, allowed, param}
|
||||
CIRcvGroupFeature groupFeature preference param -> DBJCIRcvGroupFeature {groupFeature, preference, param}
|
||||
CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param}
|
||||
CIRcvGroupFeature groupFeature preference param memberRole_ -> DBJCIRcvGroupFeature {groupFeature, preference, param, memberRole_}
|
||||
CISndGroupFeature groupFeature preference param memberRole_ -> DBJCISndGroupFeature {groupFeature, preference, param, memberRole_}
|
||||
CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature}
|
||||
CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature}
|
||||
CISndModerated -> DBJCISndModerated
|
||||
|
|
@ -584,8 +585,8 @@ aciContentDBJSON = \case
|
|||
DBJCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param
|
||||
DBJCIRcvChatPreference {feature, allowed, param} -> ACIContent SMDRcv $ CIRcvChatPreference feature allowed param
|
||||
DBJCISndChatPreference {feature, allowed, param} -> ACIContent SMDSnd $ CISndChatPreference feature allowed param
|
||||
DBJCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param
|
||||
DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
|
||||
DBJCIRcvGroupFeature {groupFeature, preference, param, memberRole_} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param memberRole_
|
||||
DBJCISndGroupFeature {groupFeature, preference, param, memberRole_} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param memberRole_
|
||||
DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
|
||||
DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
|
||||
DBJCISndModerated -> ACIContent SMDSnd CISndModerated
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ module Simplex.Chat.Messages.CIContent.Events where
|
|||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Aeson.TH as J
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol (RatchetSyncState (..), SwitchPhase (..))
|
||||
import Simplex.Messaging.Parsers (dropPrefix, singleFieldJSON, sumTypeJSON)
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption)
|
||||
|
|
|
|||
|
|
@ -45,6 +45,7 @@ import Database.SQLite.Simple.FromField (FromField (..))
|
|||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion)
|
||||
import Simplex.Messaging.Compression (compress1, decompressBatch)
|
||||
|
|
|
|||
|
|
@ -124,6 +124,7 @@ import Control.Monad
|
|||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Bifunctor (second)
|
||||
import Data.Either (rights)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (partition, sortOn)
|
||||
|
|
@ -139,6 +140,7 @@ import Simplex.Chat.Store.Direct
|
|||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
|
|
@ -668,13 +670,13 @@ getGroupSummary db User {userId} groupId = do
|
|||
(userId, groupId, GSMemRemoved, GSMemLeft, GSMemUnknown, GSMemInvited)
|
||||
pure GroupSummary {currentMembers = fromMaybe 0 currentMembers_}
|
||||
|
||||
getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [FullGroupPreferences]
|
||||
getContactGroupPreferences :: DB.Connection -> User -> Contact -> IO [(GroupMemberRole, FullGroupPreferences)]
|
||||
getContactGroupPreferences db User {userId} Contact {contactId} = do
|
||||
map (mergeGroupPreferences . fromOnly)
|
||||
map (second mergeGroupPreferences)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT gp.preferences
|
||||
SELECT m.member_role, gp.preferences
|
||||
FROM groups g
|
||||
JOIN group_profiles gp USING (group_profile_id)
|
||||
JOIN group_members m USING (group_id)
|
||||
|
|
|
|||
|
|
@ -81,6 +81,7 @@ import Simplex.Chat.Store.Direct
|
|||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
|
|
|
|||
|
|
@ -30,7 +30,6 @@ import qualified Data.Aeson.TH as JQ
|
|||
import qualified Data.Aeson.Types as JT
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString, pack, unpack)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
|
|
@ -45,6 +44,7 @@ import Database.SQLite.Simple.Internal (Field (..))
|
|||
import Database.SQLite.Simple.Ok
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.FileTransfer.Description (FileDigest)
|
||||
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, RcvFileId, SAEntity (..), SndFileId, UserId)
|
||||
|
|
@ -439,9 +439,13 @@ featureAllowed feature forWhom Contact {mergedPreferences} =
|
|||
let ContactUserPreference {enabled} = getContactUserPreference feature mergedPreferences
|
||||
in forWhom enabled
|
||||
|
||||
groupFeatureAllowed :: GroupFeatureI f => SGroupFeature f -> GroupInfo -> Bool
|
||||
groupFeatureAllowed :: GroupFeatureNoRoleI f => SGroupFeature f -> GroupInfo -> Bool
|
||||
groupFeatureAllowed feature gInfo = groupFeatureAllowed' feature $ fullGroupPreferences gInfo
|
||||
|
||||
groupFeatureMemberAllowed :: GroupFeatureRoleI f => SGroupFeature f -> GroupMember -> GroupInfo -> Bool
|
||||
groupFeatureMemberAllowed feature GroupMember {memberRole} =
|
||||
groupFeatureMemberAllowed' feature memberRole . fullGroupPreferences
|
||||
|
||||
mergeUserChatPrefs :: User -> Contact -> FullPreferences
|
||||
mergeUserChatPrefs user ct = mergeUserChatPrefs' user (contactConnIncognito ct) (userPreferences ct)
|
||||
|
||||
|
|
@ -796,41 +800,6 @@ fromInvitedBy userCtId = \case
|
|||
IBContact ctId -> Just ctId
|
||||
IBUser -> Just userCtId
|
||||
|
||||
data GroupMemberRole
|
||||
= GRObserver -- connects to all group members and receives all messages, can't send messages
|
||||
| GRAuthor -- reserved, unused
|
||||
| GRMember -- + can send messages to all group members
|
||||
| GRAdmin -- + add/remove members, change member role (excl. Owners)
|
||||
| GROwner -- + delete and change group information, add/remove/change roles for Owners
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance FromField GroupMemberRole where fromField = fromBlobField_ strDecode
|
||||
|
||||
instance ToField GroupMemberRole where toField = toField . strEncode
|
||||
|
||||
instance StrEncoding GroupMemberRole where
|
||||
strEncode = \case
|
||||
GROwner -> "owner"
|
||||
GRAdmin -> "admin"
|
||||
GRMember -> "member"
|
||||
GRAuthor -> "author"
|
||||
GRObserver -> "observer"
|
||||
strDecode = \case
|
||||
"owner" -> Right GROwner
|
||||
"admin" -> Right GRAdmin
|
||||
"member" -> Right GRMember
|
||||
"author" -> Right GRAuthor
|
||||
"observer" -> Right GRObserver
|
||||
r -> Left $ "bad GroupMemberRole " <> B.unpack r
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
|
||||
instance FromJSON GroupMemberRole where
|
||||
parseJSON = strParseJSON "GroupMemberRole"
|
||||
|
||||
instance ToJSON GroupMemberRole where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data GroupMemberSettings = GroupMemberSettings
|
||||
{ showMessages :: Bool
|
||||
}
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
|
|
@ -31,6 +32,7 @@ import qualified Data.Text as T
|
|||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Records.Compat
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_, sumTypeJSON)
|
||||
|
|
@ -148,6 +150,7 @@ data GroupFeature
|
|||
| GFReactions
|
||||
| GFVoice
|
||||
| GFFiles
|
||||
| GFSimplexLinks
|
||||
| GFHistory
|
||||
deriving (Show)
|
||||
|
||||
|
|
@ -158,14 +161,23 @@ data SGroupFeature (f :: GroupFeature) where
|
|||
SGFReactions :: SGroupFeature 'GFReactions
|
||||
SGFVoice :: SGroupFeature 'GFVoice
|
||||
SGFFiles :: SGroupFeature 'GFFiles
|
||||
SGFSimplexLinks :: SGroupFeature 'GFSimplexLinks
|
||||
SGFHistory :: SGroupFeature 'GFHistory
|
||||
|
||||
deriving instance Show (SGroupFeature f)
|
||||
|
||||
data AGroupFeature = forall f. GroupFeatureI f => AGF (SGroupFeature f)
|
||||
|
||||
data AGroupFeatureNoRole = forall f. GroupFeatureNoRoleI f => AGFNR (SGroupFeature f)
|
||||
|
||||
data AGroupFeatureRole = forall f. GroupFeatureRoleI f => AGFR (SGroupFeature f)
|
||||
|
||||
deriving instance Show AGroupFeature
|
||||
|
||||
deriving instance Show AGroupFeatureNoRole
|
||||
|
||||
deriving instance Show AGroupFeatureRole
|
||||
|
||||
groupFeatureNameText :: GroupFeature -> Text
|
||||
groupFeatureNameText = \case
|
||||
GFTimedMessages -> "Disappearing messages"
|
||||
|
|
@ -174,15 +186,21 @@ groupFeatureNameText = \case
|
|||
GFReactions -> "Message reactions"
|
||||
GFVoice -> "Voice messages"
|
||||
GFFiles -> "Files and media"
|
||||
GFSimplexLinks -> "SimpleX links"
|
||||
GFHistory -> "Recent history"
|
||||
|
||||
groupFeatureNameText' :: SGroupFeature f -> Text
|
||||
groupFeatureNameText' = groupFeatureNameText . toGroupFeature
|
||||
|
||||
groupFeatureAllowed' :: GroupFeatureI f => SGroupFeature f -> FullGroupPreferences -> Bool
|
||||
groupFeatureAllowed' :: GroupFeatureNoRoleI f => SGroupFeature f -> FullGroupPreferences -> Bool
|
||||
groupFeatureAllowed' feature prefs =
|
||||
getField @"enable" (getGroupPreference feature prefs) == FEOn
|
||||
|
||||
groupFeatureMemberAllowed' :: GroupFeatureRoleI f => SGroupFeature f -> GroupMemberRole -> FullGroupPreferences -> Bool
|
||||
groupFeatureMemberAllowed' feature role prefs =
|
||||
let pref = getGroupPreference feature prefs
|
||||
in getField @"enable" pref == FEOn && maybe True (role >=) (getField @"role" pref)
|
||||
|
||||
allGroupFeatures :: [AGroupFeature]
|
||||
allGroupFeatures =
|
||||
[ AGF SGFTimedMessages,
|
||||
|
|
@ -191,17 +209,19 @@ allGroupFeatures =
|
|||
AGF SGFReactions,
|
||||
AGF SGFVoice,
|
||||
AGF SGFFiles,
|
||||
AGF SGFSimplexLinks,
|
||||
AGF SGFHistory
|
||||
]
|
||||
|
||||
groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
|
||||
groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, history} = case f of
|
||||
groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, history} = case f of
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
SGFReactions -> reactions
|
||||
SGFVoice -> voice
|
||||
SGFFiles -> files
|
||||
SGFSimplexLinks -> simplexLinks
|
||||
SGFHistory -> history
|
||||
|
||||
toGroupFeature :: SGroupFeature f -> GroupFeature
|
||||
|
|
@ -212,6 +232,7 @@ toGroupFeature = \case
|
|||
SGFReactions -> GFReactions
|
||||
SGFVoice -> GFVoice
|
||||
SGFFiles -> GFFiles
|
||||
SGFSimplexLinks -> GFSimplexLinks
|
||||
SGFHistory -> GFHistory
|
||||
|
||||
class GroupPreferenceI p where
|
||||
|
|
@ -224,13 +245,14 @@ instance GroupPreferenceI (Maybe GroupPreferences) where
|
|||
getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs)
|
||||
|
||||
instance GroupPreferenceI FullGroupPreferences where
|
||||
getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, history} = case f of
|
||||
getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, history} = case f of
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
SGFReactions -> reactions
|
||||
SGFVoice -> voice
|
||||
SGFFiles -> files
|
||||
SGFSimplexLinks -> simplexLinks
|
||||
SGFHistory -> history
|
||||
{-# INLINE getGroupPreference #-}
|
||||
|
||||
|
|
@ -242,17 +264,25 @@ data GroupPreferences = GroupPreferences
|
|||
reactions :: Maybe ReactionsGroupPreference,
|
||||
voice :: Maybe VoiceGroupPreference,
|
||||
files :: Maybe FilesGroupPreference,
|
||||
simplexLinks :: Maybe SimplexLinksGroupPreference,
|
||||
history :: Maybe HistoryGroupPreference
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
setGroupPreference :: forall f. GroupFeatureI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreference :: forall f. GroupFeatureNoRoleI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreference f enable prefs_ = setGroupPreference_ f pref prefs
|
||||
where
|
||||
prefs = mergeGroupPreferences prefs_
|
||||
pref :: GroupFeaturePreference f
|
||||
pref = setField @"enable" (getGroupPreference f prefs) enable
|
||||
|
||||
setGroupPreferenceRole :: forall f. GroupFeatureRoleI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupMemberRole -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreferenceRole f enable role prefs_ = setGroupPreference_ f pref prefs
|
||||
where
|
||||
prefs = mergeGroupPreferences prefs_
|
||||
pref :: GroupFeaturePreference f
|
||||
pref = setField @"role" (setField @"enable" (getGroupPreference f prefs) enable) role
|
||||
|
||||
setGroupPreference' :: SGroupFeature f -> GroupFeaturePreference f -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreference' f pref prefs_ = setGroupPreference_ f pref prefs
|
||||
where
|
||||
|
|
@ -267,6 +297,7 @@ setGroupPreference_ f pref prefs =
|
|||
SGFReactions -> prefs {reactions = pref}
|
||||
SGFVoice -> prefs {voice = pref}
|
||||
SGFFiles -> prefs {files = pref}
|
||||
SGFSimplexLinks -> prefs {simplexLinks = pref}
|
||||
SGFHistory -> prefs {history = pref}
|
||||
|
||||
setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences
|
||||
|
|
@ -295,6 +326,7 @@ data FullGroupPreferences = FullGroupPreferences
|
|||
reactions :: ReactionsGroupPreference,
|
||||
voice :: VoiceGroupPreference,
|
||||
files :: FilesGroupPreference,
|
||||
simplexLinks :: SimplexLinksGroupPreference,
|
||||
history :: HistoryGroupPreference
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
|
@ -346,16 +378,17 @@ defaultGroupPrefs :: FullGroupPreferences
|
|||
defaultGroupPrefs =
|
||||
FullGroupPreferences
|
||||
{ timedMessages = TimedMessagesGroupPreference {enable = FEOff, ttl = Just 86400},
|
||||
directMessages = DirectMessagesGroupPreference {enable = FEOff},
|
||||
directMessages = DirectMessagesGroupPreference {enable = FEOff, role = Nothing},
|
||||
fullDelete = FullDeleteGroupPreference {enable = FEOff},
|
||||
reactions = ReactionsGroupPreference {enable = FEOn},
|
||||
voice = VoiceGroupPreference {enable = FEOn},
|
||||
files = FilesGroupPreference {enable = FEOn},
|
||||
voice = VoiceGroupPreference {enable = FEOn, role = Nothing},
|
||||
files = FilesGroupPreference {enable = FEOn, role = Nothing},
|
||||
simplexLinks = SimplexLinksGroupPreference {enable = FEOn, role = Nothing},
|
||||
history = HistoryGroupPreference {enable = FEOff}
|
||||
}
|
||||
|
||||
emptyGroupPrefs :: GroupPreferences
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
data TimedMessagesPreference = TimedMessagesPreference
|
||||
{ allow :: FeatureAllowed,
|
||||
|
|
@ -431,7 +464,7 @@ data TimedMessagesGroupPreference = TimedMessagesGroupPreference
|
|||
deriving (Eq, Show)
|
||||
|
||||
data DirectMessagesGroupPreference = DirectMessagesGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
{enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FullDeleteGroupPreference = FullDeleteGroupPreference
|
||||
|
|
@ -443,11 +476,15 @@ data ReactionsGroupPreference = ReactionsGroupPreference
|
|||
deriving (Eq, Show)
|
||||
|
||||
data VoiceGroupPreference = VoiceGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
{enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FilesGroupPreference = FilesGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
{enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SimplexLinksGroupPreference = SimplexLinksGroupPreference
|
||||
{enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data HistoryGroupPreference = HistoryGroupPreference
|
||||
|
|
@ -458,6 +495,11 @@ class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference
|
|||
type GroupFeaturePreference (f :: GroupFeature) = p | p -> f
|
||||
sGroupFeature :: SGroupFeature f
|
||||
groupPrefParam :: GroupFeaturePreference f -> Maybe Int
|
||||
groupPrefRole :: GroupFeaturePreference f -> Maybe GroupMemberRole
|
||||
|
||||
class GroupFeatureI f => GroupFeatureNoRoleI f
|
||||
|
||||
class (GroupFeatureI f, HasField "role" (GroupFeaturePreference f) (Maybe GroupMemberRole)) => GroupFeatureRoleI f
|
||||
|
||||
instance HasField "enable" GroupPreference GroupFeatureEnabled where
|
||||
hasField p@GroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
|
@ -480,6 +522,9 @@ instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where
|
|||
instance HasField "enable" FilesGroupPreference GroupFeatureEnabled where
|
||||
hasField p@FilesGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
instance HasField "enable" SimplexLinksGroupPreference GroupFeatureEnabled where
|
||||
hasField p@SimplexLinksGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
instance HasField "enable" HistoryGroupPreference GroupFeatureEnabled where
|
||||
hasField p@HistoryGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
|
|
@ -487,42 +532,84 @@ instance GroupFeatureI 'GFTimedMessages where
|
|||
type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference
|
||||
sGroupFeature = SGFTimedMessages
|
||||
groupPrefParam TimedMessagesGroupPreference {ttl} = ttl
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFDirectMessages where
|
||||
type GroupFeaturePreference 'GFDirectMessages = DirectMessagesGroupPreference
|
||||
sGroupFeature = SGFDirectMessages
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole DirectMessagesGroupPreference {role} = role
|
||||
|
||||
instance GroupFeatureI 'GFFullDelete where
|
||||
type GroupFeaturePreference 'GFFullDelete = FullDeleteGroupPreference
|
||||
sGroupFeature = SGFFullDelete
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFReactions where
|
||||
type GroupFeaturePreference 'GFReactions = ReactionsGroupPreference
|
||||
sGroupFeature = SGFReactions
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFVoice where
|
||||
type GroupFeaturePreference 'GFVoice = VoiceGroupPreference
|
||||
sGroupFeature = SGFVoice
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole VoiceGroupPreference {role} = role
|
||||
|
||||
instance GroupFeatureI 'GFFiles where
|
||||
type GroupFeaturePreference 'GFFiles = FilesGroupPreference
|
||||
sGroupFeature = SGFFiles
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole FilesGroupPreference {role} = role
|
||||
|
||||
instance GroupFeatureI 'GFSimplexLinks where
|
||||
type GroupFeaturePreference 'GFSimplexLinks = SimplexLinksGroupPreference
|
||||
sGroupFeature = SGFSimplexLinks
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole SimplexLinksGroupPreference {role} = role
|
||||
|
||||
instance GroupFeatureI 'GFHistory where
|
||||
type GroupFeaturePreference 'GFHistory = HistoryGroupPreference
|
||||
sGroupFeature = SGFHistory
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
groupPrefStateText :: HasField "enable" p GroupFeatureEnabled => GroupFeature -> p -> Maybe Int -> Text
|
||||
groupPrefStateText feature pref param =
|
||||
instance GroupFeatureNoRoleI 'GFTimedMessages
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFFullDelete
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFReactions
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFHistory
|
||||
|
||||
instance HasField "role" DirectMessagesGroupPreference (Maybe GroupMemberRole) where
|
||||
hasField p@DirectMessagesGroupPreference {role} = (\r -> p {role = r}, role)
|
||||
|
||||
instance HasField "role" VoiceGroupPreference (Maybe GroupMemberRole) where
|
||||
hasField p@VoiceGroupPreference {role} = (\r -> p {role = r}, role)
|
||||
|
||||
instance HasField "role" FilesGroupPreference (Maybe GroupMemberRole) where
|
||||
hasField p@FilesGroupPreference {role} = (\r -> p {role = r}, role)
|
||||
|
||||
instance HasField "role" SimplexLinksGroupPreference (Maybe GroupMemberRole) where
|
||||
hasField p@SimplexLinksGroupPreference {role} = (\r -> p {role = r}, role)
|
||||
|
||||
instance GroupFeatureRoleI 'GFDirectMessages
|
||||
|
||||
instance GroupFeatureRoleI 'GFVoice
|
||||
|
||||
instance GroupFeatureRoleI 'GFFiles
|
||||
|
||||
instance GroupFeatureRoleI 'GFSimplexLinks
|
||||
|
||||
groupPrefStateText :: HasField "enable" p GroupFeatureEnabled => GroupFeature -> p -> Maybe Int -> Maybe GroupMemberRole -> Text
|
||||
groupPrefStateText feature pref param role =
|
||||
let enabled = getField @"enable" pref
|
||||
paramText = if enabled == FEOn then groupParamText_ feature param else ""
|
||||
in groupFeatureNameText feature <> ": " <> safeDecodeUtf8 (strEncode enabled) <> paramText
|
||||
roleText = maybe "" (\r -> " for " <> safeDecodeUtf8 (strEncode r) <> "s") role
|
||||
in groupFeatureNameText feature <> ": " <> safeDecodeUtf8 (strEncode enabled) <> paramText <> roleText
|
||||
|
||||
groupParamText_ :: GroupFeature -> Maybe Int -> Text
|
||||
groupParamText_ feature param = case feature of
|
||||
|
|
@ -532,7 +619,7 @@ groupParamText_ feature param = case feature of
|
|||
groupPreferenceText :: forall f. GroupFeatureI f => GroupFeaturePreference f -> Text
|
||||
groupPreferenceText pref =
|
||||
let feature = toGroupFeature $ sGroupFeature @f
|
||||
in groupPrefStateText feature pref $ groupPrefParam pref
|
||||
in groupPrefStateText feature pref (groupPrefParam pref) (groupPrefRole pref)
|
||||
|
||||
timedTTLText :: Int -> Text
|
||||
timedTTLText 0 = "0 sec"
|
||||
|
|
@ -602,7 +689,7 @@ instance StrEncoding GroupFeatureEnabled where
|
|||
"on" -> Right FEOn
|
||||
"off" -> Right FEOff
|
||||
r -> Left $ "bad GroupFeatureEnabled " <> B.unpack r
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
strP = strDecode <$?> A.takeTill (== ' ')
|
||||
|
||||
instance FromJSON GroupFeatureEnabled where
|
||||
parseJSON = strParseJSON "GroupFeatureEnabled"
|
||||
|
|
@ -611,11 +698,13 @@ instance ToJSON GroupFeatureEnabled where
|
|||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
groupFeatureState :: GroupFeatureI f => GroupFeaturePreference f -> (GroupFeatureEnabled, Maybe Int)
|
||||
groupFeatureState :: GroupFeatureI f => GroupFeaturePreference f -> (GroupFeatureEnabled, Maybe Int, Maybe GroupMemberRole)
|
||||
groupFeatureState p =
|
||||
let enable = getField @"enable" p
|
||||
param = if enable == FEOn then groupPrefParam p else Nothing
|
||||
in (enable, param)
|
||||
(param, role)
|
||||
| enable == FEOn = (groupPrefParam p, groupPrefRole p)
|
||||
| otherwise = (Nothing, Nothing)
|
||||
in (enable, param, role)
|
||||
|
||||
mergePreferences :: Maybe Preferences -> Maybe Preferences -> FullPreferences
|
||||
mergePreferences contactPrefs userPreferences =
|
||||
|
|
@ -641,6 +730,7 @@ mergeGroupPreferences groupPreferences =
|
|||
reactions = pref SGFReactions,
|
||||
voice = pref SGFVoice,
|
||||
files = pref SGFFiles,
|
||||
simplexLinks = pref SGFSimplexLinks,
|
||||
history = pref SGFHistory
|
||||
}
|
||||
where
|
||||
|
|
@ -656,6 +746,7 @@ toGroupPreferences groupPreferences =
|
|||
reactions = pref SGFReactions,
|
||||
voice = pref SGFVoice,
|
||||
files = pref SGFFiles,
|
||||
simplexLinks = pref SGFSimplexLinks,
|
||||
history = pref SGFHistory
|
||||
}
|
||||
where
|
||||
|
|
@ -762,6 +853,8 @@ $(J.deriveJSON defaultJSON ''VoiceGroupPreference)
|
|||
|
||||
$(J.deriveJSON defaultJSON ''FilesGroupPreference)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''SimplexLinksGroupPreference)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''HistoryGroupPreference)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''GroupPreferences)
|
||||
|
|
|
|||
48
src/Simplex/Chat/Types/Shared.hs
Normal file
48
src/Simplex/Chat/Types/Shared.hs
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Types.Shared where
|
||||
|
||||
import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
data GroupMemberRole
|
||||
= GRObserver -- connects to all group members and receives all messages, can't send messages
|
||||
| GRAuthor -- reserved, unused
|
||||
| GRMember -- + can send messages to all group members
|
||||
| GRAdmin -- + add/remove members, change member role (excl. Owners)
|
||||
| GROwner -- + delete and change group information, add/remove/change roles for Owners
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance FromField GroupMemberRole where fromField = fromBlobField_ strDecode
|
||||
|
||||
instance ToField GroupMemberRole where toField = toField . strEncode
|
||||
|
||||
instance StrEncoding GroupMemberRole where
|
||||
strEncode = \case
|
||||
GROwner -> "owner"
|
||||
GRAdmin -> "admin"
|
||||
GRMember -> "member"
|
||||
GRAuthor -> "author"
|
||||
GRObserver -> "observer"
|
||||
strDecode = \case
|
||||
"owner" -> Right GROwner
|
||||
"admin" -> Right GRAdmin
|
||||
"member" -> Right GRMember
|
||||
"author" -> Right GRAuthor
|
||||
"observer" -> Right GRObserver
|
||||
r -> Left $ "bad GroupMemberRole " <> B.unpack r
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
|
||||
instance FromJSON GroupMemberRole where
|
||||
parseJSON = strParseJSON "GroupMemberRole"
|
||||
|
||||
instance ToJSON GroupMemberRole where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
|
@ -49,6 +49,7 @@ import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..
|
|||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import qualified Simplex.FileTransfer.Transport as XFTPTransport
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
|
||||
|
|
|
|||
|
|
@ -19,7 +19,8 @@ import Simplex.Chat.Bot.KnownContacts
|
|||
import Simplex.Chat.Controller (ChatConfig (..))
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options (CoreChatOpts (..))
|
||||
import Simplex.Chat.Types (GroupMemberRole (..), Profile (..))
|
||||
import Simplex.Chat.Types (Profile (..))
|
||||
import Simplex.Chat.Types.Shared (GroupMemberRole (..))
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hspec hiding (it)
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,8 @@ import qualified Data.Text as T
|
|||
import Simplex.Chat.Controller (ChatConfig (..))
|
||||
import Simplex.Chat.Protocol (supportedChatVRange)
|
||||
import Simplex.Chat.Store (agentStoreFile, chatStoreFile)
|
||||
import Simplex.Chat.Types (GroupMemberRole (..), VersionRangeChat)
|
||||
import Simplex.Chat.Types (VersionRangeChat)
|
||||
import Simplex.Chat.Types.Shared (GroupMemberRole (..))
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOff)
|
||||
import System.Directory (copyFile)
|
||||
|
|
@ -1509,6 +1510,7 @@ testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile
|
|||
alice <## "Message reactions: on"
|
||||
alice <## "Voice messages: on"
|
||||
alice <## "Files and media: on"
|
||||
alice <## "SimpleX links: on"
|
||||
alice <## "Recent history: on"
|
||||
bobAddedDan :: HasCallStack => TestCC -> IO ()
|
||||
bobAddedDan cc = do
|
||||
|
|
|
|||
|
|
@ -13,7 +13,8 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
|
|||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Store.Shared (createContact)
|
||||
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), Profile (..))
|
||||
import Simplex.Chat.Types (ConnStatus (..), Profile (..))
|
||||
import Simplex.Chat.Types.Shared (GroupMemberRole (..))
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import System.Directory (copyFile, createDirectoryIfMissing)
|
||||
import Test.Hspec hiding (it)
|
||||
|
|
@ -68,6 +69,10 @@ chatProfileTests = do
|
|||
it "enable timed messages in group" testEnableTimedMessagesGroup
|
||||
xit'' "timed messages enabled globally, contact turns on" testTimedMessagesEnabledGlobally
|
||||
it "update multiple user preferences for multiple contacts" testUpdateMultipleUserPrefs
|
||||
describe "group preferences for specific member role" $ do
|
||||
it "direct messages" testGroupPrefsDirectForRole
|
||||
it "files & media" testGroupPrefsFilesForRole
|
||||
it "SimpleX links" testGroupPrefsSimplexLinksForRole
|
||||
|
||||
testUpdateProfile :: HasCallStack => FilePath -> IO ()
|
||||
testUpdateProfile =
|
||||
|
|
@ -1903,3 +1908,122 @@ testUpdateMultipleUserPrefs = testChat3 aliceProfile bobProfile cathProfile $
|
|||
|
||||
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "hi bob"), (1, "Full deletion: enabled for contact"), (1, "Message reactions: off")])
|
||||
alice #$> ("/_get chat @3 count=100", chat, chatFeatures <> [(1, "hi cath"), (1, "Full deletion: enabled for contact"), (1, "Message reactions: off")])
|
||||
|
||||
testGroupPrefsDirectForRole :: HasCallStack => FilePath -> IO ()
|
||||
testGroupPrefsDirectForRole = testChat4 aliceProfile bobProfile cathProfile danProfile $
|
||||
\alice bob cath dan -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
alice ##> "/set direct #team on owner"
|
||||
alice <## "updated group preferences:"
|
||||
alice <## "Direct messages: on for owners"
|
||||
directForOwners bob
|
||||
directForOwners cath
|
||||
threadDelay 1000000
|
||||
bob ##> "@cath hello again"
|
||||
bob <## "bad chat command: direct messages not allowed"
|
||||
(cath </)
|
||||
|
||||
connectUsers cath dan
|
||||
addMember "team" cath dan GRMember
|
||||
dan ##> "/j #team"
|
||||
concurrentlyN_
|
||||
[ cath <## "#team: dan joined the group",
|
||||
do
|
||||
dan <## "#team: you joined the group"
|
||||
dan
|
||||
<### [ "#team: member alice (Alice) is connected",
|
||||
"#team: member bob (Bob) is connected"
|
||||
],
|
||||
do
|
||||
alice <## "#team: cath added dan (Daniel) to the group (connecting...)"
|
||||
alice <## "#team: new member dan is connected",
|
||||
do
|
||||
bob <## "#team: cath added dan (Daniel) to the group (connecting...)"
|
||||
bob <## "#team: new member dan is connected"
|
||||
]
|
||||
-- dan cannot send direct messages to alice (owner)
|
||||
dan ##> "@alice hello alice"
|
||||
dan <## "bad chat command: direct messages not allowed"
|
||||
(alice </)
|
||||
-- but alice can
|
||||
alice `send` "@dan hello dan"
|
||||
alice <## "member #team dan does not have direct connection, creating"
|
||||
alice <## "contact for member #team dan is created"
|
||||
alice <## "sent invitation to connect directly to member #team dan"
|
||||
alice <# "@dan hello dan"
|
||||
alice <## "dan (Daniel): contact is connected"
|
||||
dan <## "#team alice is creating direct contact alice with you"
|
||||
dan <# "alice> hello dan"
|
||||
dan <## "alice (Alice): contact is connected"
|
||||
-- and now dan can too
|
||||
dan #> "@alice hi alice"
|
||||
alice <# "dan> hi alice"
|
||||
where
|
||||
directForOwners :: HasCallStack => TestCC -> IO ()
|
||||
directForOwners cc = do
|
||||
cc <## "alice updated group #team:"
|
||||
cc <## "updated group preferences:"
|
||||
cc <## "Direct messages: on for owners"
|
||||
|
||||
testGroupPrefsFilesForRole :: HasCallStack => FilePath -> IO ()
|
||||
testGroupPrefsFilesForRole = testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> withXFTPServer $ do
|
||||
alice #$> ("/_files_folder ./tests/tmp/alice", id, "ok")
|
||||
bob #$> ("/_files_folder ./tests/tmp/bob", id, "ok")
|
||||
createDirectoryIfMissing True "./tests/tmp/alice"
|
||||
createDirectoryIfMissing True "./tests/tmp/bob"
|
||||
copyFile "./tests/fixtures/test.txt" "./tests/tmp/alice/test1.txt"
|
||||
copyFile "./tests/fixtures/test.txt" "./tests/tmp/bob/test2.txt"
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
alice ##> "/set files #team on owner"
|
||||
alice <## "updated group preferences:"
|
||||
alice <## "Files and media: on for owners"
|
||||
filesForOwners bob
|
||||
filesForOwners cath
|
||||
threadDelay 1000000
|
||||
bob ##> "/f #team test2.txt"
|
||||
bob <## "bad chat command: feature not allowed Files and media"
|
||||
(alice </)
|
||||
(cath </)
|
||||
alice #> "/f #team test1.txt"
|
||||
alice <## "use /fc 1 to cancel sending"
|
||||
alice <## "completed uploading file 1 (test1.txt) for #team"
|
||||
bob <# "#team alice> sends file test1.txt (11 bytes / 11 bytes)"
|
||||
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
cath <# "#team alice> sends file test1.txt (11 bytes / 11 bytes)"
|
||||
cath <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
where
|
||||
filesForOwners :: HasCallStack => TestCC -> IO ()
|
||||
filesForOwners cc = do
|
||||
cc <## "alice updated group #team:"
|
||||
cc <## "updated group preferences:"
|
||||
cc <## "Files and media: on for owners"
|
||||
|
||||
testGroupPrefsSimplexLinksForRole :: HasCallStack => FilePath -> IO ()
|
||||
testGroupPrefsSimplexLinksForRole = testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> withXFTPServer $ do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
alice ##> "/set links #team on owner"
|
||||
alice <## "updated group preferences:"
|
||||
alice <## "SimpleX links: on for owners"
|
||||
linksForOwners bob
|
||||
linksForOwners cath
|
||||
threadDelay 1000000
|
||||
bob ##> "/c"
|
||||
inv <- getInvitation bob
|
||||
bob ##> ("#team " <> inv)
|
||||
bob <## "bad chat command: feature not allowed SimpleX links"
|
||||
(alice </)
|
||||
(cath </)
|
||||
alice #> ("#team " <> inv)
|
||||
bob <# ("#team alice> " <> inv)
|
||||
cath <# ("#team alice> " <> inv)
|
||||
where
|
||||
linksForOwners :: HasCallStack => TestCC -> IO ()
|
||||
linksForOwners cc = do
|
||||
cc <## "alice updated group #team:"
|
||||
cc <## "updated group preferences:"
|
||||
cc <## "SimpleX links: on for owners"
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ import Simplex.Chat.Store.NoteFolders (createNoteFolder)
|
|||
import Simplex.Chat.Store.Profiles (getUserContactProfiles)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.FileTransfer.Client.Main (xftpClientCLI)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow, withTransaction)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
|
|
@ -315,6 +316,7 @@ groupFeatures'' =
|
|||
((0, "Message reactions: on"), Nothing, Nothing),
|
||||
((0, "Voice messages: on"), Nothing, Nothing),
|
||||
((0, "Files and media: on"), Nothing, Nothing),
|
||||
((0, "SimpleX links: on"), Nothing, Nothing),
|
||||
((0, "Recent history: on"), Nothing, Nothing)
|
||||
]
|
||||
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
|
|||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.Ratchet
|
||||
|
|
@ -99,7 +100,7 @@ testChatPreferences :: Maybe Preferences
|
|||
testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, fullDelete = Nothing, timedMessages = Nothing, calls = Nothing, reactions = Just ReactionsPreference {allow = FAYes}}
|
||||
|
||||
testGroupPreferences :: Maybe GroupPreferences
|
||||
testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn}, files = Nothing, fullDelete = Nothing, history = Nothing}
|
||||
testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, reactions = Just ReactionsGroupPreference {enable = FEOn}, voice = Just VoiceGroupPreference {enable = FEOn, role = Nothing}, files = Nothing, fullDelete = Nothing, simplexLinks = Nothing, history = Nothing}
|
||||
|
||||
testProfile :: Profile
|
||||
testProfile = Profile {displayName = "alice", fullName = "Alice", image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), contactLink = Nothing, preferences = testChatPreferences}
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue