From f128ebac871d94dc52dabd047c0a47abbdb04a4f Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Sat, 17 Dec 2022 14:49:03 +0400 Subject: [PATCH] core: timed messages terminal api, tests (#1591) --- src/Simplex/Chat.hs | 43 +++++++++++++++++++++++++----- src/Simplex/Chat/Controller.hs | 16 ++++++++++++ src/Simplex/Chat/Types.hs | 40 +++++++++++++++++++++------- tests/ChatTests.hs | 48 ++++++++++++++++++++++++++++++++++ 4 files changed, 132 insertions(+), 15 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 5d3572f10b..3521333da0 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -341,7 +341,7 @@ processChatCommand = \case msgTimed ct = case contactCITimedTTL ct of Just ttl -> do ts <- liftIO getCurrentTime - let deleteAt = addUTCTime (toEnum ttl) ts + let deleteAt = addUTCTime (realToFrac ttl) ts pure . Just $ CITimed ttl (Just deleteAt) Nothing -> pure Nothing prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect)) @@ -394,7 +394,7 @@ processChatCommand = \case msgTimed gInfo = case groupCITimedTTL gInfo of Just ttl -> do ts <- liftIO getCurrentTime - let deleteAt = addUTCTime (toEnum ttl) ts + let deleteAt = addUTCTime (realToFrac ttl) ts pure . Just $ CITimed ttl (Just deleteAt) Nothing -> pure Nothing sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m () @@ -513,7 +513,7 @@ processChatCommand = \case timedItems <- withStore' $ \db -> getDirectUnreadTimedItems db user chatId fromToIds ts <- liftIO getCurrentTime forM_ timedItems $ \(itemId, ttl) -> do - let deleteAt = addUTCTime (toEnum ttl) ts + let deleteAt = addUTCTime (realToFrac ttl) ts withStore' $ \db -> setDirectChatItemDeleteAt db user chatId itemId deleteAt when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTDirect chatId, itemId) deleteAt withStore' $ \db -> updateDirectChatItemsRead db userId chatId fromToIds @@ -522,7 +522,7 @@ processChatCommand = \case timedItems <- withStore' $ \db -> getGroupUnreadTimedItems db user chatId fromToIds ts <- liftIO getCurrentTime forM_ timedItems $ \(itemId, ttl) -> do - let deleteAt = addUTCTime (toEnum ttl) ts + let deleteAt = addUTCTime (realToFrac ttl) ts withStore' $ \db -> setGroupChatItemDeleteAt db user chatId itemId deleteAt when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTGroup chatId, itemId) deleteAt withStore' $ \db -> updateGroupChatItemsRead db userId chatId fromToIds @@ -1174,6 +1174,21 @@ processChatCommand = \case SetGroupFeature (AGF f) gName enabled -> updateGroupProfileByName gName $ \p -> p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p} + SetUserTimedMessages onOff -> withUser $ \user@User {profile} -> do + let allowed = if onOff then FAYes else FANo + pref = TimedMessagesPreference allowed Nothing + p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference' SCFTimedMessages (Just pref) $ preferences' user} + updateProfile user p + SetContactTimedMessages cName timedMessagesEnabled_ -> withUser $ \user -> do + ct@Contact {userPreferences = userPreferences@Preferences {timedMessages}} <- withStore $ \db -> getContactByName db user cName + let currentTTL = timedMessages >>= \TimedMessagesPreference {ttl} -> ttl + pref_ = tmeToPref currentTTL <$> timedMessagesEnabled_ + prefs' = setPreference' SCFTimedMessages pref_ $ Just userPreferences + updateContactPrefs user ct prefs' + SetGroupTimedMessages gName ttl_ -> do + let pref = uncurry TimedMessagesGroupPreference $ maybe (FEOff, 86400) (FEOn,) ttl_ + updateGroupProfileByName gName $ \p -> + p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p} QuitChat -> liftIO exitSuccess ShowVersion -> pure $ CRVersionInfo versionNumber DebugLocks -> do @@ -1710,7 +1725,7 @@ cleanupManager user = do where cleanupTimedItems = do ts <- liftIO getCurrentTime - let startTimedThreadCutoff = addUTCTime (toEnum cleanupManagerInterval) ts + let startTimedThreadCutoff = addUTCTime (realToFrac cleanupManagerInterval) ts timedItems <- withStore' $ \db -> getTimedItems db user startTimedThreadCutoff forM_ timedItems $ uncurry (startTimedItemThread user) @@ -1719,7 +1734,7 @@ startTimedItemThread user itemRef deleteAt = do itemThreads <- asks timedItemThreads threadTVar_ <- atomically $ do exists <- TM.member itemRef itemThreads - if exists + if not exists then do threadTVar <- newTVar Nothing TM.insert itemRef threadTVar itemThreads @@ -3648,6 +3663,9 @@ chatCommandP = "/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)), + "/set disappear #" *> (SetGroupTimedMessages <$> displayName <*> (A.space *> timedTTLOffP)), + "/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)), + "/set disappear " *> (SetUserTimedMessages <$> onOffP), "/incognito " *> (SetIncognito <$> onOffP), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion, @@ -3709,6 +3727,19 @@ chatCommandP = <|> ("week" $> Just (7 * 86400)) <|> ("month" $> Just (30 * 86400)) <|> ("none" $> Nothing) + timedTTLP = + ("30s" $> 30) + <|> ("5min" $> 300) + <|> ("1h" $> 3600) + <|> ("8h" $> (8 * 3600)) + <|> ("day" $> 86400) + <|> ("week" $> (7 * 86400)) + <|> ("month" $> (30 * 86400)) + timedTTLOffP = (Just <$> timedTTLP) <|> ("off" $> Nothing) + timedMessagesEnabledP = + optional "yes" *> A.space *> (TMEEnableSetTTL <$> timedTTLP) + <|> ("yes" $> TMEEnableKeepTTL) + <|> ("no" $> TMEDisableKeepTTL) netCfgP = do socksProxy <- "socks=" *> ("off" $> Nothing <|> "on" $> Just defaultSocksProxy <|> Just <$> strP) t_ <- optional $ " timeout=" *> A.decimal diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index e7fdf8b4d4..e4f984cb0d 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} @@ -267,6 +268,9 @@ data ChatCommand | SetUserFeature AChatFeature FeatureAllowed | SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed) | SetGroupFeature AGroupFeature GroupName GroupFeatureEnabled + | SetUserTimedMessages Bool + | SetContactTimedMessages ContactName (Maybe TimedMessagesEnabled) + | SetGroupTimedMessages GroupName (Maybe Int) | QuitChat | ShowVersion | DebugLocks @@ -512,6 +516,18 @@ data ServerAddress = ServerAddress instance ToJSON ServerAddress where toEncoding = J.genericToEncoding J.defaultOptions +data TimedMessagesEnabled + = TMEEnableSetTTL Int + | TMEEnableKeepTTL + | TMEDisableKeepTTL + deriving (Show) + +tmeToPref :: Maybe Int -> TimedMessagesEnabled -> TimedMessagesPreference +tmeToPref currentTTL tme = uncurry TimedMessagesPreference $ case tme of + TMEEnableSetTTL ttl -> (FAYes, Just ttl) + TMEEnableKeepTTL -> (FAYes, currentTTL) + TMEDisableKeepTTL -> (FANo, currentTTL) + data ChatError = ChatError {errorType :: ChatErrorType} | ChatErrorAgent {agentError :: AgentErrorType} diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index d5f3207e73..7bf40aa240 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -338,17 +338,25 @@ instance PreferenceI FullPreferences where {-# INLINE getPreference #-} setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences -setPreference f allow_ prefs_ = - let pref = setAllow <$> allow_ - in case f of - SCFTimedMessages -> prefs {timedMessages = pref} - SCFFullDelete -> prefs {fullDelete = pref} - SCFVoice -> prefs {voice = pref} +setPreference f allow_ prefs_ = setPreference_ f pref prefs where + pref = setAllow <$> allow_ setAllow :: FeatureAllowed -> FeaturePreference f setAllow = setField @"allow" (getPreference f prefs) prefs = toChatPrefs $ mergePreferences Nothing prefs_ +setPreference' :: SChatFeature f -> Maybe (FeaturePreference f) -> Maybe Preferences -> Preferences +setPreference' f pref_ prefs_ = setPreference_ f pref_ prefs + where + prefs = toChatPrefs $ mergePreferences Nothing prefs_ + +setPreference_ :: SChatFeature f -> Maybe (FeaturePreference f) -> Preferences -> Preferences +setPreference_ f pref_ prefs = + case f of + SCFTimedMessages -> prefs {timedMessages = pref_} + SCFFullDelete -> prefs {fullDelete = pref_} + SCFVoice -> prefs {voice = pref_} + -- collection of optional chat preferences for the user and the contact data Preferences = Preferences { timedMessages :: Maybe TimedMessagesPreference, @@ -473,16 +481,30 @@ instance FromField GroupPreferences where fromField = fromTextField_ decodeJSON setGroupPreference :: forall f. GroupFeatureI f => SGroupFeature f -> GroupFeatureEnabled -> Maybe GroupPreferences -> GroupPreferences -setGroupPreference f enable prefs_ = +setGroupPreference f enable prefs_ = setGroupPreference_ f pref prefs + where + prefs = mergeGroupPreferences prefs_ + pref :: GroupFeaturePreference f + pref = setField @"enable" (getGroupPreference f prefs) enable + +setGroupPreference' :: SGroupFeature f -> GroupFeaturePreference f -> Maybe GroupPreferences -> GroupPreferences +setGroupPreference' f pref prefs_ = setGroupPreference_ f pref prefs + where + prefs = mergeGroupPreferences prefs_ + +setGroupPreference_ :: SGroupFeature f -> GroupFeaturePreference f -> FullGroupPreferences -> GroupPreferences +setGroupPreference_ f pref prefs = toGroupPreferences $ case f of SGFTimedMessages -> prefs {timedMessages = pref} SGFDirectMessages -> prefs {directMessages = pref} SGFVoice -> prefs {voice = pref} SGFFullDelete -> prefs {fullDelete = pref} + +setGroupTimedMessagesPreference :: TimedMessagesGroupPreference -> Maybe GroupPreferences -> GroupPreferences +setGroupTimedMessagesPreference pref prefs_ = + toGroupPreferences $ prefs {timedMessages = 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. diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 3770f618dc..422624e9ec 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -140,6 +140,8 @@ chatTests = do it "allow full deletion to contact" testAllowFullDeletionContact it "allow full deletion to group" testAllowFullDeletionGroup it "prohibit direct messages to group members" testProhibitDirectMessages + it "enable timed messages with contact" testEnableTimedMessagesContact + it "enable timed messages in group" testEnableTimedMessagesGroup describe "SMP servers" $ do it "get and set SMP servers" testGetSetSMPServers it "test SMP server connection" testTestSMPServerConnection @@ -3551,6 +3553,52 @@ testProhibitDirectMessages = cc <## "updated group preferences:" cc <## "Direct messages enabled: off" +testEnableTimedMessagesContact :: IO () +testEnableTimedMessagesContact = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + 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)" + bob <## "alice updated preferences for you:" + bob <## "Disappearing messages: off (you allow: default (no), contact allows: yes)" + -- 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)" + alice <## "bob updated preferences for you:" + alice <## "Disappearing messages: enabled (you allow: yes, contact allows: yes)" + alice <##> bob + threadDelay 900000 + 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")]) + threadDelay 200000 + alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled")]) + bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled")]) + +testEnableTimedMessagesGroup :: IO () +testEnableTimedMessagesGroup = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + createGroup2 "team" alice bob + 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" + bob <## "alice updated group #team:" + bob <## "updated group preferences:" + bob <## "Disappearing messages enabled: on" + threadDelay 1000000 + alice #> "#team hi" + bob <# "#team alice> hi" + threadDelay 900000 + 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")]) + threadDelay 200000 + 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")]) + testGetSetSMPServers :: IO () testGetSetSMPServers = testChat2 aliceProfile bobProfile $