diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 526051edb6..ba68c8621e 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -125,6 +125,8 @@ library Simplex.Chat.Terminal.Notification Simplex.Chat.Terminal.Output Simplex.Chat.Types + Simplex.Chat.Types.Preferences + Simplex.Chat.Types.Util Simplex.Chat.Util Simplex.Chat.View other-modules: diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 9f4988271d..df8120b9cb 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -67,6 +67,8 @@ import Simplex.Chat.Store.Messages import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Shared import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences +import Simplex.Chat.Types.Util import Simplex.FileTransfer.Client.Main (maxFileSize) import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) import Simplex.FileTransfer.Description (ValidFileDescription, gb, kb, mb) diff --git a/src/Simplex/Chat/Call.hs b/src/Simplex/Chat/Call.hs index 4483e701b8..7a738512bd 100644 --- a/src/Simplex/Chat/Call.hs +++ b/src/Simplex/Chat/Call.hs @@ -21,7 +21,8 @@ import Data.Time.Clock (UTCTime) import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics (Generic) -import Simplex.Chat.Types (Contact, ContactId, User, decodeJSON, encodeJSON) +import Simplex.Chat.Types (Contact, ContactId, User) +import Simplex.Chat.Types.Util (decodeJSON, encodeJSON) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 467857a86a..8091320717 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -47,6 +47,7 @@ import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol import Simplex.Chat.Store (AutoAccept, StoreError, UserContactLink, UserMsgReceiptSettings) import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent (AgentClient) import Simplex.Messaging.Agent.Client (AgentLocks, ProtocolTestFailure) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig) diff --git a/src/Simplex/Chat/Markdown.hs b/src/Simplex/Chat/Markdown.hs index b0beccb86b..1393831630 100644 --- a/src/Simplex/Chat/Markdown.hs +++ b/src/Simplex/Chat/Markdown.hs @@ -28,6 +28,7 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import GHC.Generics import Simplex.Chat.Types +import Simplex.Chat.Types.Util import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri (..), ConnReqScheme (..), ConnReqUriData (..), ConnectionRequestUri (..), SMPQueue (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, sumTypeJSON) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 23baa618ab..f2d6553a5a 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -35,6 +35,7 @@ import Simplex.Chat.Markdown import Simplex.Chat.Messages.CIContent import Simplex.Chat.Protocol import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptStatus (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON) diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index 40b139783b..725cf74cf9 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -29,6 +29,8 @@ import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics (Generic) import Simplex.Chat.Protocol import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences +import Simplex.Chat.Types.Util import Simplex.Messaging.Agent.Protocol (MsgErrorType (..), RatchetSyncState (..), SwitchPhase (..)) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, singleFieldJSON, sumTypeJSON) diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 62f8055da6..31d1eb5738 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -41,6 +41,7 @@ import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics (Generic) import Simplex.Chat.Call import Simplex.Chat.Types +import Simplex.Chat.Types.Util import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON) diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index 416986173c..4b66291fe9 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -23,6 +23,7 @@ import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Shared import Simplex.Chat.Protocol import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow') getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index da03ed3a7c..944527ae48 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -69,6 +69,7 @@ import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Store.Shared import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Protocol (ConnId, InvitationId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index c622f3e87b..c8b58fa857 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -97,6 +97,7 @@ import Simplex.Chat.Messages import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Shared import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Protocol (ConnId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Crypto as C diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 797f237f79..608befb54d 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -74,6 +74,7 @@ import Simplex.Chat.Protocol import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Shared import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Crypto as C diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index fc1444a8a9..6f368a774a 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -31,6 +31,7 @@ import GHC.Generics (Generic) import Simplex.Chat.Messages import Simplex.Chat.Protocol import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 1ddf3c3845..33a6bd0456 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -13,9 +13,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} @@ -24,7 +22,6 @@ module Simplex.Chat.Types where -import Control.Applicative ((<|>)) import Crypto.Number.Serialize (os2ip) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J @@ -33,27 +30,22 @@ 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 qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) -import Data.Typeable -import Database.SQLite.Simple (ResultError (..), SQLData (..)) -import Database.SQLite.Simple.FromField (FieldParser, FromField (..), returnError) -import Database.SQLite.Simple.Internal (Field (..)) -import Database.SQLite.Simple.Ok (Ok (Ok)) +import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics (Generic) -import GHC.Records.Compat +import Simplex.Chat.Types.Preferences +import Simplex.Chat.Types.Util import Simplex.FileTransfer.Description (FileDigest) import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON) +import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON, taggedObjectJSON) import Simplex.Messaging.Protocol (ProtoServerWithAuth, ProtocolTypeI) -import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) +import Simplex.Messaging.Util ((<$?>)) class IsContact a where contactId' :: a -> ContactId @@ -353,659 +345,14 @@ defaultChatSettings = ChatSettings pattern DisableNtfs :: ChatSettings pattern DisableNtfs <- ChatSettings {enableNtfs = False} -data ChatFeature - = CFTimedMessages - | CFFullDelete - | CFReactions - | CFVoice - | CFCalls - deriving (Show, Generic) - -data SChatFeature (f :: ChatFeature) where - SCFTimedMessages :: SChatFeature 'CFTimedMessages - SCFFullDelete :: SChatFeature 'CFFullDelete - SCFReactions :: SChatFeature 'CFReactions - SCFVoice :: SChatFeature 'CFVoice - SCFCalls :: SChatFeature 'CFCalls - -deriving instance Show (SChatFeature f) - -data AChatFeature = forall f. FeatureI f => ACF (SChatFeature f) - -deriving instance Show AChatFeature - -chatFeatureNameText :: ChatFeature -> Text -chatFeatureNameText = \case - CFTimedMessages -> "Disappearing messages" - CFFullDelete -> "Full deletion" - CFReactions -> "Message reactions" - CFVoice -> "Voice messages" - CFCalls -> "Audio/video calls" - -chatFeatureNameText' :: SChatFeature f -> Text -chatFeatureNameText' = chatFeatureNameText . chatFeature - featureAllowed :: SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool featureAllowed feature forWhom Contact {mergedPreferences} = let ContactUserPreference {enabled} = getContactUserPreference feature mergedPreferences in forWhom enabled -instance ToJSON ChatFeature where - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CF" - toJSON = J.genericToJSON . enumJSON $ dropPrefix "CF" - -instance FromJSON ChatFeature where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CF" - -allChatFeatures :: [AChatFeature] -allChatFeatures = - [ ACF SCFTimedMessages, - ACF SCFFullDelete, - ACF SCFReactions, - ACF SCFVoice, - ACF SCFCalls - ] - -chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f) -chatPrefSel = \case - SCFTimedMessages -> timedMessages - SCFFullDelete -> fullDelete - SCFReactions -> reactions - SCFVoice -> voice - SCFCalls -> calls - -chatFeature :: SChatFeature f -> ChatFeature -chatFeature = \case - SCFTimedMessages -> CFTimedMessages - SCFFullDelete -> CFFullDelete - SCFReactions -> CFReactions - SCFVoice -> CFVoice - SCFCalls -> CFCalls - -class PreferenceI p where - getPreference :: SChatFeature f -> p -> FeaturePreference f - -instance PreferenceI Preferences where - getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f prefs) - -instance PreferenceI (Maybe Preferences) where - getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f =<< prefs) - -instance PreferenceI FullPreferences where - getPreference = \case - SCFTimedMessages -> timedMessages - SCFFullDelete -> fullDelete - SCFReactions -> reactions - SCFVoice -> voice - SCFCalls -> calls - {-# INLINE getPreference #-} - -setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences -setPreference f allow_ prefs_ = setPreference_ f pref $ fromMaybe emptyChatPrefs prefs_ - where - pref = setAllow <$> allow_ - setAllow :: FeatureAllowed -> FeaturePreference f - setAllow = setField @"allow" (getPreference f prefs) - prefs = mergePreferences Nothing prefs_ - -setPreference' :: SChatFeature f -> Maybe (FeaturePreference f) -> Maybe Preferences -> Preferences -setPreference' f pref_ prefs_ = setPreference_ f pref_ $ fromMaybe emptyChatPrefs prefs_ - -setPreference_ :: SChatFeature f -> Maybe (FeaturePreference f) -> Preferences -> Preferences -setPreference_ f pref_ prefs = - case f of - SCFTimedMessages -> prefs {timedMessages = pref_} - SCFFullDelete -> prefs {fullDelete = pref_} - SCFReactions -> prefs {reactions = pref_} - SCFVoice -> prefs {voice = pref_} - SCFCalls -> prefs {calls = pref_} - --- collection of optional chat preferences for the user and the contact -data Preferences = Preferences - { timedMessages :: Maybe TimedMessagesPreference, - fullDelete :: Maybe FullDeletePreference, - reactions :: Maybe ReactionsPreference, - voice :: Maybe VoicePreference, - calls :: Maybe CallsPreference - } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON Preferences where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - -instance ToField Preferences where - toField = toField . encodeJSON - -instance FromField Preferences where - fromField = fromTextField_ decodeJSON - -data GroupFeature - = GFTimedMessages - | GFDirectMessages - | GFFullDelete - | GFReactions - | GFVoice - | GFFiles - deriving (Show, Generic) - -data SGroupFeature (f :: GroupFeature) where - SGFTimedMessages :: SGroupFeature 'GFTimedMessages - SGFDirectMessages :: SGroupFeature 'GFDirectMessages - SGFFullDelete :: SGroupFeature 'GFFullDelete - SGFReactions :: SGroupFeature 'GFReactions - SGFVoice :: SGroupFeature 'GFVoice - SGFFiles :: SGroupFeature 'GFFiles - -deriving instance Show (SGroupFeature f) - -data AGroupFeature = forall f. GroupFeatureI f => AGF (SGroupFeature f) - -deriving instance Show AGroupFeature - -groupFeatureNameText :: GroupFeature -> Text -groupFeatureNameText = \case - GFTimedMessages -> "Disappearing messages" - GFDirectMessages -> "Direct messages" - GFFullDelete -> "Full deletion" - GFReactions -> "Message reactions" - GFVoice -> "Voice messages" - GFFiles -> "Files and media" - -groupFeatureNameText' :: SGroupFeature f -> Text -groupFeatureNameText' = groupFeatureNameText . toGroupFeature - groupFeatureAllowed :: GroupFeatureI f => SGroupFeature f -> GroupInfo -> Bool groupFeatureAllowed feature gInfo = groupFeatureAllowed' feature $ fullGroupPreferences gInfo -groupFeatureAllowed' :: GroupFeatureI f => SGroupFeature f -> FullGroupPreferences -> Bool -groupFeatureAllowed' feature prefs = - getField @"enable" (getGroupPreference feature prefs) == FEOn - -instance ToJSON GroupFeature where - toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "GF" - toJSON = J.genericToJSON . enumJSON $ dropPrefix "GF" - -instance FromJSON GroupFeature where - parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "GF" - -allGroupFeatures :: [AGroupFeature] -allGroupFeatures = - [ AGF SGFTimedMessages, - AGF SGFDirectMessages, - AGF SGFFullDelete, - AGF SGFReactions, - AGF SGFVoice, - AGF SGFFiles - ] - -groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f) -groupPrefSel = \case - SGFTimedMessages -> timedMessages - SGFDirectMessages -> directMessages - SGFFullDelete -> fullDelete - SGFReactions -> reactions - SGFVoice -> voice - SGFFiles -> files - -toGroupFeature :: SGroupFeature f -> GroupFeature -toGroupFeature = \case - SGFTimedMessages -> GFTimedMessages - SGFDirectMessages -> GFDirectMessages - SGFFullDelete -> GFFullDelete - SGFReactions -> GFReactions - SGFVoice -> GFVoice - SGFFiles -> GFFiles - -class GroupPreferenceI p where - getGroupPreference :: SGroupFeature f -> p -> GroupFeaturePreference f - -instance GroupPreferenceI GroupPreferences where - getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt prefs) - -instance GroupPreferenceI (Maybe GroupPreferences) where - getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs) - -instance GroupPreferenceI FullGroupPreferences where - getGroupPreference = \case - SGFTimedMessages -> timedMessages - SGFDirectMessages -> directMessages - SGFFullDelete -> fullDelete - SGFReactions -> reactions - SGFVoice -> voice - SGFFiles -> files - {-# INLINE getGroupPreference #-} - --- collection of optional group preferences -data GroupPreferences = GroupPreferences - { timedMessages :: Maybe TimedMessagesGroupPreference, - directMessages :: Maybe DirectMessagesGroupPreference, - fullDelete :: Maybe FullDeleteGroupPreference, - reactions :: Maybe ReactionsGroupPreference, - voice :: Maybe VoiceGroupPreference, - files :: Maybe FilesGroupPreference - } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON GroupPreferences where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - -instance ToField GroupPreferences where - toField = toField . encodeJSON - -instance FromField GroupPreferences where - fromField = fromTextField_ decodeJSON - -setGroupPreference :: forall f. GroupFeatureI 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 - -setGroupPreference' :: SGroupFeature f -> GroupFeaturePreference f -> Maybe GroupPreferences -> GroupPreferences -setGroupPreference' f pref prefs_ = setGroupPreference_ f pref prefs - where - prefs = mergeGroupPreferences prefs_ - -setGroupPreference_ :: SGroupFeature f -> GroupFeaturePreference f -> FullGroupPreferences -> GroupPreferences -setGroupPreference_ f pref prefs = - toGroupPreferences $ case f of - SGFTimedMessages -> prefs {timedMessages = pref} - SGFDirectMessages -> prefs {directMessages = pref} - SGFFullDelete -> prefs {fullDelete = pref} - SGFReactions -> prefs {reactions = pref} - SGFVoice -> prefs {voice = pref} - SGFFiles -> prefs {files = pref} - -setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences -setGroupTimedMessagesPreference pref prefs_ = - toGroupPreferences $ prefs {timedMessages = pref} - where - prefs = mergeGroupPreferences 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 - { timedMessages :: TimedMessagesPreference, - fullDelete :: FullDeletePreference, - reactions :: ReactionsPreference, - voice :: VoicePreference, - calls :: CallsPreference - } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON FullPreferences where toEncoding = J.genericToEncoding J.defaultOptions - --- 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 - { timedMessages :: TimedMessagesGroupPreference, - directMessages :: DirectMessagesGroupPreference, - fullDelete :: FullDeleteGroupPreference, - reactions :: ReactionsGroupPreference, - voice :: VoiceGroupPreference, - files :: FilesGroupPreference - } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON FullGroupPreferences where toEncoding = J.genericToEncoding J.defaultOptions - --- merged preferences of user for a given contact - they differentiate between specific preferences for the contact and global user preferences -data ContactUserPreferences = ContactUserPreferences - { timedMessages :: ContactUserPreference TimedMessagesPreference, - fullDelete :: ContactUserPreference FullDeletePreference, - reactions :: ContactUserPreference ReactionsPreference, - voice :: ContactUserPreference VoicePreference, - calls :: ContactUserPreference CallsPreference - } - deriving (Eq, Show, Generic) - -data ContactUserPreference p = ContactUserPreference - { enabled :: PrefEnabled, - userPreference :: ContactUserPref p, - contactPreference :: p - } - deriving (Eq, Show, Generic) - -data ContactUserPref p = CUPContact {preference :: p} | CUPUser {preference :: p} - deriving (Eq, Show, Generic) - -instance ToJSON ContactUserPreferences where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON p => ToJSON (ContactUserPreference p) where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON p => ToJSON (ContactUserPref p) where - toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CUP" - toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CUP" - -toChatPrefs :: FullPreferences -> Preferences -toChatPrefs FullPreferences {timedMessages, fullDelete, reactions, voice, calls} = - Preferences - { timedMessages = Just timedMessages, - fullDelete = Just fullDelete, - reactions = Just reactions, - voice = Just voice, - calls = Just calls - } - -defaultChatPrefs :: FullPreferences -defaultChatPrefs = - FullPreferences - { timedMessages = TimedMessagesPreference {allow = FAYes, ttl = Nothing}, - fullDelete = FullDeletePreference {allow = FANo}, - reactions = ReactionsPreference {allow = FAYes}, - voice = VoicePreference {allow = FAYes}, - calls = CallsPreference {allow = FAYes} - } - -emptyChatPrefs :: Preferences -emptyChatPrefs = Preferences Nothing Nothing Nothing Nothing Nothing - -defaultGroupPrefs :: FullGroupPreferences -defaultGroupPrefs = - FullGroupPreferences - { timedMessages = TimedMessagesGroupPreference {enable = FEOff, ttl = Just 86400}, - directMessages = DirectMessagesGroupPreference {enable = FEOff}, - fullDelete = FullDeleteGroupPreference {enable = FEOff}, - reactions = ReactionsGroupPreference {enable = FEOn}, - voice = VoiceGroupPreference {enable = FEOn}, - files = FilesGroupPreference {enable = FEOn} - } - -emptyGroupPrefs :: GroupPreferences -emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing - -data TimedMessagesPreference = TimedMessagesPreference - { allow :: FeatureAllowed, - ttl :: Maybe Int - } - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON TimedMessagesPreference where - toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} - toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} - -data FullDeletePreference = FullDeletePreference {allow :: FeatureAllowed} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON FullDeletePreference where toEncoding = J.genericToEncoding J.defaultOptions - -data ReactionsPreference = ReactionsPreference {allow :: FeatureAllowed} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON ReactionsPreference 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 - -data CallsPreference = CallsPreference {allow :: FeatureAllowed} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON CallsPreference 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 - sFeature :: SChatFeature f - prefParam :: FeaturePreference f -> Maybe Int - -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" ReactionsPreference FeatureAllowed where - hasField p = (\allow -> p {allow}, allow (p :: ReactionsPreference)) - -instance HasField "allow" VoicePreference FeatureAllowed where - hasField p = (\allow -> p {allow}, allow (p :: VoicePreference)) - -instance HasField "allow" CallsPreference FeatureAllowed where - hasField p = (\allow -> p {allow}, allow (p :: CallsPreference)) - -instance FeatureI 'CFTimedMessages where - type FeaturePreference 'CFTimedMessages = TimedMessagesPreference - sFeature = SCFTimedMessages - prefParam TimedMessagesPreference {ttl} = ttl - -instance FeatureI 'CFFullDelete where - type FeaturePreference 'CFFullDelete = FullDeletePreference - sFeature = SCFFullDelete - prefParam _ = Nothing - -instance FeatureI 'CFReactions where - type FeaturePreference 'CFReactions = ReactionsPreference - sFeature = SCFReactions - prefParam _ = Nothing - -instance FeatureI 'CFVoice where - type FeaturePreference 'CFVoice = VoicePreference - sFeature = SCFVoice - prefParam _ = Nothing - -instance FeatureI 'CFCalls where - type FeaturePreference 'CFCalls = CallsPreference - sFeature = SCFCalls - prefParam _ = Nothing - -data GroupPreference = GroupPreference - {enable :: GroupFeatureEnabled} - deriving (Eq, Show, Generic, FromJSON) - -data TimedMessagesGroupPreference = TimedMessagesGroupPreference - { enable :: GroupFeatureEnabled, - ttl :: Maybe 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 ReactionsGroupPreference = ReactionsGroupPreference - {enable :: GroupFeatureEnabled} - deriving (Eq, Show, Generic, FromJSON) - -data VoiceGroupPreference = VoiceGroupPreference - {enable :: GroupFeatureEnabled} - deriving (Eq, Show, Generic, FromJSON) - -data FilesGroupPreference = FilesGroupPreference - {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 ReactionsGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON FullDeleteGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON VoiceGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions - -instance ToJSON FilesGroupPreference 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 - sGroupFeature :: SGroupFeature f - groupPrefParam :: GroupFeaturePreference f -> Maybe Int - -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" ReactionsGroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, enable (p :: ReactionsGroupPreference)) - -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 HasField "enable" FilesGroupPreference GroupFeatureEnabled where - hasField p = (\enable -> p {enable}, enable (p :: FilesGroupPreference)) - -instance GroupFeatureI 'GFTimedMessages where - type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference - sGroupFeature = SGFTimedMessages - groupPrefParam TimedMessagesGroupPreference {ttl} = ttl - -instance GroupFeatureI 'GFDirectMessages where - type GroupFeaturePreference 'GFDirectMessages = DirectMessagesGroupPreference - sGroupFeature = SGFDirectMessages - groupPrefParam _ = Nothing - -instance GroupFeatureI 'GFFullDelete where - type GroupFeaturePreference 'GFFullDelete = FullDeleteGroupPreference - sGroupFeature = SGFFullDelete - groupPrefParam _ = Nothing - -instance GroupFeatureI 'GFReactions where - type GroupFeaturePreference 'GFReactions = ReactionsGroupPreference - sGroupFeature = SGFReactions - groupPrefParam _ = Nothing - -instance GroupFeatureI 'GFVoice where - type GroupFeaturePreference 'GFVoice = VoiceGroupPreference - sGroupFeature = SGFVoice - groupPrefParam _ = Nothing - -instance GroupFeatureI 'GFFiles where - type GroupFeaturePreference 'GFFiles = FilesGroupPreference - sGroupFeature = SGFFiles - groupPrefParam _ = Nothing - -groupPrefStateText :: HasField "enable" p GroupFeatureEnabled => GroupFeature -> p -> Maybe Int -> Text -groupPrefStateText feature pref param = - let enabled = getField @"enable" pref - paramText = if enabled == FEOn then groupParamText_ feature param else "" - in groupFeatureNameText feature <> ": " <> safeDecodeUtf8 (strEncode enabled) <> paramText - -groupParamText_ :: GroupFeature -> Maybe Int -> Text -groupParamText_ feature param = case feature of - GFTimedMessages -> maybe "" (\p -> " (" <> timedTTLText p <> ")") param - _ -> "" - -groupPreferenceText :: forall f. GroupFeatureI f => GroupFeaturePreference f -> Text -groupPreferenceText pref = - let feature = toGroupFeature $ sGroupFeature @f - in groupPrefStateText feature pref $ groupPrefParam pref - -timedTTLText :: Int -> Text -timedTTLText 0 = "0 sec" -timedTTLText ttl = do - let (m', s) = ttl `quotRem` 60 - (h', m) = m' `quotRem` 60 - (d', h) = h' `quotRem` 24 - (mm, d) = d' `quotRem` 30 - T.pack . unwords $ - [mms mm | mm /= 0] <> [ds d | d /= 0] <> [hs h | h /= 0] <> [ms m | m /= 0] <> [ss s | s /= 0] - where - ss s = show s <> " sec" - ms m = show m <> " min" - hs 1 = "1 hour" - hs h = show h <> " hours" - ds 1 = "1 day" - ds 7 = "1 week" - ds 14 = "2 weeks" - ds d = show d <> " days" - mms 1 = "1 month" - mms mm = show mm <> " months" - -toGroupPreference :: GroupFeatureI f => GroupFeaturePreference f -> GroupPreference -toGroupPreference p = GroupPreference {enable = getField @"enable" p} - -data FeatureAllowed - = FAAlways -- allow unconditionally - | FAYes -- allow, if peer allows it - | FANo -- do not allow - deriving (Eq, Show, Generic) - -instance FromField FeatureAllowed where fromField = fromBlobField_ strDecode - -instance ToField FeatureAllowed where toField = toField . strEncode - -instance StrEncoding FeatureAllowed where - strEncode = \case - FAAlways -> "always" - FAYes -> "yes" - FANo -> "no" - strDecode = \case - "always" -> Right FAAlways - "yes" -> Right FAYes - "no" -> Right FANo - r -> Left $ "bad FeatureAllowed " <> B.unpack r - strP = strDecode <$?> A.takeByteString - -instance FromJSON FeatureAllowed where - parseJSON = strParseJSON "FeatureAllowed" - -instance ToJSON FeatureAllowed where - toJSON = strToJSON - toEncoding = strToJEncoding - -data GroupFeatureEnabled = FEOn | FEOff - deriving (Eq, Show, Generic) - -instance FromField GroupFeatureEnabled where fromField = fromBlobField_ strDecode - -instance ToField GroupFeatureEnabled where toField = toField . strEncode - -instance StrEncoding GroupFeatureEnabled where - strEncode = \case - FEOn -> "on" - FEOff -> "off" - strDecode = \case - "on" -> Right FEOn - "off" -> Right FEOff - r -> Left $ "bad GroupFeatureEnabled " <> B.unpack r - strP = strDecode <$?> A.takeByteString - -instance FromJSON GroupFeatureEnabled where - parseJSON = strParseJSON "GroupFeatureEnabled" - -instance ToJSON GroupFeatureEnabled where - toJSON = strToJSON - toEncoding = strToJEncoding - -groupFeatureState :: GroupFeatureI f => GroupFeaturePreference f -> (GroupFeatureEnabled, Maybe Int) -groupFeatureState p = - let enable = getField @"enable" p - param = if enable == FEOn then groupPrefParam p else Nothing - in (enable, param) - -mergePreferences :: Maybe Preferences -> Maybe Preferences -> FullPreferences -mergePreferences contactPrefs userPreferences = - FullPreferences - { timedMessages = pref SCFTimedMessages, - fullDelete = pref SCFFullDelete, - reactions = pref SCFReactions, - voice = pref SCFVoice, - calls = pref SCFCalls - } - where - 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) @@ -1014,94 +361,6 @@ mergeUserChatPrefs' user connectedIncognito userPreferences = let userPrefs = if connectedIncognito then Nothing else preferences' user in mergePreferences (Just userPreferences) userPrefs -mergeGroupPreferences :: Maybe GroupPreferences -> FullGroupPreferences -mergeGroupPreferences groupPreferences = - FullGroupPreferences - { timedMessages = pref SGFTimedMessages, - directMessages = pref SGFDirectMessages, - fullDelete = pref SGFFullDelete, - reactions = pref SGFReactions, - voice = pref SGFVoice, - files = pref SGFFiles - } - where - pref :: SGroupFeature f -> GroupFeaturePreference f - pref pt = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPreferences >>= groupPrefSel pt) - -toGroupPreferences :: FullGroupPreferences -> GroupPreferences -toGroupPreferences groupPreferences = - GroupPreferences - { timedMessages = pref SGFTimedMessages, - directMessages = pref SGFDirectMessages, - fullDelete = pref SGFFullDelete, - reactions = pref SGFReactions, - voice = pref SGFVoice, - files = pref SGFFiles - } - where - pref :: SGroupFeature f -> Maybe (GroupFeaturePreference f) - pref f = Just $ getGroupPreference f groupPreferences - -data PrefEnabled = PrefEnabled {forUser :: Bool, forContact :: Bool} - deriving (Eq, Show, Generic, FromJSON) - -instance ToJSON PrefEnabled where - toJSON = J.genericToJSON J.defaultOptions - toEncoding = J.genericToEncoding J.defaultOptions - -prefEnabled :: FeatureI f => Bool -> FeaturePreference f -> FeaturePreference f -> PrefEnabled -prefEnabled asymmetric user contact = case (getField @"allow" user, getField @"allow" contact) of - (FAAlways, FANo) -> PrefEnabled {forUser = False, forContact = asymmetric} - (FANo, FAAlways) -> PrefEnabled {forUser = asymmetric, forContact = False} - (_, FANo) -> PrefEnabled False False - (FANo, _) -> PrefEnabled False False - _ -> PrefEnabled True True - -prefStateText :: ChatFeature -> FeatureAllowed -> Maybe Int -> Text -prefStateText feature allowed param = case allowed of - FANo -> "cancelled " <> chatFeatureNameText feature - _ -> "offered " <> chatFeatureNameText feature <> paramText_ feature param - -featureStateText :: ChatFeature -> PrefEnabled -> Maybe Int -> Text -featureStateText feature enabled param = - chatFeatureNameText feature <> ": " <> prefEnabledToText feature enabled param <> case enabled of - PrefEnabled {forUser = True} -> paramText_ feature param - _ -> "" - -paramText_ :: ChatFeature -> Maybe Int -> Text -paramText_ feature param = case feature of - CFTimedMessages -> maybe "" (\p -> " (" <> timedTTLText p <> ")") param - _ -> "" - -prefEnabledToText :: ChatFeature -> PrefEnabled -> Maybe Int -> Text -prefEnabledToText f enabled param = case enabled of - PrefEnabled True True -> enabledStr - PrefEnabled False False -> "off" - PrefEnabled {forUser = True, forContact = False} -> enabledStr <> " for you" - PrefEnabled {forUser = False, forContact = True} -> enabledStr <> " for contact" - where - enabledStr = case f of - CFTimedMessages -> if isJust param then "enabled" else "allowed" - _ -> "enabled" - -preferenceText :: forall f. FeatureI f => FeaturePreference f -> Text -preferenceText p = - let feature = chatFeature $ sFeature @f - allowed = getField @"allow" p - paramText = if allowed == FAAlways || allowed == FAYes then paramText_ feature (prefParam p) else "" - in safeDecodeUtf8 (strEncode allowed) <> paramText - -featureState :: FeatureI f => ContactUserPreference (FeaturePreference f) -> (PrefEnabled, Maybe Int) -featureState ContactUserPreference {enabled, userPreference} = - let param = if forUser enabled then prefParam $ preference userPreference else Nothing - in (enabled, param) - -preferenceState :: FeatureI f => FeaturePreference f -> (FeatureAllowed, Maybe Int) -preferenceState pref = - let allow = getField @"allow" pref - param = if allow == FAAlways || allow == FAYes then prefParam pref else Nothing - in (allow, param) - updateMergedPreferences :: User -> Contact -> Contact updateMergedPreferences user ct = let mergedPreferences = contactUserPreferences user (userPreferences ct) (preferences' ct) (contactConnIncognito ct) @@ -1135,14 +394,6 @@ contactUserPreferences user userPreferences contactPreferences connectedIncognit ctUserPrefs = mergeUserChatPrefs' user connectedIncognito userPreferences ctPrefs = mergePreferences contactPreferences Nothing -getContactUserPreference :: SChatFeature f -> ContactUserPreferences -> ContactUserPreference (FeaturePreference f) -getContactUserPreference = \case - SCFTimedMessages -> timedMessages - SCFFullDelete -> fullDelete - SCFReactions -> reactions - SCFVoice -> voice - SCFCalls -> calls - data Profile = Profile { displayName :: ContactName, fullName :: Text, @@ -1433,14 +684,6 @@ instance ToJSON GroupMemberRole where toJSON = strToJSON toEncoding = strToJEncoding -fromBlobField_ :: Typeable k => (ByteString -> Either String k) -> FieldParser k -fromBlobField_ p = \case - f@(Field (SQLBlob b) _) -> - case p b of - Right k -> Ok k - Left e -> returnError ConversionFailed f ("could not parse field: " ++ e) - f -> returnError ConversionFailed f "expecting SQLBlob column type" - newtype Probe = Probe {unProbe :: ByteString} deriving (Eq, Show) @@ -2194,12 +1437,6 @@ data XGrpMemIntroCont = XGrpMemIntroCont } deriving (Show) -encodeJSON :: ToJSON a => a -> Text -encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode - -decodeJSON :: FromJSON a => Text -> Maybe a -decodeJSON = J.decode . LB.fromStrict . encodeUtf8 - data ServerCfg p = ServerCfg { server :: ProtoServerWithAuth p, preset :: Bool, diff --git a/src/Simplex/Chat/Types/Preferences.hs b/src/Simplex/Chat/Types/Preferences.hs new file mode 100644 index 0000000000..a89e383242 --- /dev/null +++ b/src/Simplex/Chat/Types/Preferences.hs @@ -0,0 +1,778 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use newtype instead of data" #-} + +module Simplex.Chat.Types.Preferences where + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as J +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Char8 as B +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +import GHC.Generics (Generic) +import GHC.Records.Compat +import Simplex.Chat.Types.Util +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, sumTypeJSON) +import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>)) + +data ChatFeature + = CFTimedMessages + | CFFullDelete + | CFReactions + | CFVoice + | CFCalls + deriving (Show, Generic) + +data SChatFeature (f :: ChatFeature) where + SCFTimedMessages :: SChatFeature 'CFTimedMessages + SCFFullDelete :: SChatFeature 'CFFullDelete + SCFReactions :: SChatFeature 'CFReactions + SCFVoice :: SChatFeature 'CFVoice + SCFCalls :: SChatFeature 'CFCalls + +deriving instance Show (SChatFeature f) + +data AChatFeature = forall f. FeatureI f => ACF (SChatFeature f) + +deriving instance Show AChatFeature + +chatFeatureNameText :: ChatFeature -> Text +chatFeatureNameText = \case + CFTimedMessages -> "Disappearing messages" + CFFullDelete -> "Full deletion" + CFReactions -> "Message reactions" + CFVoice -> "Voice messages" + CFCalls -> "Audio/video calls" + +chatFeatureNameText' :: SChatFeature f -> Text +chatFeatureNameText' = chatFeatureNameText . chatFeature + +instance ToJSON ChatFeature where + toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CF" + toJSON = J.genericToJSON . enumJSON $ dropPrefix "CF" + +instance FromJSON ChatFeature where + parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CF" + +allChatFeatures :: [AChatFeature] +allChatFeatures = + [ ACF SCFTimedMessages, + ACF SCFFullDelete, + ACF SCFReactions, + ACF SCFVoice, + ACF SCFCalls + ] + +chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f) +chatPrefSel = \case + SCFTimedMessages -> timedMessages + SCFFullDelete -> fullDelete + SCFReactions -> reactions + SCFVoice -> voice + SCFCalls -> calls + +chatFeature :: SChatFeature f -> ChatFeature +chatFeature = \case + SCFTimedMessages -> CFTimedMessages + SCFFullDelete -> CFFullDelete + SCFReactions -> CFReactions + SCFVoice -> CFVoice + SCFCalls -> CFCalls + +class PreferenceI p where + getPreference :: SChatFeature f -> p -> FeaturePreference f + +instance PreferenceI Preferences where + getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f prefs) + +instance PreferenceI (Maybe Preferences) where + getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f =<< prefs) + +instance PreferenceI FullPreferences where + getPreference = \case + SCFTimedMessages -> timedMessages + SCFFullDelete -> fullDelete + SCFReactions -> reactions + SCFVoice -> voice + SCFCalls -> calls + {-# INLINE getPreference #-} + +setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences +setPreference f allow_ prefs_ = setPreference_ f pref $ fromMaybe emptyChatPrefs prefs_ + where + pref = setAllow <$> allow_ + setAllow :: FeatureAllowed -> FeaturePreference f + setAllow = setField @"allow" (getPreference f prefs) + prefs = mergePreferences Nothing prefs_ + +setPreference' :: SChatFeature f -> Maybe (FeaturePreference f) -> Maybe Preferences -> Preferences +setPreference' f pref_ prefs_ = setPreference_ f pref_ $ fromMaybe emptyChatPrefs prefs_ + +setPreference_ :: SChatFeature f -> Maybe (FeaturePreference f) -> Preferences -> Preferences +setPreference_ f pref_ prefs = + case f of + SCFTimedMessages -> prefs {timedMessages = pref_} + SCFFullDelete -> prefs {fullDelete = pref_} + SCFReactions -> prefs {reactions = pref_} + SCFVoice -> prefs {voice = pref_} + SCFCalls -> prefs {calls = pref_} + +-- collection of optional chat preferences for the user and the contact +data Preferences = Preferences + { timedMessages :: Maybe TimedMessagesPreference, + fullDelete :: Maybe FullDeletePreference, + reactions :: Maybe ReactionsPreference, + voice :: Maybe VoicePreference, + calls :: Maybe CallsPreference + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON Preferences where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + +instance ToField Preferences where + toField = toField . encodeJSON + +instance FromField Preferences where + fromField = fromTextField_ decodeJSON + +data GroupFeature + = GFTimedMessages + | GFDirectMessages + | GFFullDelete + | GFReactions + | GFVoice + | GFFiles + deriving (Show, Generic) + +data SGroupFeature (f :: GroupFeature) where + SGFTimedMessages :: SGroupFeature 'GFTimedMessages + SGFDirectMessages :: SGroupFeature 'GFDirectMessages + SGFFullDelete :: SGroupFeature 'GFFullDelete + SGFReactions :: SGroupFeature 'GFReactions + SGFVoice :: SGroupFeature 'GFVoice + SGFFiles :: SGroupFeature 'GFFiles + +deriving instance Show (SGroupFeature f) + +data AGroupFeature = forall f. GroupFeatureI f => AGF (SGroupFeature f) + +deriving instance Show AGroupFeature + +groupFeatureNameText :: GroupFeature -> Text +groupFeatureNameText = \case + GFTimedMessages -> "Disappearing messages" + GFDirectMessages -> "Direct messages" + GFFullDelete -> "Full deletion" + GFReactions -> "Message reactions" + GFVoice -> "Voice messages" + GFFiles -> "Files and media" + +groupFeatureNameText' :: SGroupFeature f -> Text +groupFeatureNameText' = groupFeatureNameText . toGroupFeature + +groupFeatureAllowed' :: GroupFeatureI f => SGroupFeature f -> FullGroupPreferences -> Bool +groupFeatureAllowed' feature prefs = + getField @"enable" (getGroupPreference feature prefs) == FEOn + +instance ToJSON GroupFeature where + toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "GF" + toJSON = J.genericToJSON . enumJSON $ dropPrefix "GF" + +instance FromJSON GroupFeature where + parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "GF" + +allGroupFeatures :: [AGroupFeature] +allGroupFeatures = + [ AGF SGFTimedMessages, + AGF SGFDirectMessages, + AGF SGFFullDelete, + AGF SGFReactions, + AGF SGFVoice, + AGF SGFFiles + ] + +groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f) +groupPrefSel = \case + SGFTimedMessages -> timedMessages + SGFDirectMessages -> directMessages + SGFFullDelete -> fullDelete + SGFReactions -> reactions + SGFVoice -> voice + SGFFiles -> files + +toGroupFeature :: SGroupFeature f -> GroupFeature +toGroupFeature = \case + SGFTimedMessages -> GFTimedMessages + SGFDirectMessages -> GFDirectMessages + SGFFullDelete -> GFFullDelete + SGFReactions -> GFReactions + SGFVoice -> GFVoice + SGFFiles -> GFFiles + +class GroupPreferenceI p where + getGroupPreference :: SGroupFeature f -> p -> GroupFeaturePreference f + +instance GroupPreferenceI GroupPreferences where + getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt prefs) + +instance GroupPreferenceI (Maybe GroupPreferences) where + getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs) + +instance GroupPreferenceI FullGroupPreferences where + getGroupPreference = \case + SGFTimedMessages -> timedMessages + SGFDirectMessages -> directMessages + SGFFullDelete -> fullDelete + SGFReactions -> reactions + SGFVoice -> voice + SGFFiles -> files + {-# INLINE getGroupPreference #-} + +-- collection of optional group preferences +data GroupPreferences = GroupPreferences + { timedMessages :: Maybe TimedMessagesGroupPreference, + directMessages :: Maybe DirectMessagesGroupPreference, + fullDelete :: Maybe FullDeleteGroupPreference, + reactions :: Maybe ReactionsGroupPreference, + voice :: Maybe VoiceGroupPreference, + files :: Maybe FilesGroupPreference + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON GroupPreferences where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + +instance ToField GroupPreferences where + toField = toField . encodeJSON + +instance FromField GroupPreferences where + fromField = fromTextField_ decodeJSON + +setGroupPreference :: forall f. GroupFeatureI 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 + +setGroupPreference' :: SGroupFeature f -> GroupFeaturePreference f -> Maybe GroupPreferences -> GroupPreferences +setGroupPreference' f pref prefs_ = setGroupPreference_ f pref prefs + where + prefs = mergeGroupPreferences prefs_ + +setGroupPreference_ :: SGroupFeature f -> GroupFeaturePreference f -> FullGroupPreferences -> GroupPreferences +setGroupPreference_ f pref prefs = + toGroupPreferences $ case f of + SGFTimedMessages -> prefs {timedMessages = pref} + SGFDirectMessages -> prefs {directMessages = pref} + SGFFullDelete -> prefs {fullDelete = pref} + SGFReactions -> prefs {reactions = pref} + SGFVoice -> prefs {voice = pref} + SGFFiles -> prefs {files = pref} + +setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences +setGroupTimedMessagesPreference pref prefs_ = + toGroupPreferences $ prefs {timedMessages = pref} + where + prefs = mergeGroupPreferences 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 + { timedMessages :: TimedMessagesPreference, + fullDelete :: FullDeletePreference, + reactions :: ReactionsPreference, + voice :: VoicePreference, + calls :: CallsPreference + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON FullPreferences where toEncoding = J.genericToEncoding J.defaultOptions + +-- 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 + { timedMessages :: TimedMessagesGroupPreference, + directMessages :: DirectMessagesGroupPreference, + fullDelete :: FullDeleteGroupPreference, + reactions :: ReactionsGroupPreference, + voice :: VoiceGroupPreference, + files :: FilesGroupPreference + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON FullGroupPreferences where toEncoding = J.genericToEncoding J.defaultOptions + +-- merged preferences of user for a given contact - they differentiate between specific preferences for the contact and global user preferences +data ContactUserPreferences = ContactUserPreferences + { timedMessages :: ContactUserPreference TimedMessagesPreference, + fullDelete :: ContactUserPreference FullDeletePreference, + reactions :: ContactUserPreference ReactionsPreference, + voice :: ContactUserPreference VoicePreference, + calls :: ContactUserPreference CallsPreference + } + deriving (Eq, Show, Generic) + +data ContactUserPreference p = ContactUserPreference + { enabled :: PrefEnabled, + userPreference :: ContactUserPref p, + contactPreference :: p + } + deriving (Eq, Show, Generic) + +data ContactUserPref p = CUPContact {preference :: p} | CUPUser {preference :: p} + deriving (Eq, Show, Generic) + +instance ToJSON ContactUserPreferences where toEncoding = J.genericToEncoding J.defaultOptions + +instance ToJSON p => ToJSON (ContactUserPreference p) where toEncoding = J.genericToEncoding J.defaultOptions + +instance ToJSON p => ToJSON (ContactUserPref p) where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CUP" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CUP" + +toChatPrefs :: FullPreferences -> Preferences +toChatPrefs FullPreferences {timedMessages, fullDelete, reactions, voice, calls} = + Preferences + { timedMessages = Just timedMessages, + fullDelete = Just fullDelete, + reactions = Just reactions, + voice = Just voice, + calls = Just calls + } + +defaultChatPrefs :: FullPreferences +defaultChatPrefs = + FullPreferences + { timedMessages = TimedMessagesPreference {allow = FAYes, ttl = Nothing}, + fullDelete = FullDeletePreference {allow = FANo}, + reactions = ReactionsPreference {allow = FAYes}, + voice = VoicePreference {allow = FAYes}, + calls = CallsPreference {allow = FAYes} + } + +emptyChatPrefs :: Preferences +emptyChatPrefs = Preferences Nothing Nothing Nothing Nothing Nothing + +defaultGroupPrefs :: FullGroupPreferences +defaultGroupPrefs = + FullGroupPreferences + { timedMessages = TimedMessagesGroupPreference {enable = FEOff, ttl = Just 86400}, + directMessages = DirectMessagesGroupPreference {enable = FEOff}, + fullDelete = FullDeleteGroupPreference {enable = FEOff}, + reactions = ReactionsGroupPreference {enable = FEOn}, + voice = VoiceGroupPreference {enable = FEOn}, + files = FilesGroupPreference {enable = FEOn} + } + +emptyGroupPrefs :: GroupPreferences +emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing + +data TimedMessagesPreference = TimedMessagesPreference + { allow :: FeatureAllowed, + ttl :: Maybe Int + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON TimedMessagesPreference where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + +data FullDeletePreference = FullDeletePreference {allow :: FeatureAllowed} + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON FullDeletePreference where toEncoding = J.genericToEncoding J.defaultOptions + +data ReactionsPreference = ReactionsPreference {allow :: FeatureAllowed} + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON ReactionsPreference 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 + +data CallsPreference = CallsPreference {allow :: FeatureAllowed} + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON CallsPreference 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 + sFeature :: SChatFeature f + prefParam :: FeaturePreference f -> Maybe Int + +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" ReactionsPreference FeatureAllowed where + hasField p = (\allow -> p {allow}, allow (p :: ReactionsPreference)) + +instance HasField "allow" VoicePreference FeatureAllowed where + hasField p = (\allow -> p {allow}, allow (p :: VoicePreference)) + +instance HasField "allow" CallsPreference FeatureAllowed where + hasField p = (\allow -> p {allow}, allow (p :: CallsPreference)) + +instance FeatureI 'CFTimedMessages where + type FeaturePreference 'CFTimedMessages = TimedMessagesPreference + sFeature = SCFTimedMessages + prefParam TimedMessagesPreference {ttl} = ttl + +instance FeatureI 'CFFullDelete where + type FeaturePreference 'CFFullDelete = FullDeletePreference + sFeature = SCFFullDelete + prefParam _ = Nothing + +instance FeatureI 'CFReactions where + type FeaturePreference 'CFReactions = ReactionsPreference + sFeature = SCFReactions + prefParam _ = Nothing + +instance FeatureI 'CFVoice where + type FeaturePreference 'CFVoice = VoicePreference + sFeature = SCFVoice + prefParam _ = Nothing + +instance FeatureI 'CFCalls where + type FeaturePreference 'CFCalls = CallsPreference + sFeature = SCFCalls + prefParam _ = Nothing + +data GroupPreference = GroupPreference + {enable :: GroupFeatureEnabled} + deriving (Eq, Show, Generic, FromJSON) + +data TimedMessagesGroupPreference = TimedMessagesGroupPreference + { enable :: GroupFeatureEnabled, + ttl :: Maybe 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 ReactionsGroupPreference = ReactionsGroupPreference + {enable :: GroupFeatureEnabled} + deriving (Eq, Show, Generic, FromJSON) + +data VoiceGroupPreference = VoiceGroupPreference + {enable :: GroupFeatureEnabled} + deriving (Eq, Show, Generic, FromJSON) + +data FilesGroupPreference = FilesGroupPreference + {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 ReactionsGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions + +instance ToJSON FullDeleteGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions + +instance ToJSON VoiceGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions + +instance ToJSON FilesGroupPreference 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 + sGroupFeature :: SGroupFeature f + groupPrefParam :: GroupFeaturePreference f -> Maybe Int + +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" ReactionsGroupPreference GroupFeatureEnabled where + hasField p = (\enable -> p {enable}, enable (p :: ReactionsGroupPreference)) + +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 HasField "enable" FilesGroupPreference GroupFeatureEnabled where + hasField p = (\enable -> p {enable}, enable (p :: FilesGroupPreference)) + +instance GroupFeatureI 'GFTimedMessages where + type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference + sGroupFeature = SGFTimedMessages + groupPrefParam TimedMessagesGroupPreference {ttl} = ttl + +instance GroupFeatureI 'GFDirectMessages where + type GroupFeaturePreference 'GFDirectMessages = DirectMessagesGroupPreference + sGroupFeature = SGFDirectMessages + groupPrefParam _ = Nothing + +instance GroupFeatureI 'GFFullDelete where + type GroupFeaturePreference 'GFFullDelete = FullDeleteGroupPreference + sGroupFeature = SGFFullDelete + groupPrefParam _ = Nothing + +instance GroupFeatureI 'GFReactions where + type GroupFeaturePreference 'GFReactions = ReactionsGroupPreference + sGroupFeature = SGFReactions + groupPrefParam _ = Nothing + +instance GroupFeatureI 'GFVoice where + type GroupFeaturePreference 'GFVoice = VoiceGroupPreference + sGroupFeature = SGFVoice + groupPrefParam _ = Nothing + +instance GroupFeatureI 'GFFiles where + type GroupFeaturePreference 'GFFiles = FilesGroupPreference + sGroupFeature = SGFFiles + groupPrefParam _ = Nothing + +groupPrefStateText :: HasField "enable" p GroupFeatureEnabled => GroupFeature -> p -> Maybe Int -> Text +groupPrefStateText feature pref param = + let enabled = getField @"enable" pref + paramText = if enabled == FEOn then groupParamText_ feature param else "" + in groupFeatureNameText feature <> ": " <> safeDecodeUtf8 (strEncode enabled) <> paramText + +groupParamText_ :: GroupFeature -> Maybe Int -> Text +groupParamText_ feature param = case feature of + GFTimedMessages -> maybe "" (\p -> " (" <> timedTTLText p <> ")") param + _ -> "" + +groupPreferenceText :: forall f. GroupFeatureI f => GroupFeaturePreference f -> Text +groupPreferenceText pref = + let feature = toGroupFeature $ sGroupFeature @f + in groupPrefStateText feature pref $ groupPrefParam pref + +timedTTLText :: Int -> Text +timedTTLText 0 = "0 sec" +timedTTLText ttl = do + let (m', s) = ttl `quotRem` 60 + (h', m) = m' `quotRem` 60 + (d', h) = h' `quotRem` 24 + (mm, d) = d' `quotRem` 30 + T.pack . unwords $ + [mms mm | mm /= 0] <> [ds d | d /= 0] <> [hs h | h /= 0] <> [ms m | m /= 0] <> [ss s | s /= 0] + where + ss s = show s <> " sec" + ms m = show m <> " min" + hs 1 = "1 hour" + hs h = show h <> " hours" + ds 1 = "1 day" + ds 7 = "1 week" + ds 14 = "2 weeks" + ds d = show d <> " days" + mms 1 = "1 month" + mms mm = show mm <> " months" + +toGroupPreference :: GroupFeatureI f => GroupFeaturePreference f -> GroupPreference +toGroupPreference p = GroupPreference {enable = getField @"enable" p} + +data FeatureAllowed + = FAAlways -- allow unconditionally + | FAYes -- allow, if peer allows it + | FANo -- do not allow + deriving (Eq, Show, Generic) + +instance FromField FeatureAllowed where fromField = fromBlobField_ strDecode + +instance ToField FeatureAllowed where toField = toField . strEncode + +instance StrEncoding FeatureAllowed where + strEncode = \case + FAAlways -> "always" + FAYes -> "yes" + FANo -> "no" + strDecode = \case + "always" -> Right FAAlways + "yes" -> Right FAYes + "no" -> Right FANo + r -> Left $ "bad FeatureAllowed " <> B.unpack r + strP = strDecode <$?> A.takeByteString + +instance FromJSON FeatureAllowed where + parseJSON = strParseJSON "FeatureAllowed" + +instance ToJSON FeatureAllowed where + toJSON = strToJSON + toEncoding = strToJEncoding + +data GroupFeatureEnabled = FEOn | FEOff + deriving (Eq, Show, Generic) + +instance FromField GroupFeatureEnabled where fromField = fromBlobField_ strDecode + +instance ToField GroupFeatureEnabled where toField = toField . strEncode + +instance StrEncoding GroupFeatureEnabled where + strEncode = \case + FEOn -> "on" + FEOff -> "off" + strDecode = \case + "on" -> Right FEOn + "off" -> Right FEOff + r -> Left $ "bad GroupFeatureEnabled " <> B.unpack r + strP = strDecode <$?> A.takeByteString + +instance FromJSON GroupFeatureEnabled where + parseJSON = strParseJSON "GroupFeatureEnabled" + +instance ToJSON GroupFeatureEnabled where + toJSON = strToJSON + toEncoding = strToJEncoding + +groupFeatureState :: GroupFeatureI f => GroupFeaturePreference f -> (GroupFeatureEnabled, Maybe Int) +groupFeatureState p = + let enable = getField @"enable" p + param = if enable == FEOn then groupPrefParam p else Nothing + in (enable, param) + +mergePreferences :: Maybe Preferences -> Maybe Preferences -> FullPreferences +mergePreferences contactPrefs userPreferences = + FullPreferences + { timedMessages = pref SCFTimedMessages, + fullDelete = pref SCFFullDelete, + reactions = pref SCFReactions, + voice = pref SCFVoice, + calls = pref SCFCalls + } + where + pref :: SChatFeature f -> FeaturePreference f + pref f = + let sel = chatPrefSel f + in fromMaybe (getPreference f defaultChatPrefs) $ (contactPrefs >>= sel) <|> (userPreferences >>= sel) + +mergeGroupPreferences :: Maybe GroupPreferences -> FullGroupPreferences +mergeGroupPreferences groupPreferences = + FullGroupPreferences + { timedMessages = pref SGFTimedMessages, + directMessages = pref SGFDirectMessages, + fullDelete = pref SGFFullDelete, + reactions = pref SGFReactions, + voice = pref SGFVoice, + files = pref SGFFiles + } + where + pref :: SGroupFeature f -> GroupFeaturePreference f + pref pt = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPreferences >>= groupPrefSel pt) + +toGroupPreferences :: FullGroupPreferences -> GroupPreferences +toGroupPreferences groupPreferences = + GroupPreferences + { timedMessages = pref SGFTimedMessages, + directMessages = pref SGFDirectMessages, + fullDelete = pref SGFFullDelete, + reactions = pref SGFReactions, + voice = pref SGFVoice, + files = pref SGFFiles + } + where + pref :: SGroupFeature f -> Maybe (GroupFeaturePreference f) + pref f = Just $ getGroupPreference f groupPreferences + +data PrefEnabled = PrefEnabled {forUser :: Bool, forContact :: Bool} + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON PrefEnabled where + toJSON = J.genericToJSON J.defaultOptions + toEncoding = J.genericToEncoding J.defaultOptions + +prefEnabled :: FeatureI f => Bool -> FeaturePreference f -> FeaturePreference f -> PrefEnabled +prefEnabled asymmetric user contact = case (getField @"allow" user, getField @"allow" contact) of + (FAAlways, FANo) -> PrefEnabled {forUser = False, forContact = asymmetric} + (FANo, FAAlways) -> PrefEnabled {forUser = asymmetric, forContact = False} + (_, FANo) -> PrefEnabled False False + (FANo, _) -> PrefEnabled False False + _ -> PrefEnabled True True + +prefStateText :: ChatFeature -> FeatureAllowed -> Maybe Int -> Text +prefStateText feature allowed param = case allowed of + FANo -> "cancelled " <> chatFeatureNameText feature + _ -> "offered " <> chatFeatureNameText feature <> paramText_ feature param + +featureStateText :: ChatFeature -> PrefEnabled -> Maybe Int -> Text +featureStateText feature enabled param = + chatFeatureNameText feature <> ": " <> prefEnabledToText feature enabled param <> case enabled of + PrefEnabled {forUser = True} -> paramText_ feature param + _ -> "" + +paramText_ :: ChatFeature -> Maybe Int -> Text +paramText_ feature param = case feature of + CFTimedMessages -> maybe "" (\p -> " (" <> timedTTLText p <> ")") param + _ -> "" + +prefEnabledToText :: ChatFeature -> PrefEnabled -> Maybe Int -> Text +prefEnabledToText f enabled param = case enabled of + PrefEnabled True True -> enabledStr + PrefEnabled False False -> "off" + PrefEnabled {forUser = True, forContact = False} -> enabledStr <> " for you" + PrefEnabled {forUser = False, forContact = True} -> enabledStr <> " for contact" + where + enabledStr = case f of + CFTimedMessages -> if isJust param then "enabled" else "allowed" + _ -> "enabled" + +preferenceText :: forall f. FeatureI f => FeaturePreference f -> Text +preferenceText p = + let feature = chatFeature $ sFeature @f + allowed = getField @"allow" p + paramText = if allowed == FAAlways || allowed == FAYes then paramText_ feature (prefParam p) else "" + in safeDecodeUtf8 (strEncode allowed) <> paramText + +featureState :: FeatureI f => ContactUserPreference (FeaturePreference f) -> (PrefEnabled, Maybe Int) +featureState ContactUserPreference {enabled, userPreference} = + let param = if forUser enabled then prefParam $ preference userPreference else Nothing + in (enabled, param) + +preferenceState :: FeatureI f => FeaturePreference f -> (FeatureAllowed, Maybe Int) +preferenceState pref = + let allow = getField @"allow" pref + param = if allow == FAAlways || allow == FAYes then prefParam pref else Nothing + in (allow, param) + +getContactUserPreference :: SChatFeature f -> ContactUserPreferences -> ContactUserPreference (FeaturePreference f) +getContactUserPreference = \case + SCFTimedMessages -> timedMessages + SCFFullDelete -> fullDelete + SCFReactions -> reactions + SCFVoice -> voice + SCFCalls -> calls diff --git a/src/Simplex/Chat/Types/Util.hs b/src/Simplex/Chat/Types/Util.hs new file mode 100644 index 0000000000..fffdd24b9e --- /dev/null +++ b/src/Simplex/Chat/Types/Util.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE LambdaCase #-} + +module Simplex.Chat.Types.Util where + +import Data.Aeson (ToJSON, FromJSON) +import qualified Data.Aeson as J +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable +import Database.SQLite.Simple (ResultError (..), SQLData (..)) +import Database.SQLite.Simple.FromField (FieldParser, returnError) +import Database.SQLite.Simple.Internal (Field (..)) +import Database.SQLite.Simple.Ok (Ok (Ok)) +import Simplex.Messaging.Util (safeDecodeUtf8) + +encodeJSON :: ToJSON a => a -> Text +encodeJSON = safeDecodeUtf8 . LB.toStrict . J.encode + +decodeJSON :: FromJSON a => Text -> Maybe a +decodeJSON = J.decode . LB.fromStrict . encodeUtf8 + +fromBlobField_ :: Typeable k => (ByteString -> Either String k) -> FieldParser k +fromBlobField_ p = \case + f@(Field (SQLBlob b) _) -> + case p b of + Right k -> Ok k + Left e -> returnError ConversionFailed f ("could not parse field: " ++ e) + f -> returnError ConversionFailed f "expecting SQLBlob column type" diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 6002665766..0b7db12f94 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -42,6 +42,7 @@ import Simplex.Chat.Protocol import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..)) import Simplex.Chat.Styled import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import qualified Simplex.FileTransfer.Protocol as XFTP import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..)) diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 9a3b3b09c5..c6acf986a1 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -20,6 +20,7 @@ import qualified Data.Text as T import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), InlineFilesConfig (..), defaultInlineFilesConfig) import Simplex.Chat.Store.Profiles (getUserContactProfiles) import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Store.SQLite (withTransaction) import Simplex.Messaging.Encoding.String import System.Directory (doesFileExist) diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index c0956f2876..6f7e0b8cf4 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -10,6 +10,7 @@ import Data.ByteString.Char8 (ByteString) import Data.Time.Clock.System (SystemTime (..), systemToUTCTime) import Simplex.Chat.Protocol import Simplex.Chat.Types +import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet