core: timed messages terminal api, tests (#1591)

2026-03-31 05:25:47 +00:00 · 2022-12-17 14:49:03 +04:00
parent b4de9c266b
commit f128ebac87
4 changed files with 132 additions and 15 deletions
--- 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
--- 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}
--- 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.
--- 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 $