diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index d2e8d991ae..af19e8f42d 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -341,7 +341,7 @@ processChatCommand = \case CTGroup -> do Group gInfo@GroupInfo {membership, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved - if isVoice mc && not (groupFeatureAllowed GFVoice gInfo) + if isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) then pure $ chatCmdError $ "feature not allowed " <> T.unpack (groupFeatureToText GFVoice) else do (fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo (length $ filter memberCurrent ms) @@ -467,7 +467,7 @@ processChatCommand = \case (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgDel itemSharedMId) setActive $ ActiveG gName - if groupFeatureAllowed GFFullDelete gInfo + if groupFeatureAllowed SGFFullDelete gInfo then deleteGroupCI user gInfo ci True else markGroupCIDeleted user gInfo ci msgId True (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete @@ -1113,16 +1113,14 @@ processChatCommand = \case UpdateProfileImage image -> withUser $ \user@User {profile} -> do let p = (fromLocalProfile profile :: Profile) {image} updateProfile user p - SetUserFeature cf allowed -> withUser $ \user@User {profile} -> do - ACF f <- pure $ aChatFeature cf + SetUserFeature (ACF f) allowed -> withUser $ \user@User {profile} -> do let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user} updateProfile user p - SetContactFeature cf cName allowed_ -> withUser $ \user -> do + SetContactFeature (ACF f) cName allowed_ -> withUser $ \user -> do ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db user cName - ACF f <- pure $ aChatFeature cf let prefs' = setPreference f allowed_ $ Just userPreferences updateContactPrefs user ct prefs' - SetGroupFeature f gName enabled -> + SetGroupFeature (AGF f) gName enabled -> updateGroupProfileByName gName $ \p -> p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p} QuitChat -> liftIO exitSuccess @@ -1322,7 +1320,7 @@ assertDirectAllowed user dir ct event = unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $ throwChatError $ CEDirectMessagesProhibited dir ct where - directMessagesAllowed = any (groupFeatureAllowed' GFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct) + directMessagesAllowed = any (groupFeatureAllowed' SGFDirectMessages) <$> withStore' (\db -> getContactGroupPreferences db user ct) allowedChatEvent = case event of XMsgNew_ -> False XMsgUpdate_ -> False @@ -2374,7 +2372,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m () newGroupContentMessage gInfo@GroupInfo {chatSettings} m@GroupMember {localDisplayName = c} mc msg msgMeta = do let (ExtMsgContent content fInv_) = mcExtMsgContent mc - if isVoice content && not (groupFeatureAllowed GFVoice gInfo) + if isVoice content && not (groupFeatureAllowed SGFVoice gInfo) then void $ newChatItem (CIRcvGroupFeatureRejected GFVoice) Nothing else do ciFile_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m @@ -2421,7 +2419,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = (SMDRcv, CIGroupRcv m) -> if sameMemberId memberId m then - if groupFeatureAllowed GFFullDelete gInfo + if groupFeatureAllowed SGFFullDelete gInfo then deleteGroupCI user gInfo ci False >>= toView else markGroupCIDeleted user gInfo ci msgId False >>= toView else messageError "x.msg.del: group member attempted to delete a message of another member" -- shouldn't happen now that query includes group member id @@ -2630,9 +2628,9 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = createGroupFeatureItems :: GroupInfo -> GroupMember -> m () createGroupFeatureItems g@GroupInfo {groupProfile} m = do let prefs = mergeGroupPreferences $ groupPreferences groupProfile - forM_ allGroupFeatures $ \f -> do + forM_ allGroupFeatures $ \(AGF f) -> do let p = getGroupPreference f prefs - createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature f p) Nothing + createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p)) Nothing xInfoProbe :: Contact -> Probe -> m () xInfoProbe c2 probe = @@ -3254,11 +3252,11 @@ createFeatureChangedItems user Contact {mergedPreferences = cups} ct'@Contact {m createGroupFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> CIContent d) -> GroupProfile -> GroupProfile -> m () createGroupFeatureChangedItems user cd ciContent p p' = - forM_ allGroupFeatures $ \f -> do + forM_ allGroupFeatures $ \(AGF f) -> do let pref = getGroupPreference f $ groupPreferences p pref' = getGroupPreference f $ groupPreferences p' unless (pref == pref') $ - createInternalChatItem user cd (ciContent f pref') Nothing + createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref')) Nothing sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing} @@ -3532,13 +3530,13 @@ chatCommandP = "/profile_image" $> UpdateProfileImage Nothing, ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> userNames), ("/profile" <|> "/p") $> ShowProfile, - "/set voice #" *> (SetGroupFeature GFVoice <$> displayName <*> (A.space *> strP)), - "/set voice @" *> (SetContactFeature CFVoice <$> displayName <*> optional (A.space *> strP)), - "/set voice " *> (SetUserFeature CFVoice <$> strP), - "/set delete #" *> (SetGroupFeature GFFullDelete <$> displayName <*> (A.space *> strP)), - "/set delete @" *> (SetContactFeature CFFullDelete <$> displayName <*> optional (A.space *> strP)), - "/set delete " *> (SetUserFeature CFFullDelete <$> strP), - "/set direct #" *> (SetGroupFeature GFDirectMessages <$> displayName <*> (A.space *> strP)), + "/set voice #" *> (SetGroupFeature (AGF SGFVoice) <$> displayName <*> (A.space *> strP)), + "/set voice @" *> (SetContactFeature (ACF SCFVoice) <$> displayName <*> optional (A.space *> strP)), + "/set voice " *> (SetUserFeature (ACF SCFVoice) <$> strP), + "/set delete #" *> (SetGroupFeature (AGF SGFFullDelete) <$> displayName <*> (A.space *> strP)), + "/set delete @" *> (SetContactFeature (ACF SCFFullDelete) <$> displayName <*> optional (A.space *> strP)), + "/set delete " *> (SetUserFeature (ACF SCFFullDelete) <$> strP), + "/set direct #" *> (SetGroupFeature (AGF SGFDirectMessages) <$> displayName <*> (A.space *> strP)), "/incognito " *> (SetIncognito <$> onOffP), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion, @@ -3573,7 +3571,7 @@ chatCommandP = groupProfile = do gName <- displayName fullName <- fullNameP gName - let groupPreferences = Just (emptyGroupPrefs :: GroupPreferences) {directMessages = Just GroupPreference {enable = FEOn}} + let groupPreferences = Just (emptyGroupPrefs :: GroupPreferences) {directMessages = Just DirectMessagesGroupPreference {enable = FEOn}} pure GroupProfile {displayName = gName, fullName, description = Nothing, image = Nothing, groupPreferences} fullNameP name = do n <- (A.space *> A.takeByteString) <|> pure "" diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 43ea8ed6f1..4b19103a3b 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -260,9 +260,9 @@ data ChatCommand | ShowProfile | UpdateProfile ContactName Text | UpdateProfileImage (Maybe ImageData) - | SetUserFeature ChatFeature FeatureAllowed - | SetContactFeature ChatFeature ContactName (Maybe FeatureAllowed) - | SetGroupFeature GroupFeature GroupName GroupFeatureEnabled + | SetUserFeature AChatFeature FeatureAllowed + | SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed) + | SetGroupFeature AGroupFeature GroupName GroupFeatureEnabled | QuitChat | ShowVersion | DebugLocks diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 1fc34232f3..1be5103a0e 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -13,6 +13,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} @@ -274,8 +275,12 @@ data SChatFeature (f :: ChatFeature) where SCFFullDelete :: SChatFeature 'CFFullDelete SCFVoice :: SChatFeature 'CFVoice +deriving instance Show (SChatFeature f) + data AChatFeature = forall f. FeatureI f => ACF (SChatFeature f) +deriving instance Show AChatFeature + chatFeatureToText :: ChatFeature -> Text chatFeatureToText = \case CFTimedMessages -> "Disappearing messages" @@ -315,12 +320,6 @@ chatFeature = \case SCFFullDelete -> CFFullDelete SCFVoice -> CFVoice -aChatFeature :: ChatFeature -> AChatFeature -aChatFeature = \case - CFTimedMessages -> ACF SCFTimedMessages - CFFullDelete -> ACF SCFFullDelete - CFVoice -> ACF SCFVoice - class PreferenceI p where getPreference :: SChatFeature f -> p -> FeaturePreference f @@ -370,25 +369,39 @@ instance FromField Preferences where fromField = fromTextField_ decodeJSON data GroupFeature - = GFDirectMessages + = GFTimedMessages + | GFDirectMessages | GFFullDelete | -- | GFReceipts GFVoice deriving (Show, Generic) +data SGroupFeature (f :: GroupFeature) where + SGFTimedMessages :: SGroupFeature 'GFTimedMessages + SGFDirectMessages :: SGroupFeature 'GFDirectMessages + SGFFullDelete :: SGroupFeature 'GFFullDelete + -- SGFReceipts + SGFVoice :: SGroupFeature 'GFVoice + +deriving instance Show (SGroupFeature f) + +data AGroupFeature = forall f. GroupFeatureI f => AGF (SGroupFeature f) + +deriving instance Show AGroupFeature + groupFeatureToText :: GroupFeature -> Text groupFeatureToText = \case + GFTimedMessages -> "Disappearing messages" GFDirectMessages -> "Direct messages" GFFullDelete -> "Full deletion" GFVoice -> "Voice messages" -groupFeatureAllowed :: GroupFeature -> GroupInfo -> Bool +groupFeatureAllowed :: GroupFeatureI f => SGroupFeature f -> GroupInfo -> Bool groupFeatureAllowed feature gInfo = groupFeatureAllowed' feature $ fullGroupPreferences gInfo -groupFeatureAllowed' :: GroupFeature -> FullGroupPreferences -> Bool +groupFeatureAllowed' :: GroupFeatureI f => SGroupFeature f -> FullGroupPreferences -> Bool groupFeatureAllowed' feature prefs = - let GroupPreference {enable} = getGroupPreference feature prefs - in enable == FEOn + getField @"enable" (getGroupPreference feature prefs) == FEOn instance ToJSON GroupFeature where toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "GF" @@ -397,23 +410,32 @@ instance ToJSON GroupFeature where instance FromJSON GroupFeature where parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "GF" -allGroupFeatures :: [GroupFeature] +allGroupFeatures :: [AGroupFeature] allGroupFeatures = - [ GFDirectMessages, - GFFullDelete, + [ AGF SGFTimedMessages, + AGF SGFDirectMessages, + AGF SGFFullDelete, -- GFReceipts, - GFVoice + AGF SGFVoice ] -groupPrefSel :: GroupFeature -> GroupPreferences -> Maybe GroupPreference +groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f) groupPrefSel = \case - GFDirectMessages -> directMessages - GFFullDelete -> fullDelete + SGFTimedMessages -> timedMessages + SGFDirectMessages -> directMessages + SGFFullDelete -> fullDelete -- GFReceipts -> receipts - GFVoice -> voice + SGFVoice -> voice + +toGroupFeature :: SGroupFeature f -> GroupFeature +toGroupFeature = \case + SGFTimedMessages -> GFTimedMessages + SGFDirectMessages -> GFDirectMessages + SGFFullDelete -> GFFullDelete + SGFVoice -> GFVoice class GroupPreferenceI p where - getGroupPreference :: GroupFeature -> p -> GroupPreference + getGroupPreference :: SGroupFeature f -> p -> GroupFeaturePreference f instance GroupPreferenceI GroupPreferences where getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt prefs) @@ -423,18 +445,20 @@ instance GroupPreferenceI (Maybe GroupPreferences) where instance GroupPreferenceI FullGroupPreferences where getGroupPreference = \case - GFDirectMessages -> directMessages - GFFullDelete -> fullDelete + SGFTimedMessages -> timedMessages + SGFDirectMessages -> directMessages + SGFFullDelete -> fullDelete -- GFReceipts -> receipts - GFVoice -> voice + SGFVoice -> voice {-# INLINE getGroupPreference #-} -- collection of optional group preferences data GroupPreferences = GroupPreferences - { directMessages :: Maybe GroupPreference, - fullDelete :: Maybe GroupPreference, + { timedMessages :: Maybe TimedMessagesGroupPreference, + directMessages :: Maybe DirectMessagesGroupPreference, + fullDelete :: Maybe FullDeleteGroupPreference, -- receipts :: Maybe GroupPreference, - voice :: Maybe GroupPreference + voice :: Maybe VoiceGroupPreference } deriving (Eq, Show, Generic, FromJSON) @@ -448,14 +472,17 @@ instance ToField GroupPreferences where instance FromField GroupPreferences where fromField = fromTextField_ decodeJSON -setGroupPreference :: GroupFeature -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences +setGroupPreference :: forall f. GroupFeatureI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences setGroupPreference f enable prefs_ = - let prefs = mergeGroupPreferences prefs_ - pref = (getGroupPreference f prefs :: GroupPreference) {enable} - in toGroupPreferences $ case f of - GFDirectMessages -> prefs {directMessages = pref} - GFVoice -> prefs {voice = pref} - GFFullDelete -> prefs {fullDelete = pref} + toGroupPreferences $ case f of + SGFTimedMessages -> prefs {timedMessages = pref} + SGFDirectMessages -> prefs {directMessages = pref} + SGFVoice -> prefs {voice = pref} + SGFFullDelete -> prefs {fullDelete = pref} + where + prefs = mergeGroupPreferences prefs_ + pref :: GroupFeaturePreference f + pref = setField @"enable" (getGroupPreference f prefs) enable -- full collection of chat preferences defined in the app - it is used to ensure we include all preferences and to simplify processing -- if some of the preferences are not defined in Preferences, defaults from defaultChatPrefs are used here. @@ -472,10 +499,11 @@ instance ToJSON FullPreferences where toEncoding = J.genericToEncoding J.default -- full collection of group preferences defined in the app - it is used to ensure we include all preferences and to simplify processing -- if some of the preferences are not defined in GroupPreferences, defaults from defaultGroupPrefs are used here. data FullGroupPreferences = FullGroupPreferences - { directMessages :: GroupPreference, - fullDelete :: GroupPreference, + { timedMessages :: TimedMessagesGroupPreference, + directMessages :: DirectMessagesGroupPreference, + fullDelete :: FullDeleteGroupPreference, -- receipts :: GroupPreference, - voice :: GroupPreference + voice :: VoiceGroupPreference } deriving (Eq, Show, Generic, FromJSON) @@ -532,14 +560,15 @@ emptyChatPrefs = Preferences Nothing Nothing Nothing defaultGroupPrefs :: FullGroupPreferences defaultGroupPrefs = FullGroupPreferences - { directMessages = GroupPreference {enable = FEOff}, - fullDelete = GroupPreference {enable = FEOff}, + { timedMessages = TimedMessagesGroupPreference {enable = FEOff, ttl = 86400}, + directMessages = DirectMessagesGroupPreference {enable = FEOff}, + fullDelete = FullDeleteGroupPreference {enable = FEOff}, -- receipts = GroupPreference {enable = FEOff}, - voice = GroupPreference {enable = FEOn} + voice = VoiceGroupPreference {enable = FEOn} } emptyGroupPrefs :: GroupPreferences -emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing +emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing data TimedMessagesPreference = TimedMessagesPreference { allow :: FeatureAllowed, @@ -584,11 +613,70 @@ data GroupPreference = GroupPreference {enable :: GroupFeatureEnabled} deriving (Eq, Show, Generic, FromJSON) -groupPrefToText :: GroupPreference -> Text -groupPrefToText GroupPreference {enable} = safeDecodeUtf8 $ strEncode enable +data TimedMessagesGroupPreference = TimedMessagesGroupPreference + { enable :: GroupFeatureEnabled, + ttl :: Int + } + deriving (Eq, Show, Generic, FromJSON) + +data DirectMessagesGroupPreference = DirectMessagesGroupPreference + {enable :: GroupFeatureEnabled} + deriving (Eq, Show, Generic, FromJSON) + +data FullDeleteGroupPreference = FullDeleteGroupPreference + {enable :: GroupFeatureEnabled} + deriving (Eq, Show, Generic, FromJSON) + +data VoiceGroupPreference = VoiceGroupPreference + {enable :: GroupFeatureEnabled} + deriving (Eq, Show, Generic, FromJSON) instance ToJSON GroupPreference where toEncoding = J.genericToEncoding J.defaultOptions +instance ToJSON TimedMessagesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions + +instance ToJSON DirectMessagesGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions + +instance ToJSON FullDeleteGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions + +instance ToJSON VoiceGroupPreference where toEncoding = J.genericToEncoding J.defaultOptions + +class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference f) GroupFeatureEnabled) => GroupFeatureI f where + type GroupFeaturePreference (f :: GroupFeature) = p | p -> f + +instance HasField "enable" GroupPreference GroupFeatureEnabled where + hasField p = (\enable -> p {enable}, enable (p :: GroupPreference)) + +instance HasField "enable" TimedMessagesGroupPreference GroupFeatureEnabled where + hasField p = (\enable -> p {enable}, enable (p :: TimedMessagesGroupPreference)) + +instance HasField "enable" DirectMessagesGroupPreference GroupFeatureEnabled where + hasField p = (\enable -> p {enable}, enable (p :: DirectMessagesGroupPreference)) + +instance HasField "enable" FullDeleteGroupPreference GroupFeatureEnabled where + hasField p = (\enable -> p {enable}, enable (p :: FullDeleteGroupPreference)) + +instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where + hasField p = (\enable -> p {enable}, enable (p :: VoiceGroupPreference)) + +instance GroupFeatureI 'GFTimedMessages where + type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference + +instance GroupFeatureI 'GFDirectMessages where + type GroupFeaturePreference 'GFDirectMessages = DirectMessagesGroupPreference + +instance GroupFeatureI 'GFFullDelete where + type GroupFeaturePreference 'GFFullDelete = FullDeleteGroupPreference + +instance GroupFeatureI 'GFVoice where + type GroupFeaturePreference 'GFVoice = VoiceGroupPreference + +groupPrefToText :: HasField "enable" p GroupFeatureEnabled => p -> Text +groupPrefToText = safeDecodeUtf8 . strEncode . getField @"enable" + +toGroupPreference :: GroupFeatureI f => GroupFeaturePreference f -> GroupPreference +toGroupPreference p = GroupPreference {enable = getField @"enable" p} + data FeatureAllowed = FAAlways -- allow unconditionally | FAYes -- allow, if peer allows it @@ -667,23 +755,27 @@ mergeUserChatPrefs' user connectedIncognito userPreferences = mergeGroupPreferences :: Maybe GroupPreferences -> FullGroupPreferences mergeGroupPreferences groupPreferences = FullGroupPreferences - { directMessages = pref GFDirectMessages, - fullDelete = pref GFFullDelete, + { timedMessages = pref SGFTimedMessages, + directMessages = pref SGFDirectMessages, + fullDelete = pref SGFFullDelete, -- receipts = pref GFReceipts, - voice = pref GFVoice + voice = pref SGFVoice } where + pref :: SGroupFeature f -> GroupFeaturePreference f pref pt = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPreferences >>= groupPrefSel pt) toGroupPreferences :: FullGroupPreferences -> GroupPreferences toGroupPreferences groupPreferences = GroupPreferences - { directMessages = pref GFDirectMessages, - fullDelete = pref GFFullDelete, + { timedMessages = pref SGFTimedMessages, + directMessages = pref SGFDirectMessages, + fullDelete = pref SGFFullDelete, -- receipts = pref GFReceipts, - voice = pref GFVoice + voice = pref SGFVoice } where + pref :: SGroupFeature f -> Maybe (GroupFeaturePreference f) pref f = Just $ getGroupPreference f groupPreferences data PrefEnabled = PrefEnabled {forUser :: Bool, forContact :: Bool} diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 8525864402..101d90113b 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -26,6 +26,7 @@ import Data.Time.Clock (DiffTime, UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.LocalTime (ZonedTime (..), localDay, localTimeOfDay, timeOfDayToTime, utcToZonedTime) import GHC.Generics (Generic) +import GHC.Records.Compat import qualified Network.HTTP.Types as Q import Numeric (showFFloat) import Simplex.Chat (maxImageSize) @@ -50,7 +51,6 @@ import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Util (bshow) import System.Console.ANSI.Types -import GHC.Records.Compat type CurrentTime = UTCTime @@ -829,11 +829,11 @@ viewGroupUpdated | otherwise = bold' "updated group preferences:" : prefs where prefs = mapMaybe viewPref allGroupFeatures - viewPref pt + viewPref (AGF f) | pref gps == pref gps' = Nothing - | otherwise = Just $ plain (groupFeatureToText pt) <> " enabled: " <> plain (groupPrefToText $ pref gps') + | otherwise = Just $ plain (groupFeatureToText $ toGroupFeature f) <> " enabled: " <> plain (groupPrefToText $ pref gps') where - pref = getGroupPreference pt . mergeGroupPreferences + pref = getGroupPreference f . mergeGroupPreferences viewGroupProfile :: GroupInfo -> [StyledString] viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, groupPreferences = gps}} = @@ -842,9 +842,9 @@ viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, g <> maybe [] ((bold' "description:" :) . map plain . T.lines) description <> (bold' "group preferences:" : map viewPref allGroupFeatures) where - viewPref pt = plain (groupFeatureToText pt) <> " enabled: " <> plain (groupPrefToText $ pref gps) + viewPref (AGF f) = plain (groupFeatureToText $ toGroupFeature f) <> " enabled: " <> plain (groupPrefToText $ pref gps) where - pref = getGroupPreference pt . mergeGroupPreferences + pref = getGroupPreference f . mergeGroupPreferences bold' :: String -> StyledString bold' = styled Bold diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 3599a52bce..3770f618dc 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -1283,7 +1283,7 @@ testGroupMessageDelete = (cath <# "#team alice> hello!") -- alice: deletes msg id 5 - alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " internal", id, "message deleted") + alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted") alice #$> ("/_get chat #1 count=1", chat, [(0, "connected")]) bob #$> ("/_get chat #1 count=1", chat, [(0, "hello!")]) @@ -1309,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 2 <> " internal", id, "message deleted") + alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " 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 3 <> " text hi alice", id, "message updated") + bob #$> ("/_update item #1 " <> groupItemId 2 7 <> " text hi alice", id, "message updated") concurrently_ (alice <# "#team bob> [edited] hi alice") ( do @@ -1335,13 +1335,13 @@ testGroupMessageDelete = (alice <# "#team cath> how are you?") (bob <# "#team cath> how are you?") - cath #$> ("/_delete item #1 " <> groupItemId' 2 3 <> " broadcast", id, "message marked deleted") + cath #$> ("/_delete item #1 " <> groupItemId 2 7 <> " 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 2 <> " broadcast", id, "cannot delete this item") - alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " internal", id, "message deleted") + 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 #$> ("/_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)]) @@ -1561,6 +1561,7 @@ testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile where groupInfo alice = do alice <## "group preferences:" + alice <## "Disappearing messages enabled: off" alice <## "Direct messages enabled: on" alice <## "Full deletion enabled: off" alice <## "Voice messages enabled: on" @@ -4875,7 +4876,7 @@ groupFeatures :: [(Int, String)] groupFeatures = map (\(a, _, _) -> a) groupFeatures'' groupFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)] -groupFeatures'' = [((0, "Direct messages: on"), Nothing, Nothing), ((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: on"), Nothing, Nothing)] +groupFeatures'' = [((0, "Disappearing messages: off"), Nothing, Nothing), ((0, "Direct messages: on"), Nothing, Nothing), ((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: on"), Nothing, Nothing)] itemId :: Int -> String itemId i = show $ length chatFeatures + i diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 34a226c74b..87a8998d8c 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -83,7 +83,7 @@ testChatPreferences :: Maybe Preferences 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} +testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, voice = Just VoiceGroupPreference {enable = FEOn}, fullDelete = Nothing} testProfile :: Profile testProfile = Profile {displayName = "alice", fullName = "Alice", image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), preferences = testChatPreferences}