From bc5af35a3ed5ecbc31fd063e222716d2e0978bf0 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 8 May 2024 15:36:20 +0100 Subject: [PATCH] core: wallpapers api (#4110) * core: wallpapers api * optional colors * update * api * update * whitespace * typo * test, fix * fix color parsing * separate UI and Theme color schemes * update * enable test * multiple themes, one per color scheme * theme overrides as a separate type * rename --------- Co-authored-by: Avently <7953703+avently@users.noreply.github.com> --- simplex-chat.cabal | 2 + src/Simplex/Chat.hs | 42 ++++- src/Simplex/Chat/AppSettings.hs | 37 +++- src/Simplex/Chat/Archive.hs | 52 +++--- src/Simplex/Chat/Controller.hs | 15 ++ .../Chat/Migrations/M20240430_ui_theme.hs | 22 +++ src/Simplex/Chat/Migrations/chat_schema.sql | 7 +- src/Simplex/Chat/Store/Connections.hs | 15 +- src/Simplex/Chat/Store/Direct.hs | 55 +++++- src/Simplex/Chat/Store/Groups.hs | 29 +-- src/Simplex/Chat/Store/Migrations.hs | 4 +- src/Simplex/Chat/Store/Profiles.hs | 13 +- src/Simplex/Chat/Store/Shared.hs | 19 +- src/Simplex/Chat/Types.hs | 6 +- src/Simplex/Chat/Types/UITheme.hs | 166 ++++++++++++++++++ src/Simplex/Chat/View.hs | 12 +- tests/ChatTests/Profiles.hs | 61 ++++++- 17 files changed, 484 insertions(+), 73 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20240430_ui_theme.hs create mode 100644 src/Simplex/Chat/Types/UITheme.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index e9e1a4a723..f59d490cc4 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -141,6 +141,7 @@ library Simplex.Chat.Migrations.M20240313_drop_agent_ack_cmd_id Simplex.Chat.Migrations.M20240324_custom_data Simplex.Chat.Migrations.M20240402_item_forwarded + Simplex.Chat.Migrations.M20240430_ui_theme Simplex.Chat.Mobile Simplex.Chat.Mobile.File Simplex.Chat.Mobile.Shared @@ -176,6 +177,7 @@ library Simplex.Chat.Types Simplex.Chat.Types.Preferences Simplex.Chat.Types.Shared + Simplex.Chat.Types.UITheme Simplex.Chat.Types.Util Simplex.Chat.Util Simplex.Chat.View diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 8a3541af0a..9f93a98a53 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -249,6 +249,7 @@ newChatController showLiveItems <- newTVarIO False encryptLocalFiles <- newTVarIO False tempDirectory <- newTVarIO optTempDirectory + assetsDirectory <- newTVarIO Nothing contactMergeEnabled <- newTVarIO True pure ChatController @@ -285,6 +286,7 @@ newChatController showLiveItems, encryptLocalFiles, tempDirectory, + assetsDirectory, logFilePath = logFile, contactMergeEnabled } @@ -630,6 +632,17 @@ processChatCommand' vr = \case createDirectoryIfMissing True rf chatWriteVar remoteHostsFolder $ Just rf ok_ + -- has to be called before StartChat + APISetAppFilePaths cfg -> do + setFolder filesFolder $ appFilesFolder cfg + setFolder tempDirectory $ appTempFolder cfg + setFolder assetsDirectory $ appAssetsFolder cfg + mapM_ (setFolder remoteHostsFolder) $ appRemoteHostsFolder cfg + ok_ + where + setFolder sel f = do + createDirectoryIfMissing True f + chatWriteVar sel $ Just f APISetEncryptLocalFiles on -> chatWriteVar encryptLocalFiles on >> ok_ SetContactMergeEnabled onOff -> chatWriteVar contactMergeEnabled onOff >> ok_ APIExportArchive cfg -> checkChatStopped $ lift (exportArchive cfg) >> ok_ @@ -1226,6 +1239,25 @@ processChatCommand' vr = \case conn <- getPendingContactConnection db userId connId liftIO $ updateContactConnectionAlias db userId conn localAlias pure $ CRConnectionAliasUpdated user conn' + APISetUserUIThemes uId uiThemes -> withUser $ \user@User {userId} -> do + user'@User {userId = uId'} <- withStore $ \db -> do + user' <- getUser db uId + liftIO $ setUserUIThemes db user uiThemes + pure user' + when (userId == uId') $ chatWriteVar currentUser $ Just (user :: User) {uiThemes} + ok user' + APISetChatUIThemes (ChatRef cType chatId) uiThemes -> withUser $ \user -> case cType of + CTDirect -> do + withStore $ \db -> do + ct <- getContact db vr user chatId + liftIO $ setContactUIThemes db user ct uiThemes + ok user + CTGroup -> do + withStore $ \db -> do + g <- getGroupInfo db vr user chatId + liftIO $ setGroupUIThemes db user g uiThemes + ok user + _ -> pure $ chatCmdError (Just user) "not supported" APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text APIGetNtfToken -> withUser $ \_ -> crNtfToken <$> withAgent getNtfToken APIRegisterToken token mode -> withUser $ \_ -> @@ -3591,7 +3623,7 @@ processAgentMessageNoConn = \case processAgentMsgSndFile :: ACorrId -> SndFileId -> ACommand 'Agent 'AESndFile -> CM () processAgentMsgSndFile _corrId aFileId msg = do (cRef_, fileId) <- withStore (`getXFTPSndFileDBIds` AgentSndFileId aFileId) - withEntityLock_ cRef_ $ withFileLock "processAgentMsgSndFile" fileId $ + withEntityLock_ cRef_ . withFileLock "processAgentMsgSndFile" fileId $ withStore' (`getUserByASndFileId` AgentSndFileId aFileId) >>= \case Just user -> process user fileId `catchChatError` (toView . CRChatError (Just user)) _ -> do @@ -3718,7 +3750,7 @@ splitFileDescr rfdText = do processAgentMsgRcvFile :: ACorrId -> RcvFileId -> ACommand 'Agent 'AERcvFile -> CM () processAgentMsgRcvFile _corrId aFileId msg = do (cRef_, fileId) <- withStore (`getXFTPRcvFileDBIds` AgentRcvFileId aFileId) - withEntityLock_ cRef_ $ withFileLock "processAgentMsgRcvFile" fileId $ + withEntityLock_ cRef_ . withFileLock "processAgentMsgRcvFile" fileId $ withStore' (`getUserByARcvFileId` AgentRcvFileId aFileId) >>= \case Just user -> process user fileId `catchChatError` (toView . CRChatError (Just user)) _ -> do @@ -7028,9 +7060,13 @@ chatCommandP = "/_app activate" $> APIActivateChat True, "/_app suspend " *> (APISuspendChat <$> A.decimal), "/_resubscribe all" $> ResubscribeAllConnections, + -- deprecated, use /set file paths "/_temp_folder " *> (SetTempFolder <$> filePath), + -- /_files_folder deprecated, use /set file paths ("/_files_folder " <|> "/files_folder ") *> (SetFilesFolder <$> filePath), + -- deprecated, use /set file paths "/remote_hosts_folder " *> (SetRemoteHostsFolder <$> filePath), + "/set file paths " *> (APISetAppFilePaths <$> jsonP), "/_files_encrypt " *> (APISetEncryptLocalFiles <$> onOffP), "/contact_merge " *> (SetContactMergeEnabled <$> onOffP), "/_db export " *> (APIExportArchive <$> jsonP), @@ -7086,6 +7122,8 @@ chatCommandP = "/_set alias @" *> (APISetContactAlias <$> A.decimal <*> (A.space *> textP <|> pure "")), "/_set alias :" *> (APISetConnectionAlias <$> A.decimal <*> (A.space *> textP <|> pure "")), "/_set prefs @" *> (APISetContactPrefs <$> A.decimal <* A.space <*> jsonP), + "/_set theme user " *> (APISetUserUIThemes <$> A.decimal <*> optional (A.space *> jsonP)), + "/_set theme " *> (APISetChatUIThemes <$> chatRefP <*> optional (A.space *> jsonP)), "/_parse " *> (APIParseMarkdown . safeDecodeUtf8 <$> A.takeByteString), "/_ntf get" $> APIGetNtfToken, "/_ntf register " *> (APIRegisterToken <$> strP_ <*> strP), diff --git a/src/Simplex/Chat/AppSettings.hs b/src/Simplex/Chat/AppSettings.hs index 572ce0c67b..6996cc1d87 100644 --- a/src/Simplex/Chat/AppSettings.hs +++ b/src/Simplex/Chat/AppSettings.hs @@ -11,6 +11,7 @@ import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ import Data.Maybe (fromMaybe) import Data.Text (Text) +import Simplex.Chat.Types.UITheme import Simplex.Messaging.Client (NetworkConfig, defaultNetworkConfig) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) import Simplex.Messaging.Util (catchAll_) @@ -43,7 +44,11 @@ data AppSettings = AppSettings confirmDBUpgrades :: Maybe Bool, androidCallOnLockScreen :: Maybe LockScreenCalls, iosCallKitEnabled :: Maybe Bool, - iosCallKitCallsInRecents :: Maybe Bool + iosCallKitCallsInRecents :: Maybe Bool, + uiProfileImageCornerRadius :: Maybe Double, + uiColorScheme :: Maybe UIColorScheme, + uiDarkColorScheme :: Maybe DarkColorScheme, + uiThemes :: Maybe UIThemes } deriving (Show) @@ -69,7 +74,11 @@ defaultAppSettings = confirmDBUpgrades = Just False, androidCallOnLockScreen = Just LSCShow, iosCallKitEnabled = Just True, - iosCallKitCallsInRecents = Just False + iosCallKitCallsInRecents = Just False, + uiProfileImageCornerRadius = Just 22.5, + uiColorScheme = Just UCSSystem, + uiDarkColorScheme = Just DCSSimplex, + uiThemes = Nothing } defaultParseAppSettings :: AppSettings @@ -94,13 +103,17 @@ defaultParseAppSettings = confirmDBUpgrades = Nothing, androidCallOnLockScreen = Nothing, iosCallKitEnabled = Nothing, - iosCallKitCallsInRecents = Nothing + iosCallKitCallsInRecents = Nothing, + uiProfileImageCornerRadius = Nothing, + uiColorScheme = Nothing, + uiDarkColorScheme = Nothing, + uiThemes = Nothing } combineAppSettings :: AppSettings -> AppSettings -> AppSettings combineAppSettings platformDefaults storedSettings = AppSettings - { appPlatform = p appPlatform, + { appPlatform = p appPlatform, networkConfig = p networkConfig, privacyEncryptLocalFiles = p privacyEncryptLocalFiles, privacyAcceptImages = p privacyAcceptImages, @@ -119,7 +132,11 @@ combineAppSettings platformDefaults storedSettings = confirmDBUpgrades = p confirmDBUpgrades, iosCallKitEnabled = p iosCallKitEnabled, iosCallKitCallsInRecents = p iosCallKitCallsInRecents, - androidCallOnLockScreen = p androidCallOnLockScreen + androidCallOnLockScreen = p androidCallOnLockScreen, + uiProfileImageCornerRadius = p uiProfileImageCornerRadius, + uiColorScheme = p uiColorScheme, + uiDarkColorScheme = p uiDarkColorScheme, + uiThemes = p uiThemes } where p :: (AppSettings -> Maybe a) -> Maybe a @@ -157,6 +174,10 @@ instance FromJSON AppSettings where iosCallKitEnabled <- p "iosCallKitEnabled" iosCallKitCallsInRecents <- p "iosCallKitCallsInRecents" androidCallOnLockScreen <- p "androidCallOnLockScreen" + uiProfileImageCornerRadius <- p "uiProfileImageCornerRadius" + uiColorScheme <- p "uiColorScheme" + uiDarkColorScheme <- p "uiDarkColorScheme" + uiThemes <- p "uiThemes" pure AppSettings { appPlatform, @@ -178,7 +199,11 @@ instance FromJSON AppSettings where confirmDBUpgrades, iosCallKitEnabled, iosCallKitCallsInRecents, - androidCallOnLockScreen + androidCallOnLockScreen, + uiProfileImageCornerRadius, + uiColorScheme, + uiDarkColorScheme, + uiThemes } where p key = v .:? key <|> pure Nothing diff --git a/src/Simplex/Chat/Archive.hs b/src/Simplex/Chat/Archive.hs index d51f60f5f1..8550c03438 100644 --- a/src/Simplex/Chat/Archive.hs +++ b/src/Simplex/Chat/Archive.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -44,14 +45,22 @@ archiveChatDbFile = "simplex_v1_chat.db" archiveFilesFolder :: String archiveFilesFolder = "simplex_v1_files" +archiveAssetsFolder :: String +archiveAssetsFolder = "simplex_v1_assets" + +wallpapersFolder :: String +wallpapersFolder = "wallpapers" + exportArchive :: ArchiveConfig -> CM' () exportArchive cfg@ArchiveConfig {archivePath, disableCompression} = withTempDir cfg "simplex-chat." $ \dir -> do - StorageFiles {chatStore, agentStore, filesPath} <- storageFiles + StorageFiles {chatStore, agentStore, filesPath, assetsPath} <- storageFiles copyFile (dbFilePath chatStore) $ dir archiveChatDbFile copyFile (dbFilePath agentStore) $ dir archiveAgentDbFile forM_ filesPath $ \fp -> copyDirectoryFiles fp $ dir archiveFilesFolder + forM_ assetsPath $ \fp -> + copyDirectoryFiles (fp wallpapersFolder) $ dir archiveAssetsFolder wallpapersFolder let method = if disableCompression == Just True then Z.Store else Z.Deflate Z.createArchive archivePath $ Z.packDirRecur method Z.mkEntrySelector dir @@ -59,24 +68,24 @@ importArchive :: ArchiveConfig -> CM' [ArchiveError] importArchive cfg@ArchiveConfig {archivePath} = withTempDir cfg "simplex-chat." $ \dir -> do Z.withArchive archivePath $ Z.unpackInto dir - fs@StorageFiles {chatStore, agentStore, filesPath} <- storageFiles + fs@StorageFiles {chatStore, agentStore, filesPath, assetsPath} <- storageFiles liftIO $ closeSQLiteStore `withStores` fs backup `withDBs` fs copyFile (dir archiveChatDbFile) $ dbFilePath chatStore copyFile (dir archiveAgentDbFile) $ dbFilePath agentStore - copyFiles dir filesPath - `E.catch` \(e :: E.SomeException) -> pure [AEImport . ChatError . CEException $ show e] + errs <- copyFiles (dir archiveFilesFolder) filesPath + errs' <- copyFiles (dir archiveAssetsFolder wallpapersFolder) (( wallpapersFolder) <$> assetsPath) + pure $ errs <> errs' where backup f = whenM (doesFileExist f) $ copyFile f $ f <> ".bak" - copyFiles dir filesPath = do - let filesDir = dir archiveFilesFolder - case filesPath of - Just fp -> - ifM - (doesDirectoryExist filesDir) - (copyDirectoryFiles filesDir fp) - (pure []) - _ -> pure [] + copyFiles fromDir = \case + Just fp -> + ifM + (doesDirectoryExist fromDir) + (copyDirectoryFiles fromDir fp) + (pure []) + `E.catch` \(e :: E.SomeException) -> pure [AEImport . ChatError . CEException $ show e] + _ -> pure [] withTempDir :: ArchiveConfig -> (String -> (FilePath -> CM' a) -> CM' a) withTempDir cfg = case parentTempDirectory (cfg :: ArchiveConfig) of @@ -85,7 +94,7 @@ withTempDir cfg = case parentTempDirectory (cfg :: ArchiveConfig) of copyDirectoryFiles :: FilePath -> FilePath -> CM' [ArchiveError] copyDirectoryFiles fromDir toDir = do - createDirectoryIfMissing False toDir + createDirectoryIfMissing True toDir fs <- listDirectory fromDir foldM copyFileCatchError [] fs where @@ -103,6 +112,7 @@ deleteStorage = do liftIO $ closeSQLiteStore `withStores` fs remove `withDBs` fs mapM_ removeDir $ filesPath fs + mapM_ removeDir $ assetsPath fs mapM_ removeDir =<< chatReadVar tempDirectory where remove f = whenM (doesFileExist f) $ removeFile f @@ -111,15 +121,17 @@ deleteStorage = do data StorageFiles = StorageFiles { chatStore :: SQLiteStore, agentStore :: SQLiteStore, - filesPath :: Maybe FilePath + filesPath :: Maybe FilePath, + assetsPath :: Maybe FilePath } storageFiles :: CM' StorageFiles storageFiles = do - ChatController {chatStore, filesFolder, smpAgent} <- ask + ChatController {chatStore, filesFolder, assetsDirectory, smpAgent} <- ask let agentStore = agentClientStore smpAgent filesPath <- readTVarIO filesFolder - pure StorageFiles {chatStore, agentStore, filesPath} + assetsPath <- readTVarIO assetsDirectory + pure StorageFiles {chatStore, agentStore, filesPath, assetsPath} sqlCipherExport :: DBEncryptionConfig -> CM () sqlCipherExport DBEncryptionConfig {currentKey = DBEncryptionKey key, newKey = DBEncryptionKey key', keepKey} = @@ -177,9 +189,9 @@ testSQL k = T.unlines $ keySQL k <> [ "PRAGMA foreign_keys = ON;", - "PRAGMA secure_delete = ON;", - "SELECT count(*) FROM sqlite_master;" - ] + "PRAGMA secure_delete = ON;", + "SELECT count(*) FROM sqlite_master;" + ] keySQL :: BA.ScrubbedBytes -> [Text] keySQL k = ["PRAGMA key = " <> keyString k <> ";" | not (BA.null k)] diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 29566634f4..26ace9c772 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -63,6 +63,7 @@ import Simplex.Chat.Store (AutoAccept, ChatLockEntity, StoreError (..), UserCont import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared +import Simplex.Chat.Types.UITheme import Simplex.Chat.Util (liftIOEither) import Simplex.FileTransfer.Description (FileDescriptionURI) import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo) @@ -229,6 +230,7 @@ data ChatController = ChatController showLiveItems :: TVar Bool, encryptLocalFiles :: TVar Bool, tempDirectory :: TVar (Maybe FilePath), + assetsDirectory :: TVar (Maybe FilePath), logFilePath :: Maybe FilePath, contactMergeEnabled :: TVar Bool } @@ -265,6 +267,7 @@ data ChatCommand | SetTempFolder FilePath | SetFilesFolder FilePath | SetRemoteHostsFolder FilePath + | APISetAppFilePaths AppFilePathsConfig | APISetEncryptLocalFiles Bool | SetContactMergeEnabled Bool | APIExportArchive ArchiveConfig @@ -311,6 +314,8 @@ data ChatCommand | APISetContactPrefs ContactId Preferences | APISetContactAlias ContactId LocalAlias | APISetConnectionAlias Int64 LocalAlias + | APISetUserUIThemes UserId (Maybe UIThemeEntityOverrides) + | APISetChatUIThemes ChatRef (Maybe UIThemeEntityOverrides) | APIParseMarkdown Text | APIGetNtfToken | APIRegisterToken DeviceToken NotificationsMode @@ -928,6 +933,14 @@ instance StrEncoding DBEncryptionKey where instance FromJSON DBEncryptionKey where parseJSON = strParseJSON "DBEncryptionKey" +data AppFilePathsConfig = AppFilePathsConfig + { appFilesFolder :: FilePath, + appTempFolder :: FilePath, + appAssetsFolder :: FilePath, + appRemoteHostsFolder :: Maybe FilePath + } + deriving (Show) + data ContactSubStatus = ContactSubStatus { contact :: Contact, contactError :: Maybe ChatError @@ -1399,6 +1412,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "DB") ''DatabaseError) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "Chat") ''ChatError) +$(JQ.deriveJSON defaultJSON ''AppFilePathsConfig) + $(JQ.deriveJSON defaultJSON ''ContactSubStatus) $(JQ.deriveJSON defaultJSON ''MemberSubStatus) diff --git a/src/Simplex/Chat/Migrations/M20240430_ui_theme.hs b/src/Simplex/Chat/Migrations/M20240430_ui_theme.hs new file mode 100644 index 0000000000..1f4b9805cf --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20240430_ui_theme.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20240430_ui_theme where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20240430_ui_theme :: Query +m20240430_ui_theme = + [sql| +ALTER TABLE users ADD COLUMN ui_themes TEXT; +ALTER TABLE contacts ADD COLUMN ui_themes TEXT; +ALTER TABLE groups ADD COLUMN ui_themes TEXT; +|] + +down_m20240430_ui_theme :: Query +down_m20240430_ui_theme = + [sql| +ALTER TABLE users DROP COLUMN ui_themes; +ALTER TABLE contacts DROP COLUMN ui_themes; +ALTER TABLE groups DROP COLUMN ui_themes; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index f2d8e59ca7..f2f94d019c 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -34,7 +34,8 @@ CREATE TABLE users( show_ntfs INTEGER NOT NULL DEFAULT 1, send_rcpts_contacts INTEGER NOT NULL DEFAULT 0, send_rcpts_small_groups INTEGER NOT NULL DEFAULT 0, - user_member_profile_updated_at TEXT, -- 1 for active user + user_member_profile_updated_at TEXT, + ui_themes TEXT, -- 1 for active user FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE RESTRICT @@ -74,6 +75,7 @@ CREATE TABLE contacts( contact_grp_inv_sent INTEGER NOT NULL DEFAULT 0, contact_status TEXT NOT NULL DEFAULT 'active', custom_data BLOB, + ui_themes TEXT, FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE CASCADE @@ -122,7 +124,8 @@ CREATE TABLE groups( send_rcpts INTEGER, via_group_link_uri_hash BLOB, user_member_profile_sent_at TEXT, - custom_data BLOB, -- received + custom_data BLOB, + ui_themes TEXT, -- received FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE CASCADE diff --git a/src/Simplex/Chat/Store/Connections.hs b/src/Simplex/Chat/Store/Connections.hs index d42fd1d6f6..bae9d00bfd 100644 --- a/src/Simplex/Chat/Store/Connections.hs +++ b/src/Simplex/Chat/Store/Connections.hs @@ -22,8 +22,6 @@ import Control.Monad import Control.Monad.Except import Data.Int (Int64) import Data.Maybe (catMaybes, fromMaybe) -import Data.Text (Text) -import Data.Time.Clock (UTCTime (..)) import Database.SQLite.Simple (Only (..), (:.) (..)) import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Protocol @@ -32,7 +30,6 @@ import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Shared import Simplex.Chat.Types -import Simplex.Chat.Types.Preferences import Simplex.Messaging.Agent.Protocol (ConnId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -100,20 +97,20 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do db [sql| SELECT - c.contact_profile_id, c.local_display_name, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, c.via_group, c.contact_used, c.contact_status, c.enable_ntfs, c.send_rcpts, c.favorite, - p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts, c.contact_group_member_id, c.contact_grp_inv_sent, c.custom_data + c.contact_profile_id, c.local_display_name, c.via_group, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, c.contact_used, c.contact_status, c.enable_ntfs, c.send_rcpts, c.favorite, + p.preferences, c.user_preferences, c.created_at, c.updated_at, c.chat_ts, c.contact_group_member_id, c.contact_grp_inv_sent, c.ui_themes, c.custom_data FROM contacts c JOIN contact_profiles p ON c.contact_profile_id = p.contact_profile_id WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0 |] (userId, contactId) - toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool, Maybe CustomData)] -> Either StoreError Contact - toContact' contactId conn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, customData)] = + toContact' :: Int64 -> Connection -> [ContactRow'] -> Either StoreError Contact + toContact' contactId conn [(profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, uiThemes, customData)] = let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn activeConn = Just conn - in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, customData} + in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, uiThemes, customData} toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) getGroupAndMember_ groupMemberId c = ExceptT $ do @@ -125,7 +122,7 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do -- GroupInfo g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, - g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.custom_data, + g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.ui_themes, g.custom_data, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 650940b520..deb0f9fc4c 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -69,6 +69,7 @@ module Simplex.Chat.Store.Direct setConnConnReqInv, resetContactConnInitiated, setContactCustomData, + setContactUIThemes, ) where @@ -87,6 +88,7 @@ import Simplex.Chat.Messages import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.Preferences +import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Protocol (ConnId, InvitationId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -176,7 +178,7 @@ getContactByConnReqHash db vr user@User {userId} cReqHash = SELECT -- Contact ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.custom_data, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.ui_themes, ct.custom_data, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, @@ -222,7 +224,26 @@ createDirectContact db user@User {userId} conn@Connection {connId, localAlias} p let profile = toLocalProfile profileId p localAlias userPreferences = emptyChatPrefs mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn - pure $ Contact {contactId, localDisplayName, profile, activeConn = Just conn, viaGroup = Nothing, contactUsed, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Nothing, contactGrpInvSent = False, customData = Nothing} + pure $ + Contact + { contactId, + localDisplayName, + profile, + activeConn = Just conn, + viaGroup = Nothing, + contactUsed, + contactStatus = CSActive, + chatSettings = defaultChatSettings, + userPreferences, + mergedPreferences, + createdAt = currentTs, + updatedAt = currentTs, + chatTs = Just currentTs, + contactGroupMemberId = Nothing, + contactGrpInvSent = False, + customData = Nothing, + uiThemes = Nothing + } deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO () deleteContactConnectionsAndFiles db userId Contact {contactId} = do @@ -579,7 +600,7 @@ createOrUpdateContactRequest db vr user@User {userId} userContactLinkId invId (V SELECT -- Contact ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.custom_data, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.ui_themes, ct.custom_data, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, @@ -725,7 +746,26 @@ createAcceptedContact db user@User {userId, profile = LocalProfile {preferences} contactId <- insertedRowId db conn <- createConnection_ db userId ConnContact (Just contactId) agentConnId connChatVersion cReqChatVRange Nothing (Just userContactLinkId) customUserProfileId 0 createdAt subMode pqSup let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn - pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn = Just conn, viaGroup = Nothing, contactUsed, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt, contactGroupMemberId = Nothing, contactGrpInvSent = False, customData = Nothing} + pure $ + Contact + { contactId, + localDisplayName, + profile = toLocalProfile profileId profile "", + activeConn = Just conn, + viaGroup = Nothing, + contactUsed, + contactStatus = CSActive, + chatSettings = defaultChatSettings, + userPreferences, + mergedPreferences, + createdAt, + updatedAt = createdAt, + chatTs = Just createdAt, + contactGroupMemberId = Nothing, + contactGrpInvSent = False, + uiThemes = Nothing, + customData = Nothing + } getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64 getContactIdByName db User {userId} cName = @@ -744,7 +784,7 @@ getContact_ db vr user@User {userId} contactId deleted = SELECT -- Contact ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite, - cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.custom_data, + cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent, ct.ui_themes, ct.custom_data, -- Connection c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, @@ -889,3 +929,8 @@ setContactCustomData :: DB.Connection -> User -> Contact -> Maybe CustomData -> setContactCustomData db User {userId} Contact {contactId} customData = do updatedAt <- getCurrentTime DB.execute db "UPDATE contacts SET custom_data = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" (customData, updatedAt, userId, contactId) + +setContactUIThemes :: DB.Connection -> User -> Contact -> Maybe UIThemeEntityOverrides -> IO () +setContactUIThemes db User {userId} Contact {contactId} uiThemes = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE contacts SET ui_themes = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" (uiThemes, updatedAt, userId, contactId) diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 23796f95e7..d8655c818b 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -3,8 +3,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -117,6 +117,7 @@ module Simplex.Chat.Store.Groups updateUnknownMemberAnnounced, updateUserMemberProfileSentAt, setGroupCustomData, + setGroupUIThemes, ) where @@ -141,6 +142,7 @@ import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared +import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Protocol (ConnId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -151,19 +153,19 @@ import Simplex.Messaging.Util (eitherToMaybe, ($>>=), (<$$>)) import Simplex.Messaging.Version import UnliftIO.STM -type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe MsgFilter, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime, Maybe CustomData) :. GroupMemberRow +type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe MsgFilter, Maybe Bool, Bool, Maybe GroupPreferences) :. (UTCTime, UTCTime, Maybe UTCTime, Maybe UTCTime, Maybe UIThemeEntityOverrides, Maybe CustomData) :. GroupMemberRow type GroupMemberRow = ((Int64, Int64, MemberId, VersionChat, VersionChat, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Bool, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences)) type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe VersionChat, Maybe VersionChat, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences)) toGroupInfo :: VersionRangeChat -> Int64 -> GroupInfoRow -> GroupInfo -toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt, customData) :. userMemberRow) = +toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt, uiThemes, customData) :. userMemberRow) = let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} fullGroupPreferences = mergeGroupPreferences groupPreferences groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} - in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, customData} + in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, uiThemes, customData} toGroupMember :: Int64 -> GroupMemberRow -> GroupMember toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) = @@ -274,7 +276,7 @@ getGroupAndMember db User {userId, userContactId} groupMemberId vr = -- GroupInfo g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, - g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.custom_data, + g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.ui_themes, g.custom_data, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -348,6 +350,7 @@ createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = Exc updatedAt = currentTs, chatTs = Just currentTs, userMemberProfileSentAt = Just currentTs, + uiThemes = Nothing, customData = Nothing } @@ -414,6 +417,7 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ updatedAt = currentTs, chatTs = Just currentTs, userMemberProfileSentAt = Just currentTs, + uiThemes = Nothing, customData = Nothing }, groupMemberId @@ -633,7 +637,7 @@ getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, - g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.custom_data, + g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.ui_themes, g.custom_data, mu.group_member_id, g.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.contact_link, pu.local_alias, pu.preferences FROM groups g @@ -1298,7 +1302,7 @@ getViaGroupMember db vr User {userId, userContactId} Contact {contactId} = -- GroupInfo g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, - g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.custom_data, + g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.ui_themes, g.custom_data, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -1394,7 +1398,7 @@ getGroupInfo db vr User {userId, userContactId} groupId = -- GroupInfo g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, g.send_rcpts, g.favorite, gp.preferences, - g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.custom_data, + g.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, g.ui_themes, g.custom_data, -- GroupMember - membership mu.group_member_id, mu.group_id, mu.member_id, mu.peer_chat_min_version, mu.peer_chat_max_version, mu.member_role, mu.member_category, mu.member_status, mu.show_messages, mu.member_restriction, mu.invited_by, mu.invited_by_group_member_id, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -1956,7 +1960,7 @@ createMemberContact authErrCounter = 0 } mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn - pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False, customData = Nothing} + pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False, uiThemes = Nothing, customData = Nothing} getMemberContact :: DB.Connection -> VersionRangeChat -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation) getMemberContact db vr user contactId = do @@ -1993,7 +1997,7 @@ createMemberContactInvited contactId <- createContactUpdateMember currentTs userPreferences ctConn <- createMemberContactConn_ db user connIds gInfo mConn contactId subMode let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn - mCt' = Contact {contactId, localDisplayName = memberLDN, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Nothing, contactGrpInvSent = False, customData = Nothing} + mCt' = Contact {contactId, localDisplayName = memberLDN, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Nothing, contactGrpInvSent = False, uiThemes = Nothing, customData = Nothing} m' = m {memberContactId = Just contactId} pure (mCt', m') where @@ -2198,3 +2202,8 @@ setGroupCustomData :: DB.Connection -> User -> GroupInfo -> Maybe CustomData -> setGroupCustomData db User {userId} GroupInfo {groupId} customData = do updatedAt <- getCurrentTime DB.execute db "UPDATE groups SET custom_data = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (customData, updatedAt, userId, groupId) + +setGroupUIThemes :: DB.Connection -> User -> GroupInfo -> Maybe UIThemeEntityOverrides -> IO () +setGroupUIThemes db User {userId} GroupInfo {groupId} uiThemes = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE groups SET ui_themes = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (uiThemes, updatedAt, userId, groupId) diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index 7a3fb75da3..2b44778272 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -105,6 +105,7 @@ import Simplex.Chat.Migrations.M20240228_pq import Simplex.Chat.Migrations.M20240313_drop_agent_ack_cmd_id import Simplex.Chat.Migrations.M20240324_custom_data import Simplex.Chat.Migrations.M20240402_item_forwarded +import Simplex.Chat.Migrations.M20240430_ui_theme import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -209,7 +210,8 @@ schemaMigrations = ("20240228_pq", m20240228_pq, Just down_m20240228_pq), ("20240313_drop_agent_ack_cmd_id", m20240313_drop_agent_ack_cmd_id, Just down_m20240313_drop_agent_ack_cmd_id), ("20240324_custom_data", m20240324_custom_data, Just down_m20240324_custom_data), - ("20240402_item_forwarded", m20240402_item_forwarded, Just down_m20240402_item_forwarded) + ("20240402_item_forwarded", m20240402_item_forwarded, Just down_m20240402_item_forwarded), + ("20240430_ui_theme", m20240430_ui_theme, Just down_m20240430_ui_theme) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index c92bf3391c..9b83e7299f 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -57,6 +57,7 @@ module Simplex.Chat.Store.Profiles deleteCommand, updateCommandStatus, getCommandDataByCorrId, + setUserUIThemes, ) where @@ -82,6 +83,7 @@ import Simplex.Chat.Store.Shared import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared +import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -123,7 +125,7 @@ createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, image, (profileId, displayName, userId, True, currentTs, currentTs, currentTs) contactId <- insertedRowId db DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId) - pure $ toUser $ (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, Nothing, userPreferences) :. (showNtfs, sendRcptsContacts, sendRcptsSmallGroups, Nothing, Nothing, Nothing) + pure $ toUser $ (userId, auId, contactId, profileId, activeUser, displayName, fullName, image, Nothing, userPreferences) :. (showNtfs, sendRcptsContacts, sendRcptsSmallGroups, Nothing, Nothing, Nothing, Nothing) getUsersInfo :: DB.Connection -> IO [UserInfo] getUsersInfo db = getUsers db >>= mapM getUserInfo @@ -274,8 +276,8 @@ updateUserProfile db user p' where updateUserMemberProfileUpdatedAt_ currentTs | userMemberProfileChanged = do - DB.execute db "UPDATE users SET user_member_profile_updated_at = ? WHERE user_id = ?" (currentTs, userId) - pure $ Just currentTs + DB.execute db "UPDATE users SET user_member_profile_updated_at = ? WHERE user_id = ?" (currentTs, userId) + pure $ Just currentTs | otherwise = pure userMemberProfileUpdatedAt userMemberProfileChanged = newName /= displayName || newFullName /= fullName || newImage /= image User {userId, userContactId, localDisplayName, profile = LocalProfile {profileId, displayName, fullName, image, localAlias}, userMemberProfileUpdatedAt} = user @@ -619,3 +621,8 @@ getCommandDataByCorrId db User {userId} corrId = where toCommandData :: (CommandId, Maybe Int64, CommandFunction, CommandStatus) -> CommandData toCommandData (cmdId, cmdConnId, cmdFunction, cmdStatus) = CommandData {cmdId, cmdConnId, cmdFunction, cmdStatus} + +setUserUIThemes :: DB.Connection -> User -> Maybe UIThemeEntityOverrides -> IO () +setUserUIThemes db User {userId} uiThemes = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE users SET ui_themes = ?, updated_at = ? WHERE user_id = ?" (uiThemes, updatedAt, userId) diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index fe86b0c2df..1f16ebfef0 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -3,8 +3,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} @@ -33,6 +33,7 @@ import Simplex.Chat.Protocol import Simplex.Chat.Remote.Types import Simplex.Chat.Types import Simplex.Chat.Types.Preferences +import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Protocol (ConnId, UserId) import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB @@ -380,16 +381,18 @@ deleteUnusedIncognitoProfileById_ db User {userId} profileId = |] [":user_id" := userId, ":profile_id" := profileId] -type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool, Maybe CustomData) +type ContactRow' = (ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool, Maybe UIThemeEntityOverrides, Maybe CustomData) + +type ContactRow = Only ContactId :. ContactRow' toContact :: VersionRangeChat -> User -> ContactRow :. MaybeConnectionRow -> Contact -toContact vr user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, customData)) :. connRow) = +toContact vr user ((Only contactId :. (profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, uiThemes, customData)) :. connRow) = let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} activeConn = toMaybeConnection vr connRow chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} incognito = maybe False connIncognito activeConn mergedPreferences = contactUserPreferences user userPreferences preferences incognito - in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, customData} + in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, uiThemes, customData} getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile getProfileById db userId profileId = @@ -418,15 +421,15 @@ userQuery :: Query userQuery = [sql| SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.local_display_name, ucp.full_name, ucp.image, ucp.contact_link, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id |] -toUser :: (UserId, UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) :. (Bool, Bool, Bool, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime) -> User -toUser ((userId, auId, userContactId, profileId, activeUser, displayName, fullName, image, contactLink, userPreferences) :. (showNtfs, sendRcptsContacts, sendRcptsSmallGroups, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt)) = - User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences, showNtfs, sendRcptsContacts, sendRcptsSmallGroups, viewPwdHash, userMemberProfileUpdatedAt} +toUser :: (UserId, UserId, ContactId, ProfileId, Bool, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, Maybe Preferences) :. (Bool, Bool, Bool, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime, Maybe UIThemeEntityOverrides) -> User +toUser ((userId, auId, userContactId, profileId, activeUser, displayName, fullName, image, contactLink, userPreferences) :. (showNtfs, sendRcptsContacts, sendRcptsSmallGroups, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, uiThemes)) = + User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, fullPreferences, showNtfs, sendRcptsContacts, sendRcptsSmallGroups, viewPwdHash, userMemberProfileUpdatedAt, uiThemes} where profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences = userPreferences, localAlias = ""} fullPreferences = mergePreferences Nothing userPreferences diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index f7174a635b..0d07d5e3cb 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -45,6 +45,7 @@ import Database.SQLite.Simple.Ok import Database.SQLite.Simple.ToField (ToField (..)) import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared +import Simplex.Chat.Types.UITheme import Simplex.Chat.Types.Util import Simplex.FileTransfer.Description (FileDigest) import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, RcvFileId, SAEntity (..), SndFileId, UserId) @@ -117,7 +118,8 @@ data User = User showNtfs :: Bool, sendRcptsContacts :: Bool, sendRcptsSmallGroups :: Bool, - userMemberProfileUpdatedAt :: Maybe UTCTime + userMemberProfileUpdatedAt :: Maybe UTCTime, + uiThemes :: Maybe UIThemeEntityOverrides } deriving (Show) @@ -175,6 +177,7 @@ data Contact = Contact chatTs :: Maybe UTCTime, contactGroupMemberId :: Maybe GroupMemberId, contactGrpInvSent :: Bool, + uiThemes :: Maybe UIThemeEntityOverrides, customData :: Maybe CustomData } deriving (Eq, Show) @@ -372,6 +375,7 @@ data GroupInfo = GroupInfo updatedAt :: UTCTime, chatTs :: Maybe UTCTime, userMemberProfileSentAt :: Maybe UTCTime, + uiThemes :: Maybe UIThemeEntityOverrides, customData :: Maybe CustomData } deriving (Eq, Show) diff --git a/src/Simplex/Chat/Types/UITheme.hs b/src/Simplex/Chat/Types/UITheme.hs new file mode 100644 index 0000000000..9f9c106d1f --- /dev/null +++ b/src/Simplex/Chat/Types/UITheme.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Simplex.Chat.Types.UITheme where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +import Simplex.Chat.Types.Util +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fromTextField_) +import Simplex.Messaging.Util ((<$?>)) + +data UIThemes = UIThemes + { light :: Maybe UITheme, + dark :: Maybe UITheme, + simplex :: Maybe UITheme + } + deriving (Eq, Show) + +data UITheme = UITheme + { base :: ThemeColorScheme, + wallpaper :: Maybe ChatWallpaper, + colors :: UIColors + } + deriving (Eq, Show) + +data UIColorMode = UCMLight | UCMDark + deriving (Eq, Show) + +data UIThemeEntityOverrides = UIThemeEntityOverrides + { light :: Maybe UIThemeEntityOverride, + dark :: Maybe UIThemeEntityOverride + } + deriving (Eq, Show) + +data UIThemeEntityOverride = UIThemeEntityOverride + { mode :: UIColorMode, + wallpaper :: Maybe ChatWallpaper, + colors :: UIColors + } + deriving (Eq, Show) + +data ThemeColorScheme = TCSLight | TCSDark | TCSSimplex + deriving (Eq, Show) + +data UIColorScheme + = UCSSystem + | UCSLight + | UCSDark + | UCSSimplex + deriving (Show) + +data DarkColorScheme = DCSDark | DCSSimplex + deriving (Show) + +instance StrEncoding ThemeColorScheme where + strEncode = \case + TCSLight -> "LIGHT" + TCSDark -> "DARK" + TCSSimplex -> "SIMPLEX" + strDecode = \case + "LIGHT" -> Right TCSLight + "DARK" -> Right TCSDark + "SIMPLEX" -> Right TCSSimplex + _ -> Left "bad ColorScheme" + strP = strDecode <$?> A.takeTill (== ' ') + +instance FromJSON ThemeColorScheme where + parseJSON = strParseJSON "ThemeColorScheme" + +instance ToJSON ThemeColorScheme where + toJSON = strToJSON + toEncoding = strToJEncoding + +data ChatWallpaper = ChatWallpaper + { preset :: Maybe ChatWallpaperPreset, + imageFile :: Maybe FilePath, + background :: Maybe UIColor, + tint :: Maybe UIColor, + scaleType :: Maybe ChatWallpaperScale, + scale :: Maybe Double + } + deriving (Eq, Show) + +data ChatWallpaperScale = CWSFill | CWSFit | CWSRepeat + deriving (Eq, Show) + +data UIColors = UIColors + { accent :: Maybe UIColor, + accentVariant :: Maybe UIColor, + secondary :: Maybe UIColor, + secondaryVariant :: Maybe UIColor, + background :: Maybe UIColor, + menus :: Maybe UIColor, + title :: Maybe UIColor, + sentMessage :: Maybe UIColor, + receivedMessage :: Maybe UIColor + } + deriving (Eq, Show) + +defaultUIColors :: UIColors +defaultUIColors = UIColors Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data ChatWallpaperPreset + = CWPKids + | CWPCats + | CWPPets + | CWPFlowers + | CWPHearts + | CWPSocial + | CWPTravel + | CWPInternet + | CWPSpace + | CWPSchool + deriving (Eq, Show) + +newtype UIColor = UIColor String + deriving (Eq, Show) + +instance FromJSON UIColor where + parseJSON v = toColor =<< J.parseJSON v + where + toColor s@('#' : cs) + | length cs == 8 && all hexDigit cs = pure $ UIColor s + toColor _ = fail "bad UIColor" + hexDigit c = (c >= '0' && c <= '9') || (let c' = toLower c in c' >= 'a' && c' <= 'f') + +instance ToJSON UIColor where + toJSON (UIColor t) = J.toJSON t + toEncoding (UIColor t) = J.toEncoding t + +$(JQ.deriveJSON (enumJSON $ dropPrefix "DCS") ''DarkColorScheme) + +$(JQ.deriveJSON (enumJSON $ dropPrefix "UCM") ''UIColorMode) + +$(JQ.deriveJSON (enumJSON $ dropPrefix "UCS") ''UIColorScheme) + +$(JQ.deriveJSON (enumJSON $ dropPrefix "CWS") ''ChatWallpaperScale) + +$(JQ.deriveJSON (enumJSON $ dropPrefix "CWP") ''ChatWallpaperPreset) + +$(JQ.deriveJSON defaultJSON ''ChatWallpaper) + +$(JQ.deriveJSON defaultJSON ''UIColors) + +$(JQ.deriveJSON defaultJSON ''UIThemeEntityOverride) + +$(JQ.deriveJSON defaultJSON ''UIThemeEntityOverrides) + +$(JQ.deriveJSON defaultJSON ''UITheme) + +$(JQ.deriveJSON defaultJSON ''UIThemes) + +instance ToField UIThemeEntityOverrides where + toField = toField . encodeJSON + +instance FromField UIThemeEntityOverrides where + fromField = fromTextField_ $ Just . fromMaybe (UIThemeEntityOverrides Nothing Nothing) . decodeJSON diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index a10acc884a..96b742ffa4 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -50,6 +50,7 @@ import Simplex.Chat.Styled import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared +import Simplex.Chat.Types.UITheme import qualified Simplex.FileTransfer.Transport as XFTPTransport import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), SubscriptionsInfo (..)) import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..)) @@ -83,7 +84,7 @@ serializeChatResponse user_ ts tz remoteHost_ = unlines . map unStyle . response responseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString] responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz outputRH = \case - CRActiveUser User {profile} -> viewUserProfile $ fromLocalProfile profile + CRActiveUser User {profile, uiThemes} -> viewUserProfile (fromLocalProfile profile) <> viewUITheme uiThemes CRUsersList users -> viewUsersList users CRChatStarted -> ["chat started"] CRChatRunning -> ["chat is running"] @@ -1209,7 +1210,7 @@ viewNetworkConfig NetworkConfig {socksProxy, tcpTimeout} = ] viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString] -viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn, customData} stats incognitoProfile = +viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn, uiThemes, customData} stats incognitoProfile = ["contact ID: " <> sShow contactId] <> maybe [] viewConnectionStats stats <> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact l)]) contactLink @@ -1221,15 +1222,20 @@ viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, conta <> [viewConnectionVerified (contactSecurityCode ct)] <> ["quantum resistant end-to-end encryption" | contactPQEnabled ct == CR.PQEncOn] <> maybe [] (\ac -> [viewPeerChatVRange (peerChatVRange ac)]) activeConn + <> viewUITheme uiThemes <> viewCustomData customData viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString] -viewGroupInfo GroupInfo {groupId, customData} s = +viewGroupInfo GroupInfo {groupId, uiThemes, customData} s = [ "group ID: " <> sShow groupId, "current members: " <> sShow (currentMembers s) ] + <> viewUITheme uiThemes <> viewCustomData customData +viewUITheme :: Maybe UIThemeEntityOverrides -> [StyledString] +viewUITheme = maybe [] (\uiThemes -> ["UI themes: " <> plain (LB.toStrict $ J.encode uiThemes)]) + viewCustomData :: Maybe CustomData -> [StyledString] viewCustomData = maybe [] (\(CustomData v) -> ["custom data: " <> plain (LB.toStrict . J.encode $ J.Object v)]) diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 294540a62c..a8afa05af3 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PostfixOperators #-} @@ -15,6 +16,8 @@ import qualified Data.Text as T import Simplex.Chat.Store.Shared (createContact) import Simplex.Chat.Types (ConnStatus (..), Profile (..)) import Simplex.Chat.Types.Shared (GroupMemberRole (..)) +import Simplex.Chat.Types.UITheme +import Simplex.Chat.Types.Util (encodeJSON) import Simplex.Messaging.Encoding.String (StrEncoding (..)) import System.Directory (copyFile, createDirectoryIfMissing) import Test.Hspec hiding (it) @@ -73,6 +76,7 @@ chatProfileTests = do it "direct messages" testGroupPrefsDirectForRole it "files & media" testGroupPrefsFilesForRole it "SimpleX links" testGroupPrefsSimplexLinksForRole + it "set user, contact and group UI theme" testSetUITheme testUpdateProfile :: HasCallStack => FilePath -> IO () testUpdateProfile = @@ -1935,8 +1939,8 @@ testGroupPrefsDirectForRole = testChat4 aliceProfile bobProfile cathProfile danP dan <## "#team: you joined the group" dan <### [ "#team: member alice (Alice) is connected", - "#team: member bob (Bob) is connected" - ], + "#team: member bob (Bob) is connected" + ], do alice <## "#team: cath added dan (Daniel) to the group (connecting...)" alice <## "#team: new member dan is connected", @@ -1947,7 +1951,7 @@ testGroupPrefsDirectForRole = testChat4 aliceProfile bobProfile cathProfile danP -- dan cannot send direct messages to alice (owner) dan ##> "@alice hello alice" dan <## "bad chat command: direct messages not allowed" - (alice FilePath -> IO () +testSetUITheme = + testChat2 aliceProfile bobProfile $ \alice bob -> do + connectUsers alice bob + alice ##> "/g team" + alice <## "group #team is created" + alice <## "to add members use /a team or /create link #team" + alice #$> ("/_set theme user 1 " <> theme UCMDark, id, "ok") + alice #$> ("/_set theme @2 " <> theme UCMDark, id, "ok") + alice #$> ("/_set theme #1 " <> theme UCMDark, id, "ok") + alice ##> "/u" + userInfo alice "alice (Alice)" + alice <## ("UI themes: " <> theme UCMDark) + alice ##> "/create user alice2" + userInfo alice "alice2" + alice ##> "/u alice" + userInfo alice "alice (Alice)" + alice <## ("UI themes: " <> theme UCMDark) + alice ##> "/i @bob" + contactInfo alice + alice <## ("UI themes: " <> theme UCMDark) + alice ##> "/i #team" + groupInfo alice + alice <## ("UI themes: " <> theme UCMDark) + alice #$> ("/_set theme user 1", id, "ok") + alice #$> ("/_set theme @2", id, "ok") + alice #$> ("/_set theme #1", id, "ok") + alice ##> "/u" + userInfo alice "alice (Alice)" + alice ##> "/i @bob" + contactInfo alice + alice ##> "/i #team" + groupInfo alice + where + theme cm = T.unpack $ encodeJSON UIThemeEntityOverrides {light = Nothing, dark = Just $ UIThemeEntityOverride cm Nothing defaultUIColors} + userInfo a name = do + a <## ("user profile: " <> name) + a <## "use /p to change it" + a <## "(the updated profile will be sent to all your contacts)" + contactInfo a = do + a <## "contact ID: 2" + a <## "receiving messages via: localhost" + a <## "sending messages via: localhost" + a <## "you've shared main profile with this contact" + a <## "connection not verified, use /code command to see security code" + a <## "quantum resistant end-to-end encryption" + a <## "peer chat protocol version range: (Version 1, Version 8)" + groupInfo a = do + a <## "group ID: 1" + a <## "current members: 1"