From 84e43c57f6b7d5746b47954acfa4e8e77bfd18dd Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Mon, 19 Dec 2022 21:18:59 +0400 Subject: [PATCH] core: ttl in feature chat items, view responses (#1595) * core: ttl in feature chat items, view responses * fix tests * fix test * view * refactor * use prefChangedValue * use groupPrefChangedValue * use cupIntValue * simplify types * groupFeatureState * groupPrefToText * prefToText, view * remove prefFeature * rename intValue -> param * int -> param * timedTTLText * remove pragma * restore pragma * simplify * timedTTLText * fix tests * off, after Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- src/Simplex/Chat.hs | 39 +++++++++---------- src/Simplex/Chat/Messages.hs | 64 ++++++++++++++++---------------- src/Simplex/Chat/Types.hs | 72 +++++++++++++++++++++++++++++++++++- src/Simplex/Chat/View.hs | 23 +++++++----- tests/ChatTests.hs | 28 +++++++------- 5 files changed, 150 insertions(+), 76 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index a5c5d9ff0d..704097c705 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1342,7 +1342,7 @@ processChatCommand = \case unless (sameGroupProfileInfo p p') $ do ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat g') ci - createGroupFeatureChangedItems user cd CISndGroupFeature p p' + createGroupFeatureChangedItems user cd CISndGroupFeature g g' pure $ CRGroupUpdated g g' Nothing updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse updateGroupProfileByName gName update = withUser $ \user -> do @@ -2767,15 +2767,15 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = createFeatureEnabledItems :: Contact -> m () createFeatureEnabledItems ct@Contact {mergedPreferences} = forM_ allChatFeatures $ \(ACF f) -> do - let ContactUserPreference {enabled} = getContactUserPreference f mergedPreferences - createInternalChatItem user (CDDirectRcv ct) (CIRcvChatFeature (chatFeature f) enabled) Nothing + let state = featureState $ getContactUserPreference f mergedPreferences + createInternalChatItem user (CDDirectRcv ct) (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing createGroupFeatureItems :: GroupInfo -> GroupMember -> m () - createGroupFeatureItems g@GroupInfo {groupProfile} m = do - let prefs = mergeGroupPreferences $ groupPreferences groupProfile + createGroupFeatureItems g@GroupInfo {fullGroupPreferences} m = forM_ allGroupFeatures $ \(AGF f) -> do - let p = getGroupPreference f prefs - createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p)) Nothing + let p = getGroupPreference f fullGroupPreferences + (_, param) = groupFeatureState p + createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing xInfoProbe :: Contact -> Probe -> m () xInfoProbe c2 probe = @@ -3078,7 +3078,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = unless (sameGroupProfileInfo p p') $ do ci <- saveRcvChatItem user cd msg msgMeta (CIRcvGroupEvent $ RGEGroupUpdated p') groupMsgToView g' m ci msgMeta - createGroupFeatureChangedItems user cd CIRcvGroupFeature p p' + createGroupFeatureChangedItems user cd CIRcvGroupFeature g g' sendDirectFileInline :: ChatMonad m => Contact -> FileTransferMeta -> SharedMsgId -> m () sendDirectFileInline ct ft sharedMsgId = do @@ -3391,21 +3391,22 @@ userProfileToSend user@User {profile = p} incognitoProfile ct = userPrefs = maybe (preferences' user) (const Nothing) incognitoProfile in (p' :: Profile) {preferences = Just . toChatPrefs $ mergePreferences (userPreferences <$> ct) userPrefs} -createFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> Contact -> Contact -> (Contact -> ChatDirection 'CTDirect d) -> (ChatFeature -> PrefEnabled -> CIContent d) -> m () +createFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> Contact -> Contact -> (Contact -> ChatDirection 'CTDirect d) -> (ChatFeature -> PrefEnabled -> Maybe Int -> CIContent d) -> m () createFeatureChangedItems user Contact {mergedPreferences = cups} ct'@Contact {mergedPreferences = cups'} chatDir ciContent = 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 (chatFeature f) enabled') Nothing + let state = featureState $ getContactUserPreference f cups + state' = featureState $ getContactUserPreference f cups' + when (state /= state') $ + createInternalChatItem user (chatDir ct') (uncurry (ciContent $ chatFeature f) state') Nothing -createGroupFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> CIContent d) -> GroupProfile -> GroupProfile -> m () -createGroupFeatureChangedItems user cd ciContent p p' = +createGroupFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> Maybe Int -> CIContent d) -> GroupInfo -> GroupInfo -> m () +createGroupFeatureChangedItems user cd ciContent GroupInfo {fullGroupPreferences = gps} GroupInfo {fullGroupPreferences = gps'} = forM_ allGroupFeatures $ \(AGF f) -> do - let pref = getGroupPreference f $ groupPreferences p - pref' = getGroupPreference f $ groupPreferences p' - unless (pref == pref') $ - createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref')) Nothing + let state = groupFeatureState $ getGroupPreference f gps + pref' = getGroupPreference f gps' + state'@(_, int') = groupFeatureState pref' + when (state /= state') $ + createInternalChatItem user cd (ciContent (toGroupFeature f) (toGroupPreference pref') int') Nothing sameGroupProfileInfo :: GroupProfile -> GroupProfile -> Bool sameGroupProfileInfo p p' = p {groupPreferences = Nothing} == p' {groupPreferences = Nothing} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 823df7a05d..db9ebefcb5 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -608,10 +608,10 @@ data CIContent (d :: MsgDirection) where CISndGroupEvent :: SndGroupEvent -> CIContent 'MDSnd CIRcvConnEvent :: RcvConnEvent -> CIContent 'MDRcv CISndConnEvent :: SndConnEvent -> CIContent 'MDSnd - CIRcvChatFeature :: ChatFeature -> PrefEnabled -> CIContent 'MDRcv - CISndChatFeature :: ChatFeature -> PrefEnabled -> CIContent 'MDSnd - CIRcvGroupFeature :: GroupFeature -> GroupPreference -> CIContent 'MDRcv - CISndGroupFeature :: GroupFeature -> GroupPreference -> CIContent 'MDSnd + CIRcvChatFeature :: ChatFeature -> PrefEnabled -> Maybe Int -> CIContent 'MDRcv + CISndChatFeature :: ChatFeature -> PrefEnabled -> Maybe Int -> CIContent 'MDSnd + CIRcvGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDRcv + CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDSnd CIRcvChatFeatureRejected :: ChatFeature -> CIContent 'MDRcv CIRcvGroupFeatureRejected :: GroupFeature -> CIContent 'MDRcv -- ^ This type is used both in API and in DB, so we use different JSON encodings for the database and for the API @@ -800,10 +800,10 @@ ciContentToText = \case CISndGroupEvent event -> sndGroupEventToText event CIRcvConnEvent event -> rcvConnEventToText event CISndConnEvent event -> sndConnEventToText event - CIRcvChatFeature feature enabled -> chatFeatureToText feature <> ": " <> prefEnabledToText enabled - CISndChatFeature feature enabled -> chatFeatureToText feature <> ": " <> prefEnabledToText enabled - CIRcvGroupFeature feature pref -> groupFeatureToText feature <> ": " <> groupPrefToText pref - CISndGroupFeature feature pref -> groupFeatureToText feature <> ": " <> groupPrefToText pref + CIRcvChatFeature feature enabled param -> chatFeatureToText feature <> ": " <> prefToText enabled param + CISndChatFeature feature enabled param -> chatFeatureToText feature <> ": " <> prefToText enabled param + CIRcvGroupFeature feature pref param -> groupFeatureToText feature <> ": " <> groupPrefToText pref param + CISndGroupFeature feature pref param -> groupFeatureToText feature <> ": " <> groupPrefToText pref param CIRcvChatFeatureRejected feature -> chatFeatureToText feature <> ": received, prohibited" CIRcvGroupFeatureRejected feature -> groupFeatureToText feature <> ": received, prohibited" @@ -856,10 +856,10 @@ data JSONCIContent | JCISndGroupEvent {sndGroupEvent :: SndGroupEvent} | JCIRcvConnEvent {rcvConnEvent :: RcvConnEvent} | JCISndConnEvent {sndConnEvent :: SndConnEvent} - | JCIRcvChatFeature {feature :: ChatFeature, enabled :: PrefEnabled} - | JCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled} - | JCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference} - | JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference} + | JCIRcvChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int} + | JCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int} + | JCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int} + | JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int} | JCIRcvChatFeatureRejected {feature :: ChatFeature} | JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} deriving (Generic) @@ -886,10 +886,10 @@ jsonCIContent = \case CISndGroupEvent sndGroupEvent -> JCISndGroupEvent {sndGroupEvent} CIRcvConnEvent rcvConnEvent -> JCIRcvConnEvent {rcvConnEvent} CISndConnEvent sndConnEvent -> JCISndConnEvent {sndConnEvent} - CIRcvChatFeature feature enabled -> JCIRcvChatFeature {feature, enabled} - CISndChatFeature feature enabled -> JCISndChatFeature {feature, enabled} - CIRcvGroupFeature groupFeature preference -> JCIRcvGroupFeature {groupFeature, preference} - CISndGroupFeature groupFeature preference -> JCISndGroupFeature {groupFeature, preference} + CIRcvChatFeature feature enabled param -> JCIRcvChatFeature {feature, enabled, param} + CISndChatFeature feature enabled param -> JCISndChatFeature {feature, enabled, param} + CIRcvGroupFeature groupFeature preference param -> JCIRcvGroupFeature {groupFeature, preference, param} + CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param} CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature} CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature} @@ -908,10 +908,10 @@ aciContentJSON = \case JCISndGroupEvent {sndGroupEvent} -> ACIContent SMDSnd $ CISndGroupEvent sndGroupEvent JCIRcvConnEvent {rcvConnEvent} -> ACIContent SMDRcv $ CIRcvConnEvent rcvConnEvent JCISndConnEvent {sndConnEvent} -> ACIContent SMDSnd $ CISndConnEvent sndConnEvent - JCIRcvChatFeature {feature, enabled} -> ACIContent SMDRcv $ CIRcvChatFeature feature enabled - JCISndChatFeature {feature, enabled} -> ACIContent SMDSnd $ CISndChatFeature feature enabled - JCIRcvGroupFeature {groupFeature, preference} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference - JCISndGroupFeature {groupFeature, preference} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference + JCIRcvChatFeature {feature, enabled, param} -> ACIContent SMDRcv $ CIRcvChatFeature feature enabled param + JCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param + JCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param + JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature @@ -930,10 +930,10 @@ data DBJSONCIContent | DBJCISndGroupEvent {sndGroupEvent :: DBSndGroupEvent} | DBJCIRcvConnEvent {rcvConnEvent :: DBRcvConnEvent} | DBJCISndConnEvent {sndConnEvent :: DBSndConnEvent} - | DBJCIRcvChatFeature {feature :: ChatFeature, enabled :: PrefEnabled} - | DBJCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled} - | DBJCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference} - | DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference} + | DBJCIRcvChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int} + | DBJCISndChatFeature {feature :: ChatFeature, enabled :: PrefEnabled, param :: Maybe Int} + | DBJCIRcvGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int} + | DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int} | DBJCIRcvChatFeatureRejected {feature :: ChatFeature} | DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} deriving (Generic) @@ -960,10 +960,10 @@ dbJsonCIContent = \case CISndGroupEvent sge -> DBJCISndGroupEvent $ SGE sge CIRcvConnEvent rce -> DBJCIRcvConnEvent $ RCE rce CISndConnEvent sce -> DBJCISndConnEvent $ SCE sce - CIRcvChatFeature feature enabled -> DBJCIRcvChatFeature {feature, enabled} - CISndChatFeature feature enabled -> DBJCISndChatFeature {feature, enabled} - CIRcvGroupFeature groupFeature preference -> DBJCIRcvGroupFeature {groupFeature, preference} - CISndGroupFeature groupFeature preference -> DBJCISndGroupFeature {groupFeature, preference} + CIRcvChatFeature feature enabled param -> DBJCIRcvChatFeature {feature, enabled, param} + CISndChatFeature feature enabled param -> DBJCISndChatFeature {feature, enabled, param} + CIRcvGroupFeature groupFeature preference param -> DBJCIRcvGroupFeature {groupFeature, preference, param} + CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param} CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature} CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature} @@ -982,10 +982,10 @@ aciContentDBJSON = \case DBJCISndGroupEvent (SGE sge) -> ACIContent SMDSnd $ CISndGroupEvent sge DBJCIRcvConnEvent (RCE rce) -> ACIContent SMDRcv $ CIRcvConnEvent rce DBJCISndConnEvent (SCE sce) -> ACIContent SMDSnd $ CISndConnEvent sce - DBJCIRcvChatFeature {feature, enabled} -> ACIContent SMDRcv $ CIRcvChatFeature feature enabled - DBJCISndChatFeature {feature, enabled} -> ACIContent SMDSnd $ CISndChatFeature feature enabled - DBJCIRcvGroupFeature {groupFeature, preference} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference - DBJCISndGroupFeature {groupFeature, preference} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference + DBJCIRcvChatFeature {feature, enabled, param} -> ACIContent SMDRcv $ CIRcvChatFeature feature enabled param + DBJCISndChatFeature {feature, enabled, param} -> ACIContent SMDSnd $ CISndChatFeature feature enabled param + DBJCIRcvGroupFeature {groupFeature, preference, param} -> ACIContent SMDRcv $ CIRcvGroupFeature groupFeature preference param + DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 7bf40aa240..d77e3a0a2d 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -614,6 +614,7 @@ instance ToJSON VoicePreference where toEncoding = J.genericToEncoding J.default class (Eq (FeaturePreference f), HasField "allow" (FeaturePreference f) FeatureAllowed) => FeatureI f where type FeaturePreference (f :: ChatFeature) = p | p -> f + prefParam :: FeaturePreference f -> Maybe Int instance HasField "allow" TimedMessagesPreference FeatureAllowed where hasField p = (\allow -> p {allow}, allow (p :: TimedMessagesPreference)) @@ -626,12 +627,15 @@ instance HasField "allow" VoicePreference FeatureAllowed where instance FeatureI 'CFTimedMessages where type FeaturePreference 'CFTimedMessages = TimedMessagesPreference + prefParam TimedMessagesPreference {ttl} = ttl instance FeatureI 'CFFullDelete where type FeaturePreference 'CFFullDelete = FullDeletePreference + prefParam _ = Nothing instance FeatureI 'CFVoice where type FeaturePreference 'CFVoice = VoicePreference + prefParam _ = Nothing data GroupPreference = GroupPreference {enable :: GroupFeatureEnabled} @@ -667,6 +671,7 @@ instance ToJSON VoiceGroupPreference where toEncoding = J.genericToEncoding J.de class (Eq (GroupFeaturePreference f), HasField "enable" (GroupFeaturePreference f) GroupFeatureEnabled) => GroupFeatureI f where type GroupFeaturePreference (f :: GroupFeature) = p | p -> f + groupPrefParam :: GroupFeaturePreference f -> Maybe Int instance HasField "enable" GroupPreference GroupFeatureEnabled where hasField p = (\enable -> p {enable}, enable (p :: GroupPreference)) @@ -685,18 +690,52 @@ instance HasField "enable" VoiceGroupPreference GroupFeatureEnabled where instance GroupFeatureI 'GFTimedMessages where type GroupFeaturePreference 'GFTimedMessages = TimedMessagesGroupPreference + groupPrefParam TimedMessagesGroupPreference {ttl} = Just ttl instance GroupFeatureI 'GFDirectMessages where type GroupFeaturePreference 'GFDirectMessages = DirectMessagesGroupPreference + groupPrefParam _ = Nothing instance GroupFeatureI 'GFFullDelete where type GroupFeaturePreference 'GFFullDelete = FullDeleteGroupPreference + groupPrefParam _ = Nothing instance GroupFeatureI 'GFVoice where type GroupFeaturePreference 'GFVoice = VoiceGroupPreference + groupPrefParam _ = Nothing -groupPrefToText :: HasField "enable" p GroupFeatureEnabled => p -> Text -groupPrefToText = safeDecodeUtf8 . strEncode . getField @"enable" +groupPrefToText :: HasField "enable" p GroupFeatureEnabled => p -> Maybe Int -> Text +groupPrefToText p = groupPrefToText_ $ getField @"enable" p + +groupPrefToText' :: GroupFeatureI f => GroupFeaturePreference f -> Text +groupPrefToText' p = groupPrefToText_ (getField @"enable" p) (groupPrefParam p) + +groupPrefToText_ :: GroupFeatureEnabled -> Maybe Int -> Text +groupPrefToText_ enabled param = do + let enabledText = safeDecodeUtf8 . strEncode $ enabled + paramText = if enabled == FEOn then maybe "" (\n -> ", after " <> timedTTLText n) param else "" + in enabledText <> paramText + +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} @@ -754,6 +793,12 @@ 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 @@ -817,6 +862,14 @@ prefEnabled asymmetric user contact = case (getField @"allow" user, getField @"a (FANo, _) -> PrefEnabled False False _ -> PrefEnabled True True +prefToText :: PrefEnabled -> Maybe Int -> Text +prefToText enabled param = + let paramText = if enabled == PrefEnabled True True then prefParamText param else "" + in prefEnabledToText enabled <> paramText + +prefParamText :: Maybe Int -> Text +prefParamText = maybe "" (\n -> ", after " <> timedTTLText n) + prefEnabledToText :: PrefEnabled -> Text prefEnabledToText = \case PrefEnabled True True -> "enabled" @@ -824,6 +877,21 @@ prefEnabledToText = \case PrefEnabled {forUser = True, forContact = False} -> "enabled for you" PrefEnabled {forUser = False, forContact = True} -> "enabled for contact" +prefToText' :: FeatureI f => FeaturePreference f -> Text +prefToText' p = + let allowed = getField @"allow" p + allowedText = case getField @"allow" p of + FAAlways -> "always" + FAYes -> "yes" + FANo -> "no" + paramText = if allowed == FAAlways || allowed == FAYes then prefParamText (prefParam p) else "" + in allowedText <> 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) + updateMergedPreferences :: User -> Contact -> Contact updateMergedPreferences user ct = let mergedPreferences = contactUserPreferences user (userPreferences ct) (preferences' ct) (contactConnIncognito ct) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index d594c305f5..44456b827d 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -26,7 +26,6 @@ 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) @@ -797,7 +796,7 @@ viewContactPreferences user ct ct' cups = 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 $ chatFeature f) <> ": " <> plain (prefEnabledToText enabled) <> " (you allow: " <> viewCountactUserPref userPreference <> ", contact allows: " <> viewPreference contactPreference <> ")" + | otherwise = Just $ viewFeatureText f <> ": " <> plain (prefEnabledToText enabled) <> " (you allow: " <> viewCountactUserPref userPreference <> ", contact allows: " <> viewPreference contactPreference <> ")" where userPref = getPreference f userPrefs userPref' = getPreference f userPrefs' @@ -812,15 +811,15 @@ viewPrefsUpdated ps ps' prefs = mapMaybe viewPref allChatFeatures viewPref (ACF f) | pref ps == pref ps' = Nothing - | otherwise = Just $ plain (chatFeatureToText $ chatFeature f) <> " allowed: " <> viewPreference (pref ps') + | otherwise = Just $ viewFeatureText f <> " allowed: " <> viewPreference (pref ps') where pref pss = getPreference f $ mergePreferences pss Nothing +viewFeatureText :: SChatFeature f -> StyledString +viewFeatureText f = plain . chatFeatureToText $ chatFeature f + viewPreference :: FeatureI f => FeaturePreference f -> StyledString -viewPreference p = case getField @"allow" p of - FAAlways -> "always" - FAYes -> "yes" - FANo -> "no" +viewPreference p = plain $ prefToText' p viewCountactUserPref :: FeatureI f => ContactUserPref (FeaturePreference f) -> StyledString viewCountactUserPref = \case @@ -850,10 +849,16 @@ viewGroupUpdated prefs = mapMaybe viewPref allGroupFeatures viewPref (AGF f) | pref gps == pref gps' = Nothing - | otherwise = Just $ plain (groupFeatureToText $ toGroupFeature f) <> " enabled: " <> plain (groupPrefToText $ pref gps') + | otherwise = Just $ viewGroupFeatureText f <> " enabled: " <> viewGroupPreference (pref gps') where pref = getGroupPreference f . mergeGroupPreferences +viewGroupFeatureText :: SGroupFeature f -> StyledString +viewGroupFeatureText f = plain . groupFeatureToText $ toGroupFeature f + +viewGroupPreference :: GroupFeatureI f => GroupFeaturePreference f -> StyledString +viewGroupPreference p = plain $ groupPrefToText' p + viewGroupProfile :: GroupInfo -> [StyledString] viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, groupPreferences = gps}} = [ttyFullGroup g] @@ -861,7 +866,7 @@ viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, g <> maybe [] ((bold' "description:" :) . map plain . T.lines) description <> (bold' "group preferences:" : map viewPref allGroupFeatures) where - viewPref (AGF f) = plain (groupFeatureToText $ toGroupFeature f) <> " enabled: " <> plain (groupPrefToText $ pref gps) + viewPref (AGF f) = viewGroupFeatureText f <> " enabled: " <> viewGroupPreference (pref gps) where pref = getGroupPreference f . mergeGroupPreferences diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index c561449ec0..06078f6295 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -3583,22 +3583,22 @@ testEnableTimedMessagesContact = connectUsers alice bob alice ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 1}}" alice <## "you updated preferences for bob:" - alice <## "Disappearing messages: off (you allow: yes, contact allows: no)" + alice <## "Disappearing messages: off (you allow: yes, after 1 sec, contact allows: no)" bob <## "alice updated preferences for you:" - bob <## "Disappearing messages: off (you allow: default (no), contact allows: yes)" + bob <## "Disappearing messages: off (you allow: default (no), contact allows: yes, after 1 sec)" -- TODO bob ##> "/set disappear @alice yes" bob ##> "/_set prefs @2 {\"timedMessages\": {\"allow\": \"yes\", \"ttl\": 1}}" bob <## "you updated preferences for alice:" - bob <## "Disappearing messages: enabled (you allow: yes, contact allows: yes)" + bob <## "Disappearing messages: enabled (you allow: yes, after 1 sec, contact allows: yes, after 1 sec)" alice <## "bob updated preferences for you:" - alice <## "Disappearing messages: enabled (you allow: yes, contact allows: yes)" + alice <## "Disappearing messages: enabled (you allow: yes, after 1 sec, contact allows: yes, after 1 sec)" alice <##> bob threadDelay 500000 - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled"), (1, "hi"), (0, "hey")]) - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled"), (0, "hi"), (1, "hey")]) + alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled, after 1 sec"), (1, "hi"), (0, "hey")]) + bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled, after 1 sec"), (0, "hi"), (1, "hey")]) threadDelay 1000000 - alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled")]) - bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled")]) + alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled, after 1 sec")]) + bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled, after 1 sec")]) testEnableTimedMessagesGroup :: IO () testEnableTimedMessagesGroup = @@ -3608,19 +3608,19 @@ testEnableTimedMessagesGroup = threadDelay 1000000 alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"timedMessages\": {\"enable\": \"on\", \"ttl\": 1}, \"directMessages\": {\"enable\": \"on\"}}}" alice <## "updated group preferences:" - alice <## "Disappearing messages enabled: on" + alice <## "Disappearing messages enabled: on, after 1 sec" bob <## "alice updated group #team:" bob <## "updated group preferences:" - bob <## "Disappearing messages enabled: on" + bob <## "Disappearing messages enabled: on, after 1 sec" threadDelay 1000000 alice #> "#team hi" bob <# "#team alice> hi" threadDelay 500000 - alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Disappearing messages: on"), (1, "hi")]) - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on"), (0, "hi")]) + alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Disappearing messages: on, after 1 sec"), (1, "hi")]) + bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on, after 1 sec"), (0, "hi")]) threadDelay 1000000 - alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Disappearing messages: on")]) - bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on")]) + alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Disappearing messages: on, after 1 sec")]) + bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on, after 1 sec")]) testGetSetSMPServers :: IO () testGetSetSMPServers =