From 678dbec3e2f4671bbc62a74c6aeca2f3231c9ba2 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 13 Dec 2022 14:52:34 +0000 Subject: [PATCH] core: different types for chat preferences, to allow parameters (#1565) --- package.yaml | 1 + simplex-chat.cabal | 7 +- src/Simplex/Chat.hs | 22 +++-- src/Simplex/Chat/Types.hs | 194 ++++++++++++++++++++++++++------------ src/Simplex/Chat/View.hs | 34 +++---- tests/ChatTests.hs | 26 +++-- tests/MobileTests.hs | 4 +- tests/ProtocolTests.hs | 2 +- 8 files changed, 190 insertions(+), 100 deletions(-) diff --git a/package.yaml b/package.yaml index 02076e7b28..d84cca8789 100644 --- a/package.yaml +++ b/package.yaml @@ -33,6 +33,7 @@ dependencies: - optparse-applicative >= 0.15 && < 0.17 - process == 1.6.* - random >= 1.1 && < 1.3 + - record-hasfield == 1.0.* - simple-logger == 0.1.* - simplexmq >= 3.4 - socks == 0.6.* diff --git a/simplex-chat.cabal b/simplex-chat.cabal index fd026c9c97..46944b5f9c 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -107,6 +107,7 @@ library , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 + , record-hasfield ==1.0.* , simple-logger ==0.1.* , simplexmq >=3.4 , socks ==0.6.* @@ -149,6 +150,7 @@ executable simplex-bot , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 + , record-hasfield ==1.0.* , simple-logger ==0.1.* , simplex-chat , simplexmq >=3.4 @@ -192,6 +194,7 @@ executable simplex-bot-advanced , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 + , record-hasfield ==1.0.* , simple-logger ==0.1.* , simplex-chat , simplexmq >=3.4 @@ -236,6 +239,7 @@ executable simplex-chat , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 + , record-hasfield ==1.0.* , simple-logger ==0.1.* , simplex-chat , simplexmq >=3.4 @@ -289,6 +293,7 @@ test-suite simplex-chat-test , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 + , record-hasfield ==1.0.* , simple-logger ==0.1.* , simplex-chat , simplexmq >=3.4 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 7f063ca6a6..d2e8d991ae 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -291,7 +291,7 @@ processChatCommand = \case ct@Contact {localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId assertDirectAllowed user MDSnd ct XMsgNew_ unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct - if isVoice mc && not (featureAllowed CFVoice forUser ct) + if isVoice mc && not (featureAllowed SCFVoice forUser ct) then pure $ chatCmdError $ "feature not allowed " <> T.unpack (chatFeatureToText CFVoice) else do (fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct @@ -454,7 +454,7 @@ processChatCommand = \case (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do (SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId) setActive $ ActiveC c - if featureAllowed CFFullDelete forUser ct + if featureAllowed SCFFullDelete forUser ct then deleteDirectCI user ct ci True else markDirectCIDeleted user ct ci msgId True (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete @@ -1113,11 +1113,13 @@ processChatCommand = \case UpdateProfileImage image -> withUser $ \user@User {profile} -> do let p = (fromLocalProfile profile :: Profile) {image} updateProfile user p - SetUserFeature f allowed -> withUser $ \user@User {profile} -> do + SetUserFeature cf allowed -> withUser $ \user@User {profile} -> do + ACF f <- pure $ aChatFeature cf let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user} updateProfile user p - SetContactFeature f cName allowed_ -> withUser $ \user -> do + SetContactFeature cf cName allowed_ -> withUser $ \user -> do ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db user cName + ACF f <- pure $ aChatFeature cf let prefs' = setPreference f allowed_ $ Just userPreferences updateContactPrefs user ct prefs' SetGroupFeature f gName enabled -> @@ -2303,7 +2305,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct checkIntegrityCreateItem (CDDirectRcv ct) msgMeta let ExtMsgContent content fileInvitation_ = mcExtMsgContent mc - if isVoice content && not (featureAllowed CFVoice forContact ct) + if isVoice content && not (featureAllowed SCFVoice forContact ct) then do void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing setActive $ ActiveC c @@ -2364,7 +2366,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = ci@(CChatItem msgDir _) <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId case msgDir of SMDRcv -> - if featureAllowed CFFullDelete forContact ct + if featureAllowed SCFFullDelete forContact ct then deleteDirectCI user ct ci False >>= toView else markDirectCIDeleted user ct ci msgId False >>= toView SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete" @@ -2621,9 +2623,9 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = createFeatureEnabledItems :: Contact -> m () createFeatureEnabledItems ct@Contact {mergedPreferences} = - forM_ allChatFeatures $ \f -> do + forM_ allChatFeatures $ \(ACF f) -> do let ContactUserPreference {enabled} = getContactUserPreference f mergedPreferences - createInternalChatItem user (CDDirectRcv ct) (CIRcvChatFeature f enabled) Nothing + createInternalChatItem user (CDDirectRcv ct) (CIRcvChatFeature (chatFeature f) enabled) Nothing createGroupFeatureItems :: GroupInfo -> GroupMember -> m () createGroupFeatureItems g@GroupInfo {groupProfile} m = do @@ -3244,11 +3246,11 @@ userProfileToSend user@User {profile = p} incognitoProfile ct = createFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> Contact -> Contact -> (Contact -> ChatDirection 'CTDirect d) -> (ChatFeature -> PrefEnabled -> CIContent d) -> m () createFeatureChangedItems user Contact {mergedPreferences = cups} ct'@Contact {mergedPreferences = cups'} chatDir ciContent = - forM_ allChatFeatures $ \f -> do + forM_ allChatFeatures $ \(ACF f) -> do let ContactUserPreference {enabled} = getContactUserPreference f cups ContactUserPreference {enabled = enabled'} = getContactUserPreference f cups' unless (enabled == enabled') $ - createInternalChatItem user (chatDir ct') (ciContent f enabled') Nothing + createInternalChatItem user (chatDir ct') (ciContent (chatFeature f) enabled') Nothing createGroupFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> CIContent d) -> GroupProfile -> GroupProfile -> m () createGroupFeatureChangedItems user cd ciContent p p' = diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 2e34bd6e57..1fc34232f3 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -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, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index e0e8826d18..8525864402 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 8d34dc4d03..3599a52bce 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -734,7 +734,7 @@ testGroup2 = <##? [ "dan> hi", "@dan hey" ] - alice ##> "/t 18" + alice ##> "/t 21" alice <##? [ "@bob sent invitation to join group club as admin", "@cath sent invitation to join group club as admin", @@ -748,10 +748,13 @@ testGroup2 = "#club dan> how is it going?", "dan> hi", "@dan hey", + "dan> Disappearing messages: off", "dan> Full deletion: off", "dan> Voice messages: enabled", + "bob> Disappearing messages: off", "bob> Full deletion: off", "bob> Voice messages: enabled", + "cath> Disappearing messages: off", "cath> Full deletion: off", "cath> Voice messages: enabled" ] @@ -1280,7 +1283,7 @@ testGroupMessageDelete = (cath <# "#team alice> hello!") -- alice: deletes msg id 5 - alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted") + alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " internal", id, "message deleted") alice #$> ("/_get chat #1 count=1", chat, [(0, "connected")]) bob #$> ("/_get chat #1 count=1", chat, [(0, "hello!")]) @@ -1306,14 +1309,14 @@ testGroupMessageDelete = cath #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((0, "hi alic"), Just (0, "hello!"))]) -- alice: deletes msg id 5 - alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted") + alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " internal", id, "message deleted") alice #$> ("/_get chat #1 count=1", chat', [((0, "connected"), Nothing)]) bob #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((1, "hi alic"), Just (0, "hello!"))]) cath #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((0, "hi alic"), Just (0, "hello!"))]) -- alice: msg id 5 - bob #$> ("/_update item #1 " <> groupItemId 2 7 <> " text hi alice", id, "message updated") + bob #$> ("/_update item #1 " <> groupItemId' 2 3 <> " text hi alice", id, "message updated") concurrently_ (alice <# "#team bob> [edited] hi alice") ( do @@ -1332,13 +1335,13 @@ testGroupMessageDelete = (alice <# "#team cath> how are you?") (bob <# "#team cath> how are you?") - cath #$> ("/_delete item #1 " <> groupItemId 2 7 <> " broadcast", id, "message marked deleted") + cath #$> ("/_delete item #1 " <> groupItemId' 2 3 <> " broadcast", id, "message marked deleted") concurrently_ (alice <# "#team cath> [marked deleted] how are you?") (bob <# "#team cath> [marked deleted] how are you?") - alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " broadcast", id, "cannot delete this item") - alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted") + alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " broadcast", id, "cannot delete this item") + alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " internal", id, "message deleted") alice #$> ("/_get chat #1 count=1", chat', [((0, "how are you? [marked deleted]"), Nothing)]) bob #$> ("/_get chat #1 count=3", chat', [((0, "hello!"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "how are you? [marked deleted]"), Nothing)]) @@ -3333,7 +3336,7 @@ testSetContactPrefs = testChat2 aliceProfile bobProfile $ alice ##> "/_set prefs @2 {}" alice <## "your preferences for bob did not change" (bob ("/_get chat @2 count=100", chat, startFeatures) bob #$> ("/_get chat @2 count=100", chat, startFeatures) let sendVoice = "/_send @2 json {\"filePath\": \"test.txt\", \"msgContent\": {\"type\": \"voice\", \"text\": \"\", \"duration\": 10}}" @@ -3486,7 +3489,7 @@ testAllowFullDeletionGroup = bob <## "Full deletion enabled: on" alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "hi"), (0, "hey"), (1, "Full deletion: on")]) bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (1, "hey"), (0, "Full deletion: on")]) - bob #$> ("/_delete item #1 " <> groupItemId 2 5 <> " broadcast", id, "message deleted") + bob #$> ("/_delete item #1 " <> groupItemId' 2 1 <> " broadcast", id, "message deleted") alice <# "#team bob> [deleted] hey" alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "hi"), (1, "Full deletion: on")]) bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (0, "Full deletion: on")]) @@ -4866,7 +4869,7 @@ chatFeaturesF :: [((Int, String), Maybe String)] chatFeaturesF = map (\(a, _, c) -> (a, c)) chatFeatures'' chatFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)] -chatFeatures'' = [((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: enabled"), Nothing, Nothing)] +chatFeatures'' = [((0, "Disappearing messages: off"), Nothing, Nothing), ((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: enabled"), Nothing, Nothing)] groupFeatures :: [(Int, String)] groupFeatures = map (\(a, _, _) -> a) groupFeatures'' @@ -4880,6 +4883,9 @@ itemId i = show $ length chatFeatures + i groupItemId :: Int -> Int -> String groupItemId n i = show $ length chatFeatures * n + i +groupItemId' :: Int -> Int -> String +groupItemId' n i = show $ length chatFeatures * n + length groupFeatures + i + (@@@) :: TestCC -> [(String, String)] -> Expectation (@@@) = getChats . map $ \(ldn, msg, _) -> (ldn, msg) diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 7d0d67a2a6..ad69380021 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -32,9 +32,9 @@ activeUserExists = "{\"resp\":{\"type\":\"chatCmdError\",\"chatError\":{\"type\" activeUser :: String #if defined(darwin_HOST_OS) && defined(swiftJSON) -activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}" +activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\",\"ttl\":86400},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}" #else -activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}" +activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\",\"ttl\":86400},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}" #endif chatStarted :: String diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 61365b2130..34a226c74b 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -80,7 +80,7 @@ s #==# msg = do s ==# msg testChatPreferences :: Maybe Preferences -testChatPreferences = Just Preferences {voice = Just Preference {allow = FAYes}, fullDelete = Nothing} +testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, fullDelete = Nothing, timedMessages = Nothing} testGroupPreferences :: Maybe GroupPreferences testGroupPreferences = Just GroupPreferences {directMessages = Nothing, voice = Just GroupPreference {enable = FEOn}, fullDelete = Nothing}