core: different types for chat preferences, to allow parameters (#1565)

package.yaml

@@ -33,6 +33,7 @@ dependencies:
   - optparse-applicative >= 0.15 && < 0.17
   - process == 1.6.*
   - random >= 1.1 && < 1.3
+  - record-hasfield == 1.0.*
   - simple-logger == 0.1.*
   - simplexmq >= 3.4
   - socks == 0.6.*

simplex-chat.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -107,6 +107,7 @@ library
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
+    , record-hasfield ==1.0.*
     , simple-logger ==0.1.*
     , simplexmq >=3.4
     , socks ==0.6.*
@@ -149,6 +150,7 @@ executable simplex-bot
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
+    , record-hasfield ==1.0.*
     , simple-logger ==0.1.*
     , simplex-chat
     , simplexmq >=3.4
@@ -192,6 +194,7 @@ executable simplex-bot-advanced
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
+    , record-hasfield ==1.0.*
     , simple-logger ==0.1.*
     , simplex-chat
     , simplexmq >=3.4
@@ -236,6 +239,7 @@ executable simplex-chat
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
+    , record-hasfield ==1.0.*
     , simple-logger ==0.1.*
     , simplex-chat
     , simplexmq >=3.4
@@ -289,6 +293,7 @@ test-suite simplex-chat-test
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
+    , record-hasfield ==1.0.*
     , simple-logger ==0.1.*
     , simplex-chat
     , simplexmq >=3.4

src/Simplex/Chat.hs

@@ -291,7 +291,7 @@ processChatCommand = \case
       ct@Contact {localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
       assertDirectAllowed user MDSnd ct XMsgNew_
       unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
-      if isVoice mc && not (featureAllowed CFVoice forUser ct)
+      if isVoice mc && not (featureAllowed SCFVoice forUser ct)
         then pure $ chatCmdError $ "feature not allowed " <> T.unpack (chatFeatureToText CFVoice)
         else do
           (fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct
@@ -454,7 +454,7 @@ processChatCommand = \case
         (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
           (SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId)
           setActive $ ActiveC c
-          if featureAllowed CFFullDelete forUser ct
+          if featureAllowed SCFFullDelete forUser ct
             then deleteDirectCI user ct ci True
             else markDirectCIDeleted user ct ci msgId True
         (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete
@@ -1113,11 +1113,13 @@ processChatCommand = \case
   UpdateProfileImage image -> withUser $ \user@User {profile} -> do
     let p = (fromLocalProfile profile :: Profile) {image}
     updateProfile user p
-  SetUserFeature f allowed -> withUser $ \user@User {profile} -> do
+  SetUserFeature cf allowed -> withUser $ \user@User {profile} -> do
+    ACF f <- pure $ aChatFeature cf
     let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user}
     updateProfile user p
-  SetContactFeature f cName allowed_ -> withUser $ \user -> do
+  SetContactFeature cf 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 ->
@@ -2303,7 +2305,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
       unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
       checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
       let ExtMsgContent content fileInvitation_ = mcExtMsgContent mc
-      if isVoice content && not (featureAllowed CFVoice forContact ct)
+      if isVoice content && not (featureAllowed SCFVoice forContact ct)
         then do
           void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing
           setActive $ ActiveC c
@@ -2364,7 +2366,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
           ci@(CChatItem msgDir _) <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId
           case msgDir of
             SMDRcv ->
-              if featureAllowed CFFullDelete forContact ct
+              if featureAllowed SCFFullDelete forContact ct
                 then deleteDirectCI user ct ci False >>= toView
                 else markDirectCIDeleted user ct ci msgId False >>= toView
             SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete"
@@ -2621,9 +2623,9 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
 
     createFeatureEnabledItems :: Contact -> m ()
     createFeatureEnabledItems ct@Contact {mergedPreferences} =
-      forM_ allChatFeatures $ \f -> do
+      forM_ allChatFeatures $ \(ACF f) -> do
         let ContactUserPreference {enabled} = getContactUserPreference f mergedPreferences
-        createInternalChatItem user (CDDirectRcv ct) (CIRcvChatFeature f enabled) Nothing
+        createInternalChatItem user (CDDirectRcv ct) (CIRcvChatFeature (chatFeature f) enabled) Nothing
 
     createGroupFeatureItems :: GroupInfo -> GroupMember -> m ()
     createGroupFeatureItems g@GroupInfo {groupProfile} m = do
@@ -3244,11 +3246,11 @@ userProfileToSend user@User {profile = p} incognitoProfile ct =
 
 createFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> Contact -> Contact -> (Contact -> ChatDirection 'CTDirect d) -> (ChatFeature -> PrefEnabled -> CIContent d) -> m ()
 createFeatureChangedItems user Contact {mergedPreferences = cups} ct'@Contact {mergedPreferences = cups'} chatDir ciContent =
-  forM_ allChatFeatures $ \f -> do
+  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 f enabled') Nothing
+      createInternalChatItem user (chatDir ct') (ciContent (chatFeature f) enabled') Nothing
 
 createGroupFeatureChangedItems :: (MsgDirectionI d, ChatMonad m) => User -> ChatDirection 'CTGroup d -> (GroupFeature -> GroupPreference -> CIContent d) -> GroupProfile -> GroupProfile -> m ()
 createGroupFeatureChangedItems user cd ciContent p p' =

src/Simplex/Chat/Types.hs

@@ -1,17 +1,21 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
@@ -42,6 +46,7 @@ import Database.SQLite.Simple.Internal (Field (..))
 import Database.SQLite.Simple.Ok (Ok (Ok))
 import Database.SQLite.Simple.ToField (ToField (..))
 import GHC.Generics (Generic)
+import GHC.Records.Compat
 import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
@@ -258,17 +263,26 @@ pattern DisableNtfs :: ChatSettings
 pattern DisableNtfs = ChatSettings {enableNtfs = False}
 
 data ChatFeature
-  = CFFullDelete
+  = CFTimedMessages
+  | CFFullDelete
   | -- | CFReceipts
     CFVoice
   deriving (Show, Generic)
 
+data SChatFeature (f :: ChatFeature) where
+  SCFTimedMessages :: SChatFeature 'CFTimedMessages
+  SCFFullDelete :: SChatFeature 'CFFullDelete
+  SCFVoice :: SChatFeature 'CFVoice
+
+data AChatFeature = forall f. FeatureI f => ACF (SChatFeature f)
+
 chatFeatureToText :: ChatFeature -> Text
 chatFeatureToText = \case
+  CFTimedMessages -> "Disappearing messages"
   CFFullDelete -> "Full deletion"
   CFVoice -> "Voice messages"
 
-featureAllowed :: ChatFeature -> (PrefEnabled -> Bool) -> Contact -> Bool
+featureAllowed :: SChatFeature f -> (PrefEnabled -> Bool) -> Contact -> Bool
 featureAllowed feature forWhom Contact {mergedPreferences} =
   let ContactUserPreference {enabled} = getContactUserPreference feature mergedPreferences
    in forWhom enabled
@@ -280,48 +294,68 @@ instance ToJSON ChatFeature where
 instance FromJSON ChatFeature where
   parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CF"
 
-allChatFeatures :: [ChatFeature]
+allChatFeatures :: [AChatFeature]
 allChatFeatures =
-  [ CFFullDelete,
+  [ ACF SCFTimedMessages,
+    ACF SCFFullDelete,
     -- CFReceipts,
-    CFVoice
+    ACF SCFVoice
   ]
 
-chatPrefSel :: ChatFeature -> Preferences -> Maybe Preference
+chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f)
 chatPrefSel = \case
-  CFFullDelete -> fullDelete
+  SCFTimedMessages -> timedMessages
+  SCFFullDelete -> fullDelete
   -- CFReceipts -> receipts
-  CFVoice -> voice
+  SCFVoice -> voice
+
+chatFeature :: SChatFeature f -> ChatFeature
+chatFeature = \case
+  SCFTimedMessages -> CFTimedMessages
+  SCFFullDelete -> CFFullDelete
+  SCFVoice -> CFVoice
+
+aChatFeature :: ChatFeature -> AChatFeature
+aChatFeature = \case
+  CFTimedMessages -> ACF SCFTimedMessages
+  CFFullDelete -> ACF SCFFullDelete
+  CFVoice -> ACF SCFVoice
 
 class PreferenceI p where
-  getPreference :: ChatFeature -> p -> Preference
+  getPreference :: SChatFeature f -> p -> FeaturePreference f
 
 instance PreferenceI Preferences where
-  getPreference pt prefs = fromMaybe (getPreference pt defaultChatPrefs) (chatPrefSel pt prefs)
+  getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f prefs)
 
 instance PreferenceI (Maybe Preferences) where
-  getPreference pt prefs = fromMaybe (getPreference pt defaultChatPrefs) (chatPrefSel pt =<< prefs)
+  getPreference f prefs = fromMaybe (getPreference f defaultChatPrefs) (chatPrefSel f =<< prefs)
 
 instance PreferenceI FullPreferences where
   getPreference = \case
-    CFFullDelete -> fullDelete
+    SCFTimedMessages -> timedMessages
+    SCFFullDelete -> fullDelete
     -- CFReceipts -> receipts
-    CFVoice -> voice
+    SCFVoice -> voice
   {-# INLINE getPreference #-}
 
-setPreference :: ChatFeature -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences
+setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences
 setPreference f allow_ prefs_ =
-  let prefs = toChatPrefs $ mergePreferences Nothing prefs_
+  let pref = setAllow <$> allow_
-      pref = (\allow -> (getPreference f prefs :: Preference) {allow}) <$> allow_
    in case f of
-        CFVoice -> prefs {voice = pref}
+        SCFTimedMessages -> prefs {timedMessages = pref}
-        CFFullDelete -> prefs {fullDelete = pref}
+        SCFFullDelete -> prefs {fullDelete = pref}
+        SCFVoice -> prefs {voice = pref}
+  where
+    setAllow :: FeatureAllowed -> FeaturePreference f
+    setAllow = setField @"allow" (getPreference f prefs)
+    prefs = toChatPrefs $ mergePreferences Nothing prefs_
 
 -- collection of optional chat preferences for the user and the contact
 data Preferences = Preferences
-  { fullDelete :: Maybe Preference,
+  { timedMessages :: Maybe TimedMessagesPreference,
-    -- receipts :: Maybe Preference,
+    fullDelete :: Maybe FullDeletePreference,
-    voice :: Maybe Preference
+    -- receipts :: Maybe SimplePreference,
+    voice :: Maybe VoicePreference
   }
   deriving (Eq, Show, Generic, FromJSON)
 
@@ -426,9 +460,10 @@ setGroupPreference f enable prefs_ =
 -- 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.
 data FullPreferences = FullPreferences
-  { fullDelete :: Preference,
+  { timedMessages :: TimedMessagesPreference,
-    -- receipts :: Preference,
+    fullDelete :: FullDeletePreference,
-    voice :: Preference
+    -- receipts :: SimplePreference,
+    voice :: VoicePreference
   }
   deriving (Eq, Show, Generic, FromJSON)
 
@@ -448,34 +483,36 @@ instance ToJSON FullGroupPreferences where toEncoding = J.genericToEncoding J.de
 
 -- merged preferences of user for a given contact - they differentiate between specific preferences for the contact and global user preferences
 data ContactUserPreferences = ContactUserPreferences
-  { fullDelete :: ContactUserPreference,
+  { timedMessages :: ContactUserPreference TimedMessagesPreference,
+    fullDelete :: ContactUserPreference FullDeletePreference,
     -- receipts :: ContactUserPreference,
-    voice :: ContactUserPreference
+    voice :: ContactUserPreference VoicePreference
   }
   deriving (Eq, Show, Generic)
 
-data ContactUserPreference = ContactUserPreference
+data ContactUserPreference p = ContactUserPreference
   { enabled :: PrefEnabled,
-    userPreference :: ContactUserPref,
+    userPreference :: ContactUserPref p,
-    contactPreference :: Preference
+    contactPreference :: p
   }
   deriving (Eq, Show, Generic)
 
-data ContactUserPref = CUPContact {preference :: Preference} | CUPUser {preference :: Preference}
+data ContactUserPref p = CUPContact {preference :: p} | CUPUser {preference :: p}
   deriving (Eq, Show, Generic)
 
 instance ToJSON ContactUserPreferences where toEncoding = J.genericToEncoding J.defaultOptions
 
-instance ToJSON ContactUserPreference where toEncoding = J.genericToEncoding J.defaultOptions
+instance ToJSON p => ToJSON (ContactUserPreference p) where toEncoding = J.genericToEncoding J.defaultOptions
 
-instance ToJSON ContactUserPref where
+instance ToJSON p => ToJSON (ContactUserPref p) where
   toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CUP"
   toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CUP"
 
 toChatPrefs :: FullPreferences -> Preferences
-toChatPrefs FullPreferences {fullDelete, voice} =
+toChatPrefs FullPreferences {fullDelete, voice, timedMessages} =
   Preferences
-    { fullDelete = Just fullDelete,
+    { timedMessages = Just timedMessages,
+      fullDelete = Just fullDelete,
       -- receipts = Just receipts,
       voice = Just voice
     }
@@ -483,13 +520,14 @@ toChatPrefs FullPreferences {fullDelete, voice} =
 defaultChatPrefs :: FullPreferences
 defaultChatPrefs =
   FullPreferences
-    { fullDelete = Preference {allow = FANo},
+    { timedMessages = TimedMessagesPreference {allow = FANo, ttl = 86400},
-      -- receipts = Preference {allow = FANo},
+      fullDelete = FullDeletePreference {allow = FANo},
-      voice = Preference {allow = FAYes}
+      -- receipts = SimplePreference {allow = FANo},
+      voice = VoicePreference {allow = FAYes}
     }
 
 emptyChatPrefs :: Preferences
-emptyChatPrefs = Preferences Nothing Nothing
+emptyChatPrefs = Preferences Nothing Nothing Nothing
 
 defaultGroupPrefs :: FullGroupPreferences
 defaultGroupPrefs =
@@ -503,11 +541,44 @@ defaultGroupPrefs =
 emptyGroupPrefs :: GroupPreferences
 emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing
 
-data Preference = Preference
+data TimedMessagesPreference = TimedMessagesPreference
-  {allow :: FeatureAllowed}
+  { allow :: FeatureAllowed,
+    ttl :: Int
+  }
   deriving (Eq, Show, Generic, FromJSON)
 
-instance ToJSON Preference where toEncoding = J.genericToEncoding J.defaultOptions
+instance ToJSON TimedMessagesPreference where toEncoding = J.genericToEncoding J.defaultOptions
+
+data FullDeletePreference = FullDeletePreference {allow :: FeatureAllowed}
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON FullDeletePreference where toEncoding = J.genericToEncoding J.defaultOptions
+
+data VoicePreference = VoicePreference {allow :: FeatureAllowed}
+  deriving (Eq, Show, Generic, FromJSON)
+
+instance ToJSON VoicePreference where toEncoding = J.genericToEncoding J.defaultOptions
+
+class (Eq (FeaturePreference f), HasField "allow" (FeaturePreference f) FeatureAllowed) => FeatureI f where
+  type FeaturePreference (f :: ChatFeature) = p | p -> f
+
+instance HasField "allow" TimedMessagesPreference FeatureAllowed where
+  hasField p = (\allow -> p {allow}, allow (p :: TimedMessagesPreference))
+
+instance HasField "allow" FullDeletePreference FeatureAllowed where
+  hasField p = (\allow -> p {allow}, allow (p :: FullDeletePreference))
+
+instance HasField "allow" VoicePreference FeatureAllowed where
+  hasField p = (\allow -> p {allow}, allow (p :: VoicePreference))
+
+instance FeatureI 'CFTimedMessages where
+  type FeaturePreference 'CFTimedMessages = TimedMessagesPreference
+
+instance FeatureI 'CFFullDelete where
+  type FeaturePreference 'CFFullDelete = FullDeletePreference
+
+instance FeatureI 'CFVoice where
+  type FeaturePreference 'CFVoice = VoicePreference
 
 data GroupPreference = GroupPreference
   {enable :: GroupFeatureEnabled}
@@ -574,14 +645,16 @@ instance ToJSON GroupFeatureEnabled where
 mergePreferences :: Maybe Preferences -> Maybe Preferences -> FullPreferences
 mergePreferences contactPrefs userPreferences =
   FullPreferences
-    { fullDelete = pref CFFullDelete,
+    { timedMessages = pref SCFTimedMessages,
+      fullDelete = pref SCFFullDelete,
       -- receipts = pref CFReceipts,
-      voice = pref CFVoice
+      voice = pref SCFVoice
     }
   where
-    pref pt =
+    pref :: SChatFeature f -> FeaturePreference f
-      let sel = chatPrefSel pt
+    pref f =
-       in fromMaybe (getPreference pt defaultChatPrefs) $ (contactPrefs >>= sel) <|> (userPreferences >>= sel)
+      let sel = chatPrefSel f
+       in fromMaybe (getPreference f defaultChatPrefs) $ (contactPrefs >>= sel) <|> (userPreferences >>= sel)
 
 mergeUserChatPrefs :: User -> Contact -> FullPreferences
 mergeUserChatPrefs user ct = mergeUserChatPrefs' user (contactConnIncognito ct) (userPreferences ct)
@@ -620,8 +693,8 @@ instance ToJSON PrefEnabled where
   toJSON = J.genericToJSON J.defaultOptions
   toEncoding = J.genericToEncoding J.defaultOptions
 
-prefEnabled :: Preference -> Preference -> PrefEnabled
+prefEnabled :: FeatureI f => FeaturePreference f -> FeaturePreference f -> PrefEnabled
-prefEnabled Preference {allow = user} Preference {allow = contact} = case (user, contact) of
+prefEnabled user contact = case (getField @"allow" user, getField @"allow" contact) of
   (FAAlways, FANo) -> PrefEnabled {forUser = False, forContact = True}
   (FANo, FAAlways) -> PrefEnabled {forUser = True, forContact = False}
   (_, FANo) -> PrefEnabled False False
@@ -643,12 +716,14 @@ updateMergedPreferences user ct =
 contactUserPreferences :: User -> Preferences -> Maybe Preferences -> Bool -> ContactUserPreferences
 contactUserPreferences user userPreferences contactPreferences connectedIncognito =
   ContactUserPreferences
-    { fullDelete = pref CFFullDelete,
+    { timedMessages = pref SCFTimedMessages,
+      fullDelete = pref SCFFullDelete,
       -- receipts = pref CFReceipts,
-      voice = pref CFVoice
+      voice = pref SCFVoice
     }
   where
-    pref pt =
+    pref :: FeatureI f => SChatFeature f -> ContactUserPreference (FeaturePreference f)
+    pref f =
       ContactUserPreference
         { enabled = prefEnabled userPref ctPref,
           -- incognito contact cannot have default user preference used
@@ -656,18 +731,19 @@ contactUserPreferences user userPreferences contactPreferences connectedIncognit
           contactPreference = ctPref
         }
       where
-        ctUserPref = getPreference pt userPreferences
+        ctUserPref = getPreference f userPreferences
-        ctUserPref_ = chatPrefSel pt userPreferences
+        ctUserPref_ = chatPrefSel f userPreferences
-        userPref = getPreference pt ctUserPrefs
+        userPref = getPreference f ctUserPrefs
-        ctPref = getPreference pt ctPrefs
+        ctPref = getPreference f ctPrefs
     ctUserPrefs = mergeUserChatPrefs' user connectedIncognito userPreferences
     ctPrefs = mergePreferences contactPreferences Nothing
 
-getContactUserPreference :: ChatFeature -> ContactUserPreferences -> ContactUserPreference
+getContactUserPreference :: SChatFeature f -> ContactUserPreferences -> ContactUserPreference (FeaturePreference f)
 getContactUserPreference = \case
-  CFFullDelete -> fullDelete
+  SCFTimedMessages -> timedMessages
+  SCFFullDelete -> fullDelete
   -- CFReceipts -> receipts
-  CFVoice -> voice
+  SCFVoice -> voice
 
 data Profile = Profile
   { displayName :: ContactName,

src/Simplex/Chat/View.hs

@@ -50,6 +50,7 @@ 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
 
@@ -774,15 +775,15 @@ viewContactPreferences :: User -> Contact -> Contact -> ContactUserPreferences -
 viewContactPreferences user ct ct' cups =
   mapMaybe (viewContactPref (mergeUserChatPrefs user ct) (mergeUserChatPrefs user ct') (preferences' ct) cups) allChatFeatures
 
-viewContactPref :: FullPreferences -> FullPreferences -> Maybe Preferences -> ContactUserPreferences -> ChatFeature -> Maybe StyledString
+viewContactPref :: FullPreferences -> FullPreferences -> Maybe Preferences -> ContactUserPreferences -> AChatFeature -> Maybe StyledString
-viewContactPref userPrefs userPrefs' ctPrefs cups pt
+viewContactPref userPrefs userPrefs' ctPrefs cups (ACF f)
   | userPref == userPref' && ctPref == contactPreference = Nothing
-  | otherwise = Just $ plain (chatFeatureToText pt) <> ": " <> plain (prefEnabledToText enabled) <> " (you allow: " <> viewCountactUserPref userPreference <> ", contact allows: " <> viewPreference contactPreference <> ")"
+  | otherwise = Just $ plain (chatFeatureToText $ chatFeature f) <> ": " <> plain (prefEnabledToText enabled) <> " (you allow: " <> viewCountactUserPref userPreference <> ", contact allows: " <> viewPreference contactPreference <> ")"
   where
-    userPref = getPreference pt userPrefs
+    userPref = getPreference f userPrefs
-    userPref' = getPreference pt userPrefs'
+    userPref' = getPreference f userPrefs'
-    ctPref = getPreference pt ctPrefs
+    ctPref = getPreference f ctPrefs
-    ContactUserPreference {enabled, userPreference, contactPreference} = getContactUserPreference pt cups
+    ContactUserPreference {enabled, userPreference, contactPreference} = getContactUserPreference f cups
 
 viewPrefsUpdated :: Maybe Preferences -> Maybe Preferences -> [StyledString]
 viewPrefsUpdated ps ps'
@@ -790,20 +791,19 @@ viewPrefsUpdated ps ps'
   | otherwise = "updated preferences:" : prefs
   where
     prefs = mapMaybe viewPref allChatFeatures
-    viewPref pt
+    viewPref (ACF f)
       | pref ps == pref ps' = Nothing
-      | otherwise = Just $ plain (chatFeatureToText pt) <> " allowed: " <> viewPreference (pref ps')
+      | otherwise = Just $ plain (chatFeatureToText $ chatFeature f) <> " allowed: " <> viewPreference (pref ps')
       where
-        pref pss = getPreference pt $ mergePreferences pss Nothing
+        pref pss = getPreference f $ mergePreferences pss Nothing
 
-viewPreference :: Preference -> StyledString
+viewPreference :: FeatureI f => FeaturePreference f -> StyledString
-viewPreference = \case
+viewPreference p = case getField @"allow" p of
-  Preference {allow} -> case allow of
+  FAAlways -> "always"
-    FAAlways -> "always"
+  FAYes -> "yes"
-    FAYes -> "yes"
+  FANo -> "no"
-    FANo -> "no"
 
-viewCountactUserPref :: ContactUserPref -> StyledString
+viewCountactUserPref :: FeatureI f => ContactUserPref (FeaturePreference f) -> StyledString
 viewCountactUserPref = \case
   CUPUser p -> "default (" <> viewPreference p <> ")"
   CUPContact p -> viewPreference p

tests/ChatTests.hs

@@ -734,7 +734,7 @@ testGroup2 =
         <##? [ "dan> hi",
                "@dan hey"
              ]
-      alice ##> "/t 18"
+      alice ##> "/t 21"
       alice
         <##? [ "@bob sent invitation to join group club as admin",
                "@cath sent invitation to join group club as admin",
@@ -748,10 +748,13 @@ testGroup2 =
                "#club dan> how is it going?",
                "dan> hi",
                "@dan hey",
+               "dan> Disappearing messages: off",
                "dan> Full deletion: off",
                "dan> Voice messages: enabled",
+               "bob> Disappearing messages: off",
                "bob> Full deletion: off",
                "bob> Voice messages: enabled",
+               "cath> Disappearing messages: off",
                "cath> Full deletion: off",
                "cath> Voice messages: enabled"
              ]
@@ -1280,7 +1283,7 @@ testGroupMessageDelete =
         (cath <# "#team alice> hello!")
 
       -- alice: deletes msg id 5
-      alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted")
+      alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " internal", id, "message deleted")
 
       alice #$> ("/_get chat #1 count=1", chat, [(0, "connected")])
       bob #$> ("/_get chat #1 count=1", chat, [(0, "hello!")])
@@ -1306,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 5 <> " internal", id, "message deleted")
+      alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " 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 7 <> " text hi alice", id, "message updated")
+      bob #$> ("/_update item #1 " <> groupItemId' 2 3 <> " text hi alice", id, "message updated")
       concurrently_
         (alice <# "#team bob> [edited] hi alice")
         ( do
@@ -1332,13 +1335,13 @@ testGroupMessageDelete =
         (alice <# "#team cath> how are you?")
         (bob <# "#team cath> how are you?")
 
-      cath #$> ("/_delete item #1 " <> groupItemId 2 7 <> " broadcast", id, "message marked deleted")
+      cath #$> ("/_delete item #1 " <> groupItemId' 2 3 <> " 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 5 <> " broadcast", id, "cannot delete this item")
+      alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " broadcast", id, "cannot delete this item")
-      alice #$> ("/_delete item #1 " <> groupItemId 2 5 <> " internal", id, "message deleted")
+      alice #$> ("/_delete item #1 " <> groupItemId' 2 2 <> " 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)])
@@ -3333,7 +3336,7 @@ testSetContactPrefs = testChat2 aliceProfile bobProfile $
     alice ##> "/_set prefs @2 {}"
     alice <## "your preferences for bob did not change"
     (bob </)
-    let startFeatures = [(0, "Full deletion: off"), (0, "Voice messages: off")]
+    let startFeatures = [(0, "Disappearing messages: off"), (0, "Full deletion: off"), (0, "Voice messages: off")]
     alice #$> ("/_get chat @2 count=100", chat, startFeatures)
     bob #$> ("/_get chat @2 count=100", chat, startFeatures)
     let sendVoice = "/_send @2 json {\"filePath\": \"test.txt\", \"msgContent\": {\"type\": \"voice\", \"text\": \"\", \"duration\": 10}}"
@@ -3486,7 +3489,7 @@ testAllowFullDeletionGroup =
       bob <## "Full deletion enabled: on"
       alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "hi"), (0, "hey"), (1, "Full deletion: on")])
       bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (1, "hey"), (0, "Full deletion: on")])
-      bob #$> ("/_delete item #1 " <> groupItemId 2 5 <> " broadcast", id, "message deleted")
+      bob #$> ("/_delete item #1 " <> groupItemId' 2 1 <> " broadcast", id, "message deleted")
       alice <# "#team bob> [deleted] hey"
       alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "hi"), (1, "Full deletion: on")])
       bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "hi"), (0, "Full deletion: on")])
@@ -4866,7 +4869,7 @@ chatFeaturesF :: [((Int, String), Maybe String)]
 chatFeaturesF = map (\(a, _, c) -> (a, c)) chatFeatures''
 
 chatFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)]
-chatFeatures'' = [((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: enabled"), Nothing, Nothing)]
+chatFeatures'' = [((0, "Disappearing messages: off"), Nothing, Nothing), ((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: enabled"), Nothing, Nothing)]
 
 groupFeatures :: [(Int, String)]
 groupFeatures = map (\(a, _, _) -> a) groupFeatures''
@@ -4880,6 +4883,9 @@ itemId i = show $ length chatFeatures + i
 groupItemId :: Int -> Int -> String
 groupItemId n i = show $ length chatFeatures * n + i
 
+groupItemId' :: Int -> Int -> String
+groupItemId' n i = show $ length chatFeatures * n + length groupFeatures + i
+
 (@@@) :: TestCC -> [(String, String)] -> Expectation
 (@@@) = getChats . map $ \(ldn, msg, _) -> (ldn, msg)
 

tests/MobileTests.hs

@@ -32,9 +32,9 @@ activeUserExists = "{\"resp\":{\"type\":\"chatCmdError\",\"chatError\":{\"type\"
 
 activeUser :: String
 #if defined(darwin_HOST_OS) && defined(swiftJSON)
-activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
+activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\",\"ttl\":86400},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
 #else
-activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
+activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\",\"ttl\":86400},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true}}}"
 #endif
 
 chatStarted :: String

tests/ProtocolTests.hs

@@ -80,7 +80,7 @@ s #==# msg = do
   s ==# msg
 
 testChatPreferences :: Maybe Preferences
-testChatPreferences = Just Preferences {voice = Just Preference {allow = FAYes}, fullDelete = Nothing}
+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}