diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 1d7a866051..76f57585a8 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -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) diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index c1428881b9..d158b57e22 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -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) diff --git a/simplex-chat.cabal b/simplex-chat.cabal index fb0635abad..005fbe10a9 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c62fdfb8bd..d075c6cf70 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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} diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 024757e7bb..85d93a7d88 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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) diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index 2eabb48166..d3b9ea52f1 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/src/Simplex/Chat/Markdown.hs @@ -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 diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index 0e95570b85..9266a0c1ca 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -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 diff --git a/src/Simplex/Chat/Messages/CIContent/Events.hs b/src/Simplex/Chat/Messages/CIContent/Events.hs index 7ce5f73cde..74f7d94399 100644 --- a/src/Simplex/Chat/Messages/CIContent/Events.hs +++ b/src/Simplex/Chat/Messages/CIContent/Events.hs @@ -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) diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 8727a592a7..e262de0e74 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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) diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 832b928012..cd62f17f4c 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -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) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 512c857b23..0e2445572c 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -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 diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index e419f8c4cb..f7174a635b 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -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 } diff --git a/src/Simplex/Chat/Types/Preferences.hs b/src/Simplex/Chat/Types/Preferences.hs index 2286ae8f40..4cf9f862d2 100644 --- a/src/Simplex/Chat/Types/Preferences.hs +++ b/src/Simplex/Chat/Types/Preferences.hs @@ -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) diff --git a/src/Simplex/Chat/Types/Shared.hs b/src/Simplex/Chat/Types/Shared.hs new file mode 100644 index 0000000000..f44457160f --- /dev/null +++ b/src/Simplex/Chat/Types/Shared.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 550fe97b18..55e0078d0d 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 (..)) diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index b78d36f489..fbabccfb54 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -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) diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 77bac11145..a7a646c17b 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -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 diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 8a9191c988..a6cc491456 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -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 "/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 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 "/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 [/ | ] to receive it" + cath <# "#team alice> sends file test1.txt (11 bytes / 11 bytes)" + cath <## "use /fr 1 [/ | ] 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 ("#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" diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 3b0748e7d0..98227fcd0c 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -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) ] diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 082af825e5..18fb677be2 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -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}