mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
core: type for group preference for timed messages (#1568)
* core: type for group preference for timed messages * remove unused func
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
21765905a7
commit
7b8f5be821
+20
-22
@@ -341,7 +341,7 @@ processChatCommand = \case
|
||||
CTGroup -> do
|
||||
Group gInfo@GroupInfo {membership, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
|
||||
if isVoice mc && not (groupFeatureAllowed GFVoice gInfo)
|
||||
if isVoice mc && not (groupFeatureAllowed SGFVoice gInfo)
|
||||
then pure $ chatCmdError $ "feature not allowed " <> T.unpack (groupFeatureToText GFVoice)
|
||||
else do
|
||||
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo (length $ filter memberCurrent ms)
|
||||
@@ -467,7 +467,7 @@ processChatCommand = \case
|
||||
(CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
|
||||
SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgDel itemSharedMId)
|
||||
setActive $ ActiveG gName
|
||||
if groupFeatureAllowed GFFullDelete gInfo
|
||||
if groupFeatureAllowed SGFFullDelete gInfo
|
||||
then deleteGroupCI user gInfo ci True
|
||||
else markGroupCIDeleted user gInfo ci msgId True
|
||||
(CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete
|
||||
@@ -1113,16 +1113,14 @@ processChatCommand = \case
|
||||
UpdateProfileImage image -> withUser $ \user@User {profile} -> do
|
||||
let p = (fromLocalProfile profile :: Profile) {image}
|
||||
updateProfile user p
|
||||
SetUserFeature cf allowed -> withUser $ \user@User {profile} -> do
|
||||
ACF f <- pure $ aChatFeature cf
|
||||
SetUserFeature (ACF f) allowed -> withUser $ \user@User {profile} -> do
|
||||
let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user}
|
||||
updateProfile user p
|
||||
SetContactFeature cf cName allowed_ -> withUser $ \user -> do
|
||||
SetContactFeature (ACF f) 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 ->
|
||||
SetGroupFeature (AGF f) gName enabled ->
|
||||
updateGroupProfileByName gName $ \p ->
|
||||
p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p}
|
||||
QuitChat -> liftIO exitSuccess
|
||||
@@ -1322,7 +1320,7 @@ assertDirectAllowed user dir ct event =
|
||||
unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $
|
||||
throwChatError $ CEDirectMessagesProhibited dir ct
|
||||
where
|
||||
directMessagesAllowed = any (groupFeatureAllowed' GFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct)
|
||||
directMessagesAllowed = any (groupFeatureAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct)
|
||||
allowedChatEvent = case event of
|
||||
XMsgNew_ -> False
|
||||
XMsgUpdate_ -> False
|
||||
@@ -2374,7 +2372,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
||||
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
|
||||
newGroupContentMessage gInfo@GroupInfo {chatSettings} m@GroupMember {localDisplayName = c} mc msg msgMeta = do
|
||||
let (ExtMsgContent content fInv_) = mcExtMsgContent mc
|
||||
if isVoice content && not (groupFeatureAllowed GFVoice gInfo)
|
||||
if isVoice content && not (groupFeatureAllowed SGFVoice gInfo)
|
||||
then void $ newChatItem (CIRcvGroupFeatureRejected GFVoice) Nothing
|
||||
else do
|
||||
ciFile_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
@@ -2421,7 +2419,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
||||
(SMDRcv, CIGroupRcv m) ->
|
||||
if sameMemberId memberId m
|
||||
then
|
||||
if groupFeatureAllowed GFFullDelete gInfo
|
||||
if groupFeatureAllowed SGFFullDelete gInfo
|
||||
then deleteGroupCI user gInfo ci False >>= toView
|
||||
else markGroupCIDeleted user gInfo ci msgId False >>= toView
|
||||
else messageError "x.msg.del: group member attempted to delete a message of another member" -- shouldn't happen now that query includes group member id
|
||||
@@ -2630,9 +2628,9 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
||||
createGroupFeatureItems :: GroupInfo -> GroupMember -> m ()
|
||||
createGroupFeatureItems g@GroupInfo {groupProfile} m = do
|
||||
let prefs = mergeGroupPreferences $ groupPreferences groupProfile
|
||||
forM_ allGroupFeatures $ \f -> do
|
||||
forM_ allGroupFeatures $ \(AGF f) -> do
|
||||
let p = getGroupPreference f prefs
|
||||
createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature f p) Nothing
|
||||
createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p)) Nothing
|
||||
|
||||
xInfoProbe :: Contact -> Probe -> m ()
|
||||
xInfoProbe c2 probe =
|
||||
@@ -3254,11 +3252,11 @@ createFeatureChangedItems user Contact {mergedPreferences = cups} ct'@Contact {m
|
||||
|
||||
createGroupFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> CIContent d) -> GroupProfile -> GroupProfile -> m ()
|
||||
createGroupFeatureChangedItems user cd ciContent p p' =
|
||||
forM_ allGroupFeatures $ \f -> do
|
||||
forM_ allGroupFeatures $ \(AGF f) -> do
|
||||
let pref = getGroupPreference f $ groupPreferences p
|
||||
pref' = getGroupPreference f $ groupPreferences p'
|
||||
unless (pref == pref') $
|
||||
createInternalChatItem user cd (ciContent f pref') Nothing
|
||||
createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref')) Nothing
|
||||
|
||||
sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool
|
||||
sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing}
|
||||
@@ -3532,13 +3530,13 @@ chatCommandP =
|
||||
"/profile_image" $> UpdateProfileImage Nothing,
|
||||
("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> userNames),
|
||||
("/profile" <|> "/p") $> ShowProfile,
|
||||
"/set voice #" *> (SetGroupFeature GFVoice <$> displayName <*> (A.space *> strP)),
|
||||
"/set voice @" *> (SetContactFeature CFVoice <$> displayName <*> optional (A.space *> strP)),
|
||||
"/set voice " *> (SetUserFeature CFVoice <$> strP),
|
||||
"/set delete #" *> (SetGroupFeature GFFullDelete <$> displayName <*> (A.space *> strP)),
|
||||
"/set delete @" *> (SetContactFeature CFFullDelete <$> displayName <*> optional (A.space *> strP)),
|
||||
"/set delete " *> (SetUserFeature CFFullDelete <$> strP),
|
||||
"/set direct #" *> (SetGroupFeature GFDirectMessages <$> displayName <*> (A.space *> strP)),
|
||||
"/set voice #" *> (SetGroupFeature (AGF SGFVoice) <$> displayName <*> (A.space *> strP)),
|
||||
"/set voice @" *> (SetContactFeature (ACF SCFVoice) <$> displayName <*> optional (A.space *> strP)),
|
||||
"/set voice " *> (SetUserFeature (ACF SCFVoice) <$> strP),
|
||||
"/set delete #" *> (SetGroupFeature (AGF 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)),
|
||||
"/incognito " *> (SetIncognito <$> onOffP),
|
||||
("/quit" <|> "/q" <|> "/exit") $> QuitChat,
|
||||
("/version" <|> "/v") $> ShowVersion,
|
||||
@@ -3573,7 +3571,7 @@ chatCommandP =
|
||||
groupProfile = do
|
||||
gName <- displayName
|
||||
fullName <- fullNameP gName
|
||||
let groupPreferences = Just (emptyGroupPrefs :: GroupPreferences) {directMessages = Just GroupPreference {enable = FEOn}}
|
||||
let groupPreferences = Just (emptyGroupPrefs :: GroupPreferences) {directMessages = Just DirectMessagesGroupPreference {enable = FEOn}}
|
||||
pure GroupProfile {displayName = gName, fullName, description = Nothing, image = Nothing, groupPreferences}
|
||||
fullNameP name = do
|
||||
n <- (A.space *> A.takeByteString) <|> pure ""
|
||||
|
||||
@@ -260,9 +260,9 @@ data ChatCommand
|
||||
| ShowProfile
|
||||
| UpdateProfile ContactName Text
|
||||
| UpdateProfileImage (Maybe ImageData)
|
||||
| SetUserFeature ChatFeature FeatureAllowed
|
||||
| SetContactFeature ChatFeature ContactName (Maybe FeatureAllowed)
|
||||
| SetGroupFeature GroupFeature GroupName GroupFeatureEnabled
|
||||
| SetUserFeature AChatFeature FeatureAllowed
|
||||
| SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)
|
||||
| SetGroupFeature AGroupFeature GroupName GroupFeatureEnabled
|
||||
| QuitChat
|
||||
| ShowVersion
|
||||
| DebugLocks
|
||||
|
||||
+140
-48
@@ -13,6 +13,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
@@ -274,8 +275,12 @@ data SChatFeature (f :: ChatFeature) where
|
||||
SCFFullDelete :: SChatFeature 'CFFullDelete
|
||||
SCFVoice :: SChatFeature 'CFVoice
|
||||
|
||||
deriving instance Show (SChatFeature f)
|
||||
|
||||
data AChatFeature = forall f. FeatureI f => ACF (SChatFeature f)
|
||||
|
||||
deriving instance Show AChatFeature
|
||||
|
||||
chatFeatureToText :: ChatFeature -> Text
|
||||
chatFeatureToText = \case
|
||||
CFTimedMessages -> "Disappearing messages"
|
||||
@@ -315,12 +320,6 @@ chatFeature = \case
|
||||
SCFFullDelete -> CFFullDelete
|
||||
SCFVoice -> CFVoice
|
||||
|
||||
aChatFeature :: ChatFeature -> AChatFeature
|
||||
aChatFeature = \case
|
||||
CFTimedMessages -> ACF SCFTimedMessages
|
||||
CFFullDelete -> ACF SCFFullDelete
|
||||
CFVoice -> ACF SCFVoice
|
||||
|
||||
class PreferenceI p where
|
||||
getPreference :: SChatFeature f -> p -> FeaturePreference f
|
||||
|
||||
@@ -370,25 +369,39 @@ instance FromField Preferences where
|
||||
fromField = fromTextField_ decodeJSON
|
||||
|
||||
data GroupFeature
|
||||
= GFDirectMessages
|
||||
= GFTimedMessages
|
||||
| GFDirectMessages
|
||||
| GFFullDelete
|
||||
| -- | GFReceipts
|
||||
GFVoice
|
||||
deriving (Show, Generic)
|
||||
|
||||
data SGroupFeature (f :: GroupFeature) where
|
||||
SGFTimedMessages :: SGroupFeature 'GFTimedMessages
|
||||
SGFDirectMessages :: SGroupFeature 'GFDirectMessages
|
||||
SGFFullDelete :: SGroupFeature 'GFFullDelete
|
||||
-- SGFReceipts
|
||||
SGFVoice :: SGroupFeature 'GFVoice
|
||||
|
||||
deriving instance Show (SGroupFeature f)
|
||||
|
||||
data AGroupFeature = forall f. GroupFeatureI f => AGF (SGroupFeature f)
|
||||
|
||||
deriving instance Show AGroupFeature
|
||||
|
||||
groupFeatureToText :: GroupFeature -> Text
|
||||
groupFeatureToText = \case
|
||||
GFTimedMessages -> "Disappearing messages"
|
||||
GFDirectMessages -> "Direct messages"
|
||||
GFFullDelete -> "Full deletion"
|
||||
GFVoice -> "Voice messages"
|
||||
|
||||
groupFeatureAllowed :: GroupFeature -> GroupInfo -> Bool
|
||||
groupFeatureAllowed :: GroupFeatureI f => SGroupFeature f -> GroupInfo -> Bool
|
||||
groupFeatureAllowed feature gInfo = groupFeatureAllowed' feature $ fullGroupPreferences gInfo
|
||||
|
||||
groupFeatureAllowed' :: GroupFeature -> FullGroupPreferences -> Bool
|
||||
groupFeatureAllowed' :: GroupFeatureI f => SGroupFeature f -> FullGroupPreferences -> Bool
|
||||
groupFeatureAllowed' feature prefs =
|
||||
let GroupPreference {enable} = getGroupPreference feature prefs
|
||||
in enable == FEOn
|
||||
getField @"enable" (getGroupPreference feature prefs) == FEOn
|
||||
|
||||
instance ToJSON GroupFeature where
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "GF"
|
||||
@@ -397,23 +410,32 @@ instance ToJSON GroupFeature where
|
||||
instance FromJSON GroupFeature where
|
||||
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "GF"
|
||||
|
||||
allGroupFeatures :: [GroupFeature]
|
||||
allGroupFeatures :: [AGroupFeature]
|
||||
allGroupFeatures =
|
||||
[ GFDirectMessages,
|
||||
GFFullDelete,
|
||||
[ AGF SGFTimedMessages,
|
||||
AGF SGFDirectMessages,
|
||||
AGF SGFFullDelete,
|
||||
-- GFReceipts,
|
||||
GFVoice
|
||||
AGF SGFVoice
|
||||
]
|
||||
|
||||
groupPrefSel :: GroupFeature -> GroupPreferences -> Maybe GroupPreference
|
||||
groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
|
||||
groupPrefSel = \case
|
||||
GFDirectMessages -> directMessages
|
||||
GFFullDelete -> fullDelete
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
-- GFReceipts -> receipts
|
||||
GFVoice -> voice
|
||||
SGFVoice -> voice
|
||||
|
||||
toGroupFeature :: SGroupFeature f -> GroupFeature
|
||||
toGroupFeature = \case
|
||||
SGFTimedMessages -> GFTimedMessages
|
||||
SGFDirectMessages -> GFDirectMessages
|
||||
SGFFullDelete -> GFFullDelete
|
||||
SGFVoice -> GFVoice
|
||||
|
||||
class GroupPreferenceI p where
|
||||
getGroupPreference :: GroupFeature -> p -> GroupPreference
|
||||
getGroupPreference :: SGroupFeature f -> p -> GroupFeaturePreference f
|
||||
|
||||
instance GroupPreferenceI GroupPreferences where
|
||||
getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt prefs)
|
||||
@@ -423,18 +445,20 @@ instance GroupPreferenceI (Maybe GroupPreferences) where
|
||||
|
||||
instance GroupPreferenceI FullGroupPreferences where
|
||||
getGroupPreference = \case
|
||||
GFDirectMessages -> directMessages
|
||||
GFFullDelete -> fullDelete
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
-- GFReceipts -> receipts
|
||||
GFVoice -> voice
|
||||
SGFVoice -> voice
|
||||
{-# INLINE getGroupPreference #-}
|
||||
|
||||
-- collection of optional group preferences
|
||||
data GroupPreferences = GroupPreferences
|
||||
{ directMessages :: Maybe GroupPreference,
|
||||
fullDelete :: Maybe GroupPreference,
|
||||
{ timedMessages :: Maybe TimedMessagesGroupPreference,
|
||||
directMessages :: Maybe DirectMessagesGroupPreference,
|
||||
fullDelete :: Maybe FullDeleteGroupPreference,
|
||||
-- receipts :: Maybe GroupPreference,
|
||||
voice :: Maybe GroupPreference
|
||||
voice :: Maybe VoiceGroupPreference
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
@@ -448,14 +472,17 @@ instance ToField GroupPreferences where
|
||||
instance FromField GroupPreferences where
|
||||
fromField = fromTextField_ decodeJSON
|
||||
|
||||
setGroupPreference :: GroupFeature -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreference :: forall f. GroupFeatureI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences
|
||||
setGroupPreference f enable prefs_ =
|
||||
let prefs = mergeGroupPreferences prefs_
|
||||
pref = (getGroupPreference f prefs :: GroupPreference) {enable}
|
||||
in toGroupPreferences $ case f of
|
||||
GFDirectMessages -> prefs {directMessages = pref}
|
||||
GFVoice -> prefs {voice = pref}
|
||||
GFFullDelete -> prefs {fullDelete = pref}
|
||||
toGroupPreferences $ case f of
|
||||
SGFTimedMessages -> prefs {timedMessages = pref}
|
||||
SGFDirectMessages -> prefs {directMessages = pref}
|
||||
SGFVoice -> prefs {voice = pref}
|
||||
SGFFullDelete -> prefs {fullDelete = pref}
|
||||
where
|
||||
prefs = mergeGroupPreferences prefs_
|
||||
pref :: GroupFeaturePreference f
|
||||
pref = setField @"enable" (getGroupPreference f prefs) enable
|
||||
|
||||
-- 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.
|
||||
@@ -472,10 +499,11 @@ instance ToJSON FullPreferences where toEncoding = J.genericToEncoding J.default
|
||||
-- full collection of group 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 GroupPreferences, defaults from defaultGroupPrefs are used here.
|
||||
data FullGroupPreferences = FullGroupPreferences
|
||||
{ directMessages :: GroupPreference,
|
||||
fullDelete :: GroupPreference,
|
||||
{ timedMessages :: TimedMessagesGroupPreference,
|
||||
directMessages :: DirectMessagesGroupPreference,
|
||||
fullDelete :: FullDeleteGroupPreference,
|
||||
-- receipts :: GroupPreference,
|
||||
voice :: GroupPreference
|
||||
voice :: VoiceGroupPreference
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
@@ -532,14 +560,15 @@ emptyChatPrefs = Preferences Nothing Nothing Nothing
|
||||
defaultGroupPrefs :: FullGroupPreferences
|
||||
defaultGroupPrefs =
|
||||
FullGroupPreferences
|
||||
{ directMessages = GroupPreference {enable = FEOff},
|
||||
fullDelete = GroupPreference {enable = FEOff},
|
||||
{ timedMessages = TimedMessagesGroupPreference {enable = FEOff, ttl = 86400},
|
||||
directMessages = DirectMessagesGroupPreference {enable = FEOff},
|
||||
fullDelete = FullDeleteGroupPreference {enable = FEOff},
|
||||
-- receipts = GroupPreference {enable = FEOff},
|
||||
voice = GroupPreference {enable = FEOn}
|
||||
voice = VoiceGroupPreference {enable = FEOn}
|
||||
}
|
||||
|
||||
emptyGroupPrefs :: GroupPreferences
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing
|
||||
|
||||
data TimedMessagesPreference = TimedMessagesPreference
|
||||
{ allow :: FeatureAllowed,
|
||||
@@ -584,11 +613,70 @@ data GroupPreference = GroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
groupPrefToText :: GroupPreference -> Text
|
||||
groupPrefToText GroupPreference {enable} = safeDecodeUtf8 $ strEncode enable
|
||||
data TimedMessagesGroupPreference = TimedMessagesGroupPreference
|
||||
{ enable :: GroupFeatureEnabled,
|
||||
ttl :: Int
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
data DirectMessagesGroupPreference = DirectMessagesGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
data FullDeleteGroupPreference = FullDeleteGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
data VoiceGroupPreference = VoiceGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON GroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance ToJSON TimedMessagesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance ToJSON DirectMessagesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance ToJSON FullDeleteGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
instance ToJSON VoiceGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference f) GroupFeatureEnabled) => GroupFeatureI f where
|
||||
type GroupFeaturePreference (f :: GroupFeature) = p | p -> f
|
||||
|
||||
instance HasField "enable" GroupPreference GroupFeatureEnabled where
|
||||
hasField p = (\enable -> p {enable}, enable (p :: GroupPreference))
|
||||
|
||||
instance HasField "enable" TimedMessagesGroupPreference GroupFeatureEnabled where
|
||||
hasField p = (\enable -> p {enable}, enable (p :: TimedMessagesGroupPreference))
|
||||
|
||||
instance HasField "enable" DirectMessagesGroupPreference GroupFeatureEnabled where
|
||||
hasField p = (\enable -> p {enable}, enable (p :: DirectMessagesGroupPreference))
|
||||
|
||||
instance HasField "enable" FullDeleteGroupPreference GroupFeatureEnabled where
|
||||
hasField p = (\enable -> p {enable}, enable (p :: FullDeleteGroupPreference))
|
||||
|
||||
instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where
|
||||
hasField p = (\enable -> p {enable}, enable (p :: VoiceGroupPreference))
|
||||
|
||||
instance GroupFeatureI 'GFTimedMessages where
|
||||
type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference
|
||||
|
||||
instance GroupFeatureI 'GFDirectMessages where
|
||||
type GroupFeaturePreference 'GFDirectMessages = DirectMessagesGroupPreference
|
||||
|
||||
instance GroupFeatureI 'GFFullDelete where
|
||||
type GroupFeaturePreference 'GFFullDelete = FullDeleteGroupPreference
|
||||
|
||||
instance GroupFeatureI 'GFVoice where
|
||||
type GroupFeaturePreference 'GFVoice = VoiceGroupPreference
|
||||
|
||||
groupPrefToText :: HasField "enable" p GroupFeatureEnabled => p -> Text
|
||||
groupPrefToText = safeDecodeUtf8 . strEncode . getField @"enable"
|
||||
|
||||
toGroupPreference :: GroupFeatureI f => GroupFeaturePreference f -> GroupPreference
|
||||
toGroupPreference p = GroupPreference {enable = getField @"enable" p}
|
||||
|
||||
data FeatureAllowed
|
||||
= FAAlways -- allow unconditionally
|
||||
| FAYes -- allow, if peer allows it
|
||||
@@ -667,23 +755,27 @@ mergeUserChatPrefs' user connectedIncognito userPreferences =
|
||||
mergeGroupPreferences :: Maybe GroupPreferences -> FullGroupPreferences
|
||||
mergeGroupPreferences groupPreferences =
|
||||
FullGroupPreferences
|
||||
{ directMessages = pref GFDirectMessages,
|
||||
fullDelete = pref GFFullDelete,
|
||||
{ timedMessages = pref SGFTimedMessages,
|
||||
directMessages = pref SGFDirectMessages,
|
||||
fullDelete = pref SGFFullDelete,
|
||||
-- receipts = pref GFReceipts,
|
||||
voice = pref GFVoice
|
||||
voice = pref SGFVoice
|
||||
}
|
||||
where
|
||||
pref :: SGroupFeature f -> GroupFeaturePreference f
|
||||
pref pt = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPreferences >>= groupPrefSel pt)
|
||||
|
||||
toGroupPreferences :: FullGroupPreferences -> GroupPreferences
|
||||
toGroupPreferences groupPreferences =
|
||||
GroupPreferences
|
||||
{ directMessages = pref GFDirectMessages,
|
||||
fullDelete = pref GFFullDelete,
|
||||
{ timedMessages = pref SGFTimedMessages,
|
||||
directMessages = pref SGFDirectMessages,
|
||||
fullDelete = pref SGFFullDelete,
|
||||
-- receipts = pref GFReceipts,
|
||||
voice = pref GFVoice
|
||||
voice = pref SGFVoice
|
||||
}
|
||||
where
|
||||
pref :: SGroupFeature f -> Maybe (GroupFeaturePreference f)
|
||||
pref f = Just $ getGroupPreference f groupPreferences
|
||||
|
||||
data PrefEnabled = PrefEnabled {forUser :: Bool, forContact :: Bool}
|
||||
|
||||
@@ -26,6 +26,7 @@ import Data.Time.Clock (DiffTime, UTCTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
import Data.Time.LocalTime (ZonedTime (..), localDay, localTimeOfDay, timeOfDayToTime, utcToZonedTime)
|
||||
import GHC.Generics (Generic)
|
||||
import GHC.Records.Compat
|
||||
import qualified Network.HTTP.Types as Q
|
||||
import Numeric (showFFloat)
|
||||
import Simplex.Chat (maxImageSize)
|
||||
@@ -50,7 +51,6 @@ 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
|
||||
|
||||
@@ -829,11 +829,11 @@ viewGroupUpdated
|
||||
| otherwise = bold' "updated group preferences:" : prefs
|
||||
where
|
||||
prefs = mapMaybe viewPref allGroupFeatures
|
||||
viewPref pt
|
||||
viewPref (AGF f)
|
||||
| pref gps == pref gps' = Nothing
|
||||
| otherwise = Just $ plain (groupFeatureToText pt) <> " enabled: " <> plain (groupPrefToText $ pref gps')
|
||||
| otherwise = Just $ plain (groupFeatureToText $ toGroupFeature f) <> " enabled: " <> plain (groupPrefToText $ pref gps')
|
||||
where
|
||||
pref = getGroupPreference pt . mergeGroupPreferences
|
||||
pref = getGroupPreference f . mergeGroupPreferences
|
||||
|
||||
viewGroupProfile :: GroupInfo -> [StyledString]
|
||||
viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, groupPreferences = gps}} =
|
||||
@@ -842,9 +842,9 @@ viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, g
|
||||
<> maybe [] ((bold' "description:" :) . map plain . T.lines) description
|
||||
<> (bold' "group preferences:" : map viewPref allGroupFeatures)
|
||||
where
|
||||
viewPref pt = plain (groupFeatureToText pt) <> " enabled: " <> plain (groupPrefToText $ pref gps)
|
||||
viewPref (AGF f) = plain (groupFeatureToText $ toGroupFeature f) <> " enabled: " <> plain (groupPrefToText $ pref gps)
|
||||
where
|
||||
pref = getGroupPreference pt . mergeGroupPreferences
|
||||
pref = getGroupPreference f . mergeGroupPreferences
|
||||
|
||||
bold' :: String -> StyledString
|
||||
bold' = styled Bold
|
||||
|
||||
Reference in New Issue
Block a user