mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-31 01:05:55 +00:00
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>
This commit is contained in:
JRoberts
@@ -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}
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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 =
|
||||
|
||||
Reference in New Issue
Block a user