mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: different types for chat preferences, to allow parameters (#1565)
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
bd4c7dffbf
commit
678dbec3e2
8 changed files with 190 additions and 100 deletions
|
|
@ -33,6 +33,7 @@ dependencies:
|
|||
- optparse-applicative >= 0.15 && < 0.17
|
||||
- process == 1.6.*
|
||||
- random >= 1.1 && < 1.3
|
||||
- record-hasfield == 1.0.*
|
||||
- simple-logger == 0.1.*
|
||||
- simplexmq >= 3.4
|
||||
- socks == 0.6.*
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
|
|
@ -107,6 +107,7 @@ library
|
|||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplexmq >=3.4
|
||||
, socks ==0.6.*
|
||||
|
|
@ -149,6 +150,7 @@ executable simplex-bot
|
|||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=3.4
|
||||
|
|
@ -192,6 +194,7 @@ executable simplex-bot-advanced
|
|||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=3.4
|
||||
|
|
@ -236,6 +239,7 @@ executable simplex-chat
|
|||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=3.4
|
||||
|
|
@ -289,6 +293,7 @@ test-suite simplex-chat-test
|
|||
, optparse-applicative >=0.15 && <0.17
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, record-hasfield ==1.0.*
|
||||
, simple-logger ==0.1.*
|
||||
, simplex-chat
|
||||
, simplexmq >=3.4
|
||||
|
|
|
|||
|
|
@ -291,7 +291,7 @@ processChatCommand = \case
|
|||
ct@Contact {localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
|
||||
assertDirectAllowed user MDSnd ct XMsgNew_
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
if isVoice mc && not (featureAllowed CFVoice forUser ct)
|
||||
if isVoice mc && not (featureAllowed SCFVoice forUser ct)
|
||||
then pure $ chatCmdError $ "feature not allowed " <> T.unpack (chatFeatureToText CFVoice)
|
||||
else do
|
||||
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct
|
||||
|
|
@ -454,7 +454,7 @@ processChatCommand = \case
|
|||
(CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
|
||||
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId)
|
||||
setActive $ ActiveC c
|
||||
if featureAllowed CFFullDelete forUser ct
|
||||
if featureAllowed SCFFullDelete forUser ct
|
||||
then deleteDirectCI user ct ci True
|
||||
else markDirectCIDeleted user ct ci msgId True
|
||||
(CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete
|
||||
|
|
@ -1113,11 +1113,13 @@ processChatCommand = \case
|
|||
UpdateProfileImage image -> withUser $ \user@User {profile} -> do
|
||||
let p = (fromLocalProfile profile :: Profile) {image}
|
||||
updateProfile user p
|
||||
SetUserFeature f allowed -> withUser $ \user@User {profile} -> do
|
||||
SetUserFeature cf allowed -> withUser $ \user@User {profile} -> do
|
||||
ACF f <- pure $ aChatFeature cf
|
||||
let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user}
|
||||
updateProfile user p
|
||||
SetContactFeature f cName allowed_ -> withUser $ \user -> do
|
||||
SetContactFeature cf cName allowed_ -> withUser $ \user -> do
|
||||
ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db user cName
|
||||
ACF f <- pure $ aChatFeature cf
|
||||
let prefs' = setPreference f allowed_ $ Just userPreferences
|
||||
updateContactPrefs user ct prefs'
|
||||
SetGroupFeature f gName enabled ->
|
||||
|
|
@ -2303,7 +2305,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
|||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
let ExtMsgContent content fileInvitation_ = mcExtMsgContent mc
|
||||
if isVoice content && not (featureAllowed CFVoice forContact ct)
|
||||
if isVoice content && not (featureAllowed SCFVoice forContact ct)
|
||||
then do
|
||||
void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing
|
||||
setActive $ ActiveC c
|
||||
|
|
@ -2364,7 +2366,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
|||
ci@(CChatItem msgDir _) <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId
|
||||
case msgDir of
|
||||
SMDRcv ->
|
||||
if featureAllowed CFFullDelete forContact ct
|
||||
if featureAllowed SCFFullDelete forContact ct
|
||||
then deleteDirectCI user ct ci False >>= toView
|
||||
else markDirectCIDeleted user ct ci msgId False >>= toView
|
||||
SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete"
|
||||
|
|
@ -2621,9 +2623,9 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
|||
|
||||
createFeatureEnabledItems :: Contact -> m ()
|
||||
createFeatureEnabledItems ct@Contact {mergedPreferences} =
|
||||
forM_ allChatFeatures $ \f -> do
|
||||
forM_ allChatFeatures $ \(ACF f) -> do
|
||||
let ContactUserPreference {enabled} = getContactUserPreference f mergedPreferences
|
||||
createInternalChatItem user (CDDirectRcv ct) (CIRcvChatFeature f enabled) Nothing
|
||||
createInternalChatItem user (CDDirectRcv ct) (CIRcvChatFeature (chatFeature f) enabled) Nothing
|
||||
|
||||
createGroupFeatureItems :: GroupInfo -> GroupMember -> m ()
|
||||
createGroupFeatureItems g@GroupInfo {groupProfile} m = do
|
||||
|
|
@ -3244,11 +3246,11 @@ userProfileToSend user@User {profile = p} incognitoProfile ct =
|
|||
|
||||
createFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> Contact -> Contact -> (Contact -> ChatDirection 'CTDirect d) -> (ChatFeature -> PrefEnabled -> CIContent d) -> m ()
|
||||
createFeatureChangedItems user Contact {mergedPreferences = cups} ct'@Contact {mergedPreferences = cups'} chatDir ciContent =
|
||||
forM_ allChatFeatures $ \f -> do
|
||||
forM_ allChatFeatures $ \(ACF f) -> do
|
||||
let ContactUserPreference {enabled} = getContactUserPreference f cups
|
||||
ContactUserPreference {enabled = enabled'} = getContactUserPreference f cups'
|
||||
unless (enabled == enabled') $
|
||||
createInternalChatItem user (chatDir ct') (ciContent f enabled') Nothing
|
||||
createInternalChatItem user (chatDir ct') (ciContent (chatFeature f) enabled') Nothing
|
||||
|
||||
createGroupFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> CIContent d) -> GroupProfile -> GroupProfile -> m ()
|
||||
createGroupFeatureChangedItems user cd ciContent p p' =
|
||||
|
|
|
|||
|
|
@ -1,17 +1,21 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
|
|
@ -42,6 +46,7 @@ import Database.SQLite.Simple.Internal (Field (..))
|
|||
import Database.SQLite.Simple.Ok (Ok (Ok))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import GHC.Generics (Generic)
|
||||
import GHC.Records.Compat
|
||||
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
|
||||
|
|
@ -258,17 +263,26 @@ pattern DisableNtfs :: ChatSettings
|
|||
pattern DisableNtfs = ChatSettings {enableNtfs = False}
|
||||
|
||||
data ChatFeature
|
||||
= CFFullDelete
|
||||
= CFTimedMessages
|
||||
| CFFullDelete
|
||||
| -- | CFReceipts
|
||||
CFVoice
|
||||
deriving (Show, Generic)
|
||||
|
||||
data SChatFeature (f :: ChatFeature) where
|
||||
SCFTimedMessages :: SChatFeature 'CFTimedMessages
|
||||
SCFFullDelete :: SChatFeature 'CFFullDelete
|
||||
SCFVoice :: SChatFeature 'CFVoice
|
||||
|
||||
data AChatFeature = forall f. FeatureI f => ACF (SChatFeature f)
|
||||
|
||||
chatFeatureToText :: ChatFeature -> Text
|
||||
chatFeatureToText = \case
|
||||
CFTimedMessages -> "Disappearing messages"
|
||||
CFFullDelete -> "Full deletion"
|
||||
CFVoice -> "Voice messages"
|
||||
|
||||
featureAllowed :: ChatFeature -> (PrefEnabled -> Bool) -> Contact -> Bool
|
||||
featureAllowed :: SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool
|
||||
featureAllowed feature forWhom Contact {mergedPreferences} =
|
||||
let ContactUserPreference {enabled} = getContactUserPreference feature mergedPreferences
|
||||
in forWhom enabled
|
||||
|
|
@ -280,48 +294,68 @@ instance ToJSON ChatFeature where
|
|||
instance FromJSON ChatFeature where
|
||||
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CF"
|
||||
|
||||
allChatFeatures :: [ChatFeature]
|
||||
allChatFeatures :: [AChatFeature]
|
||||
allChatFeatures =
|
||||
[ CFFullDelete,
|
||||
[ ACF SCFTimedMessages,
|
||||
ACF SCFFullDelete,
|
||||
-- CFReceipts,
|
||||
CFVoice
|
||||
ACF SCFVoice
|
||||
]
|
||||
|
||||
chatPrefSel :: ChatFeature -> Preferences -> Maybe Preference
|
||||
chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f)
|
||||
chatPrefSel = \case
|
||||
CFFullDelete -> fullDelete
|
||||
SCFTimedMessages -> timedMessages
|
||||
SCFFullDelete -> fullDelete
|
||||
-- CFReceipts -> receipts
|
||||
CFVoice -> voice
|
||||
SCFVoice -> voice
|
||||
|
||||
chatFeature :: SChatFeature f -> ChatFeature
|
||||
chatFeature = \case
|
||||
SCFTimedMessages -> CFTimedMessages
|
||||
SCFFullDelete -> CFFullDelete
|
||||
SCFVoice -> CFVoice
|
||||
|
||||
aChatFeature :: ChatFeature -> AChatFeature
|
||||
aChatFeature = \case
|
||||
CFTimedMessages -> ACF SCFTimedMessages
|
||||
CFFullDelete -> ACF SCFFullDelete
|
||||
CFVoice -> ACF SCFVoice
|
||||
|
||||
class PreferenceI p where
|
||||
getPreference :: ChatFeature -> p -> Preference
|
||||
getPreference :: SChatFeature f -> p -> FeaturePreference f
|
||||
|
||||
instance PreferenceI Preferences where
|
||||
getPreference pt prefs = fromMaybe (getPreference pt defaultChatPrefs) (chatPrefSel pt prefs)
|
||||
getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f prefs)
|
||||
|
||||
instance PreferenceI (Maybe Preferences) where
|
||||
getPreference pt prefs = fromMaybe (getPreference pt defaultChatPrefs) (chatPrefSel pt =<< prefs)
|
||||
getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f =<< prefs)
|
||||
|
||||
instance PreferenceI FullPreferences where
|
||||
getPreference = \case
|
||||
CFFullDelete -> fullDelete
|
||||
SCFTimedMessages -> timedMessages
|
||||
SCFFullDelete -> fullDelete
|
||||
-- CFReceipts -> receipts
|
||||
CFVoice -> voice
|
||||
SCFVoice -> voice
|
||||
{-# INLINE getPreference #-}
|
||||
|
||||
setPreference :: ChatFeature -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences
|
||||
setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences
|
||||
setPreference f allow_ prefs_ =
|
||||
let prefs = toChatPrefs $ mergePreferences Nothing prefs_
|
||||
pref = (\allow -> (getPreference f prefs :: Preference) {allow}) <$> allow_
|
||||
let pref = setAllow <$> allow_
|
||||
in case f of
|
||||
CFVoice -> prefs {voice = pref}
|
||||
CFFullDelete -> prefs {fullDelete = pref}
|
||||
SCFTimedMessages -> prefs {timedMessages = pref}
|
||||
SCFFullDelete -> prefs {fullDelete = pref}
|
||||
SCFVoice -> prefs {voice = pref}
|
||||
where
|
||||
setAllow :: FeatureAllowed -> FeaturePreference f
|
||||
setAllow = setField @"allow" (getPreference f prefs)
|
||||
prefs = toChatPrefs $ mergePreferences Nothing prefs_
|
||||
|
||||
-- collection of optional chat preferences for the user and the contact
|
||||
data Preferences = Preferences
|
||||
{ fullDelete :: Maybe Preference,
|
||||
-- receipts :: Maybe Preference,
|
||||
voice :: Maybe Preference
|
||||
{ timedMessages :: Maybe TimedMessagesPreference,
|
||||
fullDelete :: Maybe FullDeletePreference,
|
||||
-- receipts :: Maybe SimplePreference,
|
||||
voice :: Maybe VoicePreference
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
|
|
@ -426,9 +460,10 @@ setGroupPreference f enable prefs_ =
|
|||
-- full collection of chat preferences defined in the app - it is used to ensure we include all preferences and to simplify processing
|
||||
-- if some of the preferences are not defined in Preferences, defaults from defaultChatPrefs are used here.
|
||||
data FullPreferences = FullPreferences
|
||||
{ fullDelete :: Preference,
|
||||
-- receipts :: Preference,
|
||||
voice :: Preference
|
||||
{ timedMessages :: TimedMessagesPreference,
|
||||
fullDelete :: FullDeletePreference,
|
||||
-- receipts :: SimplePreference,
|
||||
voice :: VoicePreference
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
|
|
@ -448,34 +483,36 @@ instance ToJSON FullGroupPreferences where toEncoding = J.genericToEncoding J.de
|
|||
|
||||
-- merged preferences of user for a given contact - they differentiate between specific preferences for the contact and global user preferences
|
||||
data ContactUserPreferences = ContactUserPreferences
|
||||
{ fullDelete :: ContactUserPreference,
|
||||
{ timedMessages :: ContactUserPreference TimedMessagesPreference,
|
||||
fullDelete :: ContactUserPreference FullDeletePreference,
|
||||
-- receipts :: ContactUserPreference,
|
||||
voice :: ContactUserPreference
|
||||
voice :: ContactUserPreference VoicePreference
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
data ContactUserPreference = ContactUserPreference
|
||||
data ContactUserPreference p = ContactUserPreference
|
||||
{ enabled :: PrefEnabled,
|
||||
userPreference :: ContactUserPref,
|
||||
contactPreference :: Preference
|
||||
userPreference :: ContactUserPref p,
|
||||
contactPreference :: p
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
data ContactUserPref = CUPContact {preference :: Preference} | CUPUser {preference :: Preference}
|
||||
data ContactUserPref p = CUPContact {preference :: p} | CUPUser {preference :: p}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON ContactUserPreferences where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance ToJSON ContactUserPreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
instance ToJSON p => ToJSON (ContactUserPreference p) where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance ToJSON ContactUserPref where
|
||||
instance ToJSON p => ToJSON (ContactUserPref p) where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CUP"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CUP"
|
||||
|
||||
toChatPrefs :: FullPreferences -> Preferences
|
||||
toChatPrefs FullPreferences {fullDelete, voice} =
|
||||
toChatPrefs FullPreferences {fullDelete, voice, timedMessages} =
|
||||
Preferences
|
||||
{ fullDelete = Just fullDelete,
|
||||
{ timedMessages = Just timedMessages,
|
||||
fullDelete = Just fullDelete,
|
||||
-- receipts = Just receipts,
|
||||
voice = Just voice
|
||||
}
|
||||
|
|
@ -483,13 +520,14 @@ toChatPrefs FullPreferences {fullDelete, voice} =
|
|||
defaultChatPrefs :: FullPreferences
|
||||
defaultChatPrefs =
|
||||
FullPreferences
|
||||
{ fullDelete = Preference {allow = FANo},
|
||||
-- receipts = Preference {allow = FANo},
|
||||
voice = Preference {allow = FAYes}
|
||||
{ timedMessages = TimedMessagesPreference {allow = FANo, ttl = 86400},
|
||||
fullDelete = FullDeletePreference {allow = FANo},
|
||||
-- receipts = SimplePreference {allow = FANo},
|
||||
voice = VoicePreference {allow = FAYes}
|
||||
}
|
||||
|
||||
emptyChatPrefs :: Preferences
|
||||
emptyChatPrefs = Preferences Nothing Nothing
|
||||
emptyChatPrefs = Preferences Nothing Nothing Nothing
|
||||
|
||||
defaultGroupPrefs :: FullGroupPreferences
|
||||
defaultGroupPrefs =
|
||||
|
|
@ -503,11 +541,44 @@ defaultGroupPrefs =
|
|||
emptyGroupPrefs :: GroupPreferences
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing
|
||||
|
||||
data Preference = Preference
|
||||
{allow :: FeatureAllowed}
|
||||
data TimedMessagesPreference = TimedMessagesPreference
|
||||
{ allow :: FeatureAllowed,
|
||||
ttl :: Int
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON Preference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
instance ToJSON TimedMessagesPreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data FullDeletePreference = FullDeletePreference {allow :: FeatureAllowed}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON FullDeletePreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data VoicePreference = VoicePreference {allow :: FeatureAllowed}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON VoicePreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
class (Eq (FeaturePreference f), HasField "allow" (FeaturePreference f) FeatureAllowed) => FeatureI f where
|
||||
type FeaturePreference (f :: ChatFeature) = p | p -> f
|
||||
|
||||
instance HasField "allow" TimedMessagesPreference FeatureAllowed where
|
||||
hasField p = (\allow -> p {allow}, allow (p :: TimedMessagesPreference))
|
||||
|
||||
instance HasField "allow" FullDeletePreference FeatureAllowed where
|
||||
hasField p = (\allow -> p {allow}, allow (p :: FullDeletePreference))
|
||||
|
||||
instance HasField "allow" VoicePreference FeatureAllowed where
|
||||
hasField p = (\allow -> p {allow}, allow (p :: VoicePreference))
|
||||
|
||||
instance FeatureI 'CFTimedMessages where
|
||||
type FeaturePreference 'CFTimedMessages = TimedMessagesPreference
|
||||
|
||||
instance FeatureI 'CFFullDelete where
|
||||
type FeaturePreference 'CFFullDelete = FullDeletePreference
|
||||
|
||||
instance FeatureI 'CFVoice where
|
||||
type FeaturePreference 'CFVoice = VoicePreference
|
||||
|
||||
data GroupPreference = GroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
|
|
@ -574,14 +645,16 @@ instance ToJSON GroupFeatureEnabled where
|
|||
mergePreferences :: Maybe Preferences -> Maybe Preferences -> FullPreferences
|
||||
mergePreferences contactPrefs userPreferences =
|
||||
FullPreferences
|
||||
{ fullDelete = pref CFFullDelete,
|
||||
{ timedMessages = pref SCFTimedMessages,
|
||||
fullDelete = pref SCFFullDelete,
|
||||
-- receipts = pref CFReceipts,
|
||||
voice = pref CFVoice
|
||||
voice = pref SCFVoice
|
||||
}
|
||||
where
|
||||
pref pt =
|
||||
let sel = chatPrefSel pt
|
||||
in fromMaybe (getPreference pt defaultChatPrefs) $ (contactPrefs >>= sel) <|> (userPreferences >>= sel)
|
||||
pref :: SChatFeature f -> FeaturePreference f
|
||||
pref f =
|
||||
let sel = chatPrefSel f
|
||||
in fromMaybe (getPreference f defaultChatPrefs) $ (contactPrefs >>= sel) <|> (userPreferences >>= sel)
|
||||
|
||||
mergeUserChatPrefs :: User -> Contact -> FullPreferences
|
||||
mergeUserChatPrefs user ct = mergeUserChatPrefs' user (contactConnIncognito ct) (userPreferences ct)
|
||||
|
|
@ -620,8 +693,8 @@ instance ToJSON PrefEnabled where
|
|||
toJSON = J.genericToJSON J.defaultOptions
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
prefEnabled :: Preference -> Preference -> PrefEnabled
|
||||
prefEnabled Preference {allow = user} Preference {allow = contact} = case (user, contact) of
|
||||
prefEnabled :: FeatureI f => FeaturePreference f -> FeaturePreference f -> PrefEnabled
|
||||
prefEnabled user contact = case (getField @"allow" user, getField @"allow" contact) of
|
||||
(FAAlways, FANo) -> PrefEnabled {forUser = False, forContact = True}
|
||||
(FANo, FAAlways) -> PrefEnabled {forUser = True, forContact = False}
|
||||
(_, FANo) -> PrefEnabled False False
|
||||
|
|
@ -643,12 +716,14 @@ updateMergedPreferences user ct =
|
|||
contactUserPreferences :: User -> Preferences -> Maybe Preferences -> Bool -> ContactUserPreferences
|
||||
contactUserPreferences user userPreferences contactPreferences connectedIncognito =
|
||||
ContactUserPreferences
|
||||
{ fullDelete = pref CFFullDelete,
|
||||
{ timedMessages = pref SCFTimedMessages,
|
||||
fullDelete = pref SCFFullDelete,
|
||||
-- receipts = pref CFReceipts,
|
||||
voice = pref CFVoice
|
||||
voice = pref SCFVoice
|
||||
}
|
||||
where
|
||||
pref pt =
|
||||
pref :: FeatureI f => SChatFeature f -> ContactUserPreference (FeaturePreference f)
|
||||
pref f =
|
||||
ContactUserPreference
|
||||
{ enabled = prefEnabled userPref ctPref,
|
||||
-- incognito contact cannot have default user preference used
|
||||
|
|
@ -656,18 +731,19 @@ contactUserPreferences user userPreferences contactPreferences connectedIncognit
|
|||
contactPreference = ctPref
|
||||
}
|
||||
where
|
||||
ctUserPref = getPreference pt userPreferences
|
||||
ctUserPref_ = chatPrefSel pt userPreferences
|
||||
userPref = getPreference pt ctUserPrefs
|
||||
ctPref = getPreference pt ctPrefs
|
||||
ctUserPref = getPreference f userPreferences
|
||||
ctUserPref_ = chatPrefSel f userPreferences
|
||||
userPref = getPreference f ctUserPrefs
|
||||
ctPref = getPreference f ctPrefs
|
||||
ctUserPrefs = mergeUserChatPrefs' user connectedIncognito userPreferences
|
||||
ctPrefs = mergePreferences contactPreferences Nothing
|
||||
|
||||
getContactUserPreference :: ChatFeature -> ContactUserPreferences -> ContactUserPreference
|
||||
getContactUserPreference :: SChatFeature f -> ContactUserPreferences -> ContactUserPreference (FeaturePreference f)
|
||||
getContactUserPreference = \case
|
||||
CFFullDelete -> fullDelete
|
||||
SCFTimedMessages -> timedMessages
|
||||
SCFFullDelete -> fullDelete
|
||||
-- CFReceipts -> receipts
|
||||
CFVoice -> voice
|
||||
SCFVoice -> voice
|
||||
|
||||
data Profile = Profile
|
||||
{ displayName :: ContactName,
|
||||
|
|
|
|||
|
|
@ -50,6 +50,7 @@ import qualified Simplex.Messaging.Protocol as SMP
|
|||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
import System.Console.ANSI.Types
|
||||
import GHC.Records.Compat
|
||||
|
||||
type CurrentTime = UTCTime
|
||||
|
||||
|
|
@ -774,15 +775,15 @@ viewContactPreferences :: User -> Contact -> Contact -> ContactUserPreferences -
|
|||
viewContactPreferences user ct ct' cups =
|
||||
mapMaybe (viewContactPref (mergeUserChatPrefs user ct) (mergeUserChatPrefs user ct') (preferences' ct) cups) allChatFeatures
|
||||
|
||||
viewContactPref :: FullPreferences -> FullPreferences -> Maybe Preferences -> ContactUserPreferences -> ChatFeature -> Maybe StyledString
|
||||
viewContactPref userPrefs userPrefs' ctPrefs cups pt
|
||||
viewContactPref :: FullPreferences -> FullPreferences -> Maybe Preferences -> ContactUserPreferences -> AChatFeature -> Maybe StyledString
|
||||
viewContactPref userPrefs userPrefs' ctPrefs cups (ACF f)
|
||||
| userPref == userPref' && ctPref == contactPreference = Nothing
|
||||
| otherwise = Just $ plain (chatFeatureToText pt) <> ": " <> plain (prefEnabledToText enabled) <> " (you allow: " <> viewCountactUserPref userPreference <> ", contact allows: " <> viewPreference contactPreference <> ")"
|
||||
| otherwise = Just $ plain (chatFeatureToText $ chatFeature f) <> ": " <> plain (prefEnabledToText enabled) <> " (you allow: " <> viewCountactUserPref userPreference <> ", contact allows: " <> viewPreference contactPreference <> ")"
|
||||
where
|
||||
userPref = getPreference pt userPrefs
|
||||
userPref' = getPreference pt userPrefs'
|
||||
ctPref = getPreference pt ctPrefs
|
||||
ContactUserPreference {enabled, userPreference, contactPreference} = getContactUserPreference pt cups
|
||||
userPref = getPreference f userPrefs
|
||||
userPref' = getPreference f userPrefs'
|
||||
ctPref = getPreference f ctPrefs
|
||||
ContactUserPreference {enabled, userPreference, contactPreference} = getContactUserPreference f cups
|
||||
|
||||
viewPrefsUpdated :: Maybe Preferences -> Maybe Preferences -> [StyledString]
|
||||
viewPrefsUpdated ps ps'
|
||||
|
|
@ -790,20 +791,19 @@ viewPrefsUpdated ps ps'
|
|||
| otherwise = "updated preferences:" : prefs
|
||||
where
|
||||
prefs = mapMaybe viewPref allChatFeatures
|
||||
viewPref pt
|
||||
viewPref (ACF f)
|
||||
| pref ps == pref ps' = Nothing
|
||||
| otherwise = Just $ plain (chatFeatureToText pt) <> " allowed: " <> viewPreference (pref ps')
|
||||
| otherwise = Just $ plain (chatFeatureToText $ chatFeature f) <> " allowed: " <> viewPreference (pref ps')
|
||||
where
|
||||
pref pss = getPreference pt $ mergePreferences pss Nothing
|
||||
pref pss = getPreference f $ mergePreferences pss Nothing
|
||||
|
||||
viewPreference :: Preference -> StyledString
|
||||
viewPreference = \case
|
||||
Preference {allow} -> case allow of
|
||||
FAAlways -> "always"
|
||||
FAYes -> "yes"
|
||||
FANo -> "no"
|
||||
viewPreference :: FeatureI f => FeaturePreference f -> StyledString
|
||||
viewPreference p = case getField @"allow" p of
|
||||
FAAlways -> "always"
|
||||
FAYes -> "yes"
|
||||
FANo -> "no"
|
||||
|
||||
viewCountactUserPref :: ContactUserPref -> StyledString
|
||||
viewCountactUserPref :: FeatureI f => ContactUserPref (FeaturePreference f) -> StyledString
|
||||
viewCountactUserPref = \case
|
||||
CUPUser p -> "default (" <> viewPreference p <> ")"
|
||||
CUPContact p -> viewPreference p
|
||||
|
|
|
|||
|
|
@ -734,7 +734,7 @@ testGroup2 =
|
|||
<##? [ "dan> hi",
|
||||
"@dan hey"
|
||||
]
|
||||
alice ##> "/t 18"
|
||||
alice ##> "/t 21"
|
||||
alice
|
||||
<##? [ "@bob sent invitation to join group club as admin",
|
||||
"@cath sent invitation to join group club as admin",
|
||||
|
|
@ -748,10 +748,13 @@ testGroup2 =
|
|||
"#club dan> how is it going?",
|
||||
"dan> hi",
|
||||
"@dan hey",
|
||||
"dan> Disappearing messages: off",
|
||||
"dan> Full deletion: off",
|
||||
"dan> Voice messages: enabled",
|
||||
"bob> Disappearing messages: off",
|
||||
"bob> Full deletion: off",
|
||||
"bob> Voice messages: enabled",
|
||||
"cath> Disappearing messages: off",
|
||||
"cath> Full deletion: off",
|
||||
"cath> Voice messages: enabled"
|
||||
]
|
||||
|
|
@ -1280,7 +1283,7 @@ testGroupMessageDelete =
|
|||
(cath <# "#team alice> hello!")
|
||||
|
||||
-- alice: deletes msg id 5
|
||||
alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted")
|
||||
alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " internal", id, "message deleted")
|
||||
|
||||
alice #$> ("/_get chat #1 count=1", chat, [(0, "connected")])
|
||||
bob #$> ("/_get chat #1 count=1", chat, [(0, "hello!")])
|
||||
|
|
@ -1306,14 +1309,14 @@ testGroupMessageDelete =
|
|||
cath #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((0, "hi alic"), Just (0, "hello!"))])
|
||||
|
||||
-- alice: deletes msg id 5
|
||||
alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted")
|
||||
alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " internal", id, "message deleted")
|
||||
|
||||
alice #$> ("/_get chat #1 count=1", chat', [((0, "connected"), Nothing)])
|
||||
bob #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((1, "hi alic"), Just (0, "hello!"))])
|
||||
cath #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((0, "hi alic"), Just (0, "hello!"))])
|
||||
|
||||
-- alice: msg id 5
|
||||
bob #$> ("/_update item #1 " <> groupItemId 2 7 <> " text hi alice", id, "message updated")
|
||||
bob #$> ("/_update item #1 " <> groupItemId' 2 3 <> " text hi alice", id, "message updated")
|
||||
concurrently_
|
||||
(alice <# "#team bob> [edited] hi alice")
|
||||
( do
|
||||
|
|
@ -1332,13 +1335,13 @@ testGroupMessageDelete =
|
|||
(alice <# "#team cath> how are you?")
|
||||
(bob <# "#team cath> how are you?")
|
||||
|
||||
cath #$> ("/_delete item #1 " <> groupItemId 2 7 <> " broadcast", id, "message marked deleted")
|
||||
cath #$> ("/_delete item #1 " <> groupItemId' 2 3 <> " broadcast", id, "message marked deleted")
|
||||
concurrently_
|
||||
(alice <# "#team cath> [marked deleted] how are you?")
|
||||
(bob <# "#team cath> [marked deleted] how are you?")
|
||||
|
||||
alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " broadcast", id, "cannot delete this item")
|
||||
alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted")
|
||||
alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " broadcast", id, "cannot delete this item")
|
||||
alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " internal", id, "message deleted")
|
||||
|
||||
alice #$> ("/_get chat #1 count=1", chat', [((0, "how are you? [marked deleted]"), Nothing)])
|
||||
bob #$> ("/_get chat #1 count=3", chat', [((0, "hello!"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "how are you? [marked deleted]"), Nothing)])
|
||||
|
|
@ -3333,7 +3336,7 @@ testSetContactPrefs = testChat2 aliceProfile bobProfile $
|
|||
alice ##> "/_set prefs @2 {}"
|
||||
alice <## "your preferences for bob did not change"
|
||||
(bob </)
|
||||
let startFeatures = [(0, "Full deletion: off"), (0, "Voice messages: off")]
|
||||
let startFeatures = [(0, "Disappearing messages: off"), (0, "Full deletion: off"), (0, "Voice messages: off")]
|
||||
alice #$> ("/_get chat @2 count=100", chat, startFeatures)
|
||||
bob #$> ("/_get chat @2 count=100", chat, startFeatures)
|
||||
let sendVoice = "/_send @2 json {\"filePath\": \"test.txt\", \"msgContent\": {\"type\": \"voice\", \"text\": \"\", \"duration\": 10}}"
|
||||
|
|
@ -3486,7 +3489,7 @@ testAllowFullDeletionGroup =
|
|||
bob <## "Full deletion enabled: on"
|
||||
alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "hi"), (0, "hey"), (1, "Full deletion: on")])
|
||||
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (1, "hey"), (0, "Full deletion: on")])
|
||||
bob #$> ("/_delete item #1 " <> groupItemId 2 5 <> " broadcast", id, "message deleted")
|
||||
bob #$> ("/_delete item #1 " <> groupItemId' 2 1 <> " broadcast", id, "message deleted")
|
||||
alice <# "#team bob> [deleted] hey"
|
||||
alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "hi"), (1, "Full deletion: on")])
|
||||
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (0, "Full deletion: on")])
|
||||
|
|
@ -4866,7 +4869,7 @@ chatFeaturesF :: [((Int, String), Maybe String)]
|
|||
chatFeaturesF = map (\(a, _, c) -> (a, c)) chatFeatures''
|
||||
|
||||
chatFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)]
|
||||
chatFeatures'' = [((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: enabled"), Nothing, Nothing)]
|
||||
chatFeatures'' = [((0, "Disappearing messages: off"), Nothing, Nothing), ((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: enabled"), Nothing, Nothing)]
|
||||
|
||||
groupFeatures :: [(Int, String)]
|
||||
groupFeatures = map (\(a, _, _) -> a) groupFeatures''
|
||||
|
|
@ -4880,6 +4883,9 @@ itemId i = show $ length chatFeatures + i
|
|||
groupItemId :: Int -> Int -> String
|
||||
groupItemId n i = show $ length chatFeatures * n + i
|
||||
|
||||
groupItemId' :: Int -> Int -> String
|
||||
groupItemId' n i = show $ length chatFeatures * n + length groupFeatures + i
|
||||
|
||||
(@@@) :: TestCC -> [(String, String)] -> Expectation
|
||||
(@@@) = getChats . map $ \(ldn, msg, _) -> (ldn, msg)
|
||||
|
||||
|
|
|
|||
|
|
@ -32,9 +32,9 @@ activeUserExists = "{\"resp\":{\"type\":\"chatCmdError\",\"chatError\":{\"type\"
|
|||
|
||||
activeUser :: String
|
||||
#if defined(darwin_HOST_OS) && defined(swiftJSON)
|
||||
activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
|
||||
activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\",\"ttl\":86400},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
|
||||
#else
|
||||
activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
|
||||
activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\",\"ttl\":86400},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
|
||||
#endif
|
||||
|
||||
chatStarted :: String
|
||||
|
|
|
|||
|
|
@ -80,7 +80,7 @@ s #==# msg = do
|
|||
s ==# msg
|
||||
|
||||
testChatPreferences :: Maybe Preferences
|
||||
testChatPreferences = Just Preferences {voice = Just Preference {allow = FAYes}, fullDelete = Nothing}
|
||||
testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, fullDelete = Nothing, timedMessages = Nothing}
|
||||
|
||||
testGroupPreferences :: Maybe GroupPreferences
|
||||
testGroupPreferences = Just GroupPreferences {directMessages = Nothing, voice = Just GroupPreference {enable = FEOn}, fullDelete = Nothing}
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue