core: different types for chat preferences, to allow parameters (#1565)

This commit is contained in:
Evgeny Poberezkin
2022-12-13 14:52:34 +00:00
committed by GitHub
parent bd4c7dffbf
commit 678dbec3e2
8 changed files with 190 additions and 100 deletions
+135 -59
View File
@@ -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,
+17 -17
View File
@@ -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