mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-06-04 19:01:57 +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
committed by
GitHub
GitHub
parent
069395c2a0
commit
18efc28d16
@@ -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)
|
||||
|
||||
@@ -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 (..))
|
||||
|
||||
Reference in New Issue
Block a user