mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
core: chat hooks allowing to extend or customize chat core (#3953)
* core: chat hooks allowing to extend or customize chat core * update * json * custom response * user in db queries
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
735359c279
commit
86fe28f1ed
17 changed files with 223 additions and 109 deletions
|
|
@ -1,61 +1,8 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.LocalTime (getCurrentTimeZone)
|
||||
import Server
|
||||
import Simplex.Chat.Controller (ChatController (..), ChatResponse (..), currentRemoteHost, versionNumber, versionString)
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Terminal
|
||||
import Simplex.Chat.View (serializeChatResponse)
|
||||
import Simplex.Messaging.Client (NetworkConfig (..))
|
||||
import System.Directory (getAppUserDataDirectory)
|
||||
import System.Terminal (withTerminal)
|
||||
import Server (simplexChatServer)
|
||||
import Simplex.Chat.Terminal (terminalChatConfig)
|
||||
import Simplex.Chat.Terminal.Main (simplexChatCLI)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
appDir <- getAppUserDataDirectory "simplex"
|
||||
opts@ChatOpts {chatCmd, chatServerPort} <- getChatOpts appDir "simplex_v1"
|
||||
if null chatCmd
|
||||
then case chatServerPort of
|
||||
Just chatPort -> simplexChatServer defaultChatServerConfig {chatPort} terminalChatConfig opts
|
||||
_ -> runCLI opts
|
||||
else simplexChatCore terminalChatConfig opts $ runCommand opts
|
||||
where
|
||||
runCLI opts = do
|
||||
welcome opts
|
||||
t <- withTerminal pure
|
||||
simplexChatTerminal terminalChatConfig opts t
|
||||
runCommand ChatOpts {chatCmd, chatCmdLog, chatCmdDelay} user cc = do
|
||||
when (chatCmdLog /= CCLNone) . void . forkIO . forever $ do
|
||||
(_, _, r') <- atomically . readTBQueue $ outputQ cc
|
||||
case r' of
|
||||
CRNewChatItem {} -> printResponse r'
|
||||
_ -> when (chatCmdLog == CCLAll) $ printResponse r'
|
||||
sendChatCmdStr cc chatCmd >>= printResponse
|
||||
threadDelay $ chatCmdDelay * 1000000
|
||||
where
|
||||
printResponse r = do
|
||||
ts <- getCurrentTime
|
||||
tz <- getCurrentTimeZone
|
||||
rh <- readTVarIO $ currentRemoteHost cc
|
||||
putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r
|
||||
|
||||
welcome :: ChatOpts -> IO ()
|
||||
welcome ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, networkConfig}} =
|
||||
mapM_
|
||||
putStrLn
|
||||
[ versionString versionNumber,
|
||||
"db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db",
|
||||
maybe
|
||||
"direct network connection - use `/network` command or `-x` CLI option to connect via SOCKS5 at :9050"
|
||||
(("using SOCKS5 proxy " <>) . show)
|
||||
(socksProxy networkConfig),
|
||||
"type \"/help\" or \"/h\" for usage info"
|
||||
]
|
||||
main = simplexChatCLI terminalChatConfig (Just simplexChatServer)
|
||||
|
|
|
|||
|
|
@ -28,9 +28,9 @@ import Simplex.Messaging.Util (raceAny_)
|
|||
import UnliftIO.Exception
|
||||
import UnliftIO.STM
|
||||
|
||||
simplexChatServer :: ChatServerConfig -> ChatConfig -> ChatOpts -> IO ()
|
||||
simplexChatServer srvCfg cfg opts =
|
||||
simplexChatCore cfg opts . const $ runChatServer srvCfg
|
||||
simplexChatServer :: ServiceName -> ChatConfig -> ChatOpts -> IO ()
|
||||
simplexChatServer chatPort cfg opts =
|
||||
simplexChatCore cfg opts . const $ runChatServer defaultChatServerConfig {chatPort}
|
||||
|
||||
data ChatServerConfig = ChatServerConfig
|
||||
{ chatPort :: ServiceName,
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ crDirectoryEvent = \case
|
|||
CRChatItemDeleted {deletedChatItem = AChatItem _ SMDRcv (DirectChat ct) _, byUser = False} -> Just $ DEItemDeleteIgnored ct
|
||||
CRNewChatItem {chatItem = AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc, meta = CIMeta {itemLive}}} ->
|
||||
Just $ case (mc, itemLive) of
|
||||
(MCText t, Nothing) -> DEContactCommand ct ciId $ fromRight err $ A.parseOnly directoryCmdP $ T.dropWhileEnd isSpace t
|
||||
(MCText t, Nothing) -> DEContactCommand ct ciId $ fromRight err $ A.parseOnly (directoryCmdP <* A.endOfInput) $ T.dropWhileEnd isSpace t
|
||||
_ -> DEUnsupportedMessage ct ciId
|
||||
where
|
||||
ciId = chatItemId' ci
|
||||
|
|
|
|||
|
|
@ -139,6 +139,7 @@ library
|
|||
Simplex.Chat.Migrations.M20240226_users_restrict
|
||||
Simplex.Chat.Migrations.M20240228_pq
|
||||
Simplex.Chat.Migrations.M20240313_drop_agent_ack_cmd_id
|
||||
Simplex.Chat.Migrations.M20240324_custom_data
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Mobile.File
|
||||
Simplex.Chat.Mobile.Shared
|
||||
|
|
@ -168,6 +169,7 @@ library
|
|||
Simplex.Chat.Styled
|
||||
Simplex.Chat.Terminal
|
||||
Simplex.Chat.Terminal.Input
|
||||
Simplex.Chat.Terminal.Main
|
||||
Simplex.Chat.Terminal.Notification
|
||||
Simplex.Chat.Terminal.Output
|
||||
Simplex.Chat.Types
|
||||
|
|
|
|||
|
|
@ -161,7 +161,8 @@ defaultChatConfig =
|
|||
ciExpirationInterval = 30 * 60 * 1000000, -- 30 minutes
|
||||
coreApi = False,
|
||||
highlyAvailable = False,
|
||||
deviceNameForRemote = ""
|
||||
deviceNameForRemote = "",
|
||||
chatHooks = defaultChatHooks
|
||||
}
|
||||
|
||||
_defaultSMPServers :: NonEmpty SMPServerWithAuth
|
||||
|
|
@ -424,7 +425,9 @@ execChatCommand rh s = do
|
|||
Just rhId
|
||||
| allowRemoteCommand cmd -> execRemoteCommand u rhId cmd s
|
||||
| otherwise -> pure $ CRChatCmdError u $ ChatErrorRemoteHost (RHId rhId) $ RHELocalCommand
|
||||
_ -> execChatCommand_ u cmd
|
||||
_ -> do
|
||||
cc@ChatController {config = ChatConfig {chatHooks}} <- ask
|
||||
liftIO (preCmdHook chatHooks cc cmd) >>= either pure (execChatCommand_ u)
|
||||
|
||||
execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse
|
||||
execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)
|
||||
|
|
@ -2094,6 +2097,9 @@ processChatCommand' vr = \case
|
|||
SubInfo {server, subError = Just e} -> M.alter (Just . maybe [e] (e :)) server m
|
||||
_ -> m
|
||||
GetAgentSubsDetails -> CRAgentSubsDetails <$> withAgent getAgentSubscriptions
|
||||
-- CustomChatCommand is unsupported, it can be processed in preCmdHook
|
||||
-- in a modified CLI app or core - the hook should return Either ChatResponse ChatCommand
|
||||
CustomChatCommand _cmd -> withUser $ \user -> pure $ chatCmdError (Just user) "not supported"
|
||||
where
|
||||
withChatLock name action = asks chatLock >>= \l -> withLock l name action
|
||||
-- below code would make command responses asynchronous where they can be slow
|
||||
|
|
@ -4553,25 +4559,28 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
|||
when (sz > fileSize) $ receiveFile' user ft Nothing Nothing >>= toView
|
||||
|
||||
messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> m ()
|
||||
messageFileDescription Contact {contactId} sharedMsgId fileDescr = do
|
||||
messageFileDescription ct@Contact {contactId} sharedMsgId fileDescr = do
|
||||
fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId
|
||||
processFDMessage fileId fileDescr
|
||||
processFDMessage (CDDirectRcv ct) sharedMsgId fileId fileDescr
|
||||
|
||||
groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> m ()
|
||||
groupMessageFileDescription GroupInfo {groupId} _m sharedMsgId fileDescr = do
|
||||
groupMessageFileDescription g@GroupInfo {groupId} m sharedMsgId fileDescr = do
|
||||
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
||||
processFDMessage fileId fileDescr
|
||||
processFDMessage (CDGroupRcv g m) sharedMsgId fileId fileDescr
|
||||
|
||||
processFDMessage :: FileTransferId -> FileDescr -> m ()
|
||||
processFDMessage fileId fileDescr = do
|
||||
processFDMessage :: ChatTypeQuotable c => ChatDirection c 'MDRcv -> SharedMsgId -> FileTransferId -> FileDescr -> m ()
|
||||
processFDMessage cd sharedMsgId fileId fileDescr = do
|
||||
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
|
||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||
(rfd, RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs}) <- withStore $ \db -> do
|
||||
(rfd@RcvFileDescr {fileDescrComplete}, ft'@RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs}) <- withStore $ \db -> do
|
||||
rfd <- appendRcvFD db userId fileId fileDescr
|
||||
-- reading second time in the same transaction as appending description
|
||||
-- to prevent race condition with accept
|
||||
ft' <- getRcvFileTransfer db user fileId
|
||||
pure (rfd, ft')
|
||||
when fileDescrComplete $ do
|
||||
ci <- withStore $ \db -> getAChatItemBySharedMsgId db user cd sharedMsgId
|
||||
toView $ CRRcvFileDescrReady user ci ft' rfd
|
||||
case (fileStatus, xftpRcvFile) of
|
||||
(RFSAccepted _, Just XFTPRcvFile {}) -> receiveViaCompleteFD user fileId rfd cryptoArgs
|
||||
_ -> pure ()
|
||||
|
|
@ -7040,7 +7049,8 @@ chatCommandP =
|
|||
"/get subs" $> GetAgentSubs,
|
||||
"/get subs details" $> GetAgentSubsDetails,
|
||||
"/get workers" $> GetAgentWorkers,
|
||||
"/get workers details" $> GetAgentWorkersDetails
|
||||
"/get workers details" $> GetAgentWorkersDetails,
|
||||
"//" *> (CustomChatCommand <$> A.takeByteString)
|
||||
]
|
||||
where
|
||||
choice = A.choice . map (\p -> p <* A.takeWhile (== ' ') <* A.endOfInput)
|
||||
|
|
|
|||
|
|
@ -144,9 +144,28 @@ data ChatConfig = ChatConfig
|
|||
ciExpirationInterval :: Int64, -- microseconds
|
||||
coreApi :: Bool,
|
||||
highlyAvailable :: Bool,
|
||||
deviceNameForRemote :: Text
|
||||
deviceNameForRemote :: Text,
|
||||
chatHooks :: ChatHooks
|
||||
}
|
||||
|
||||
-- The hooks can be used to extend or customize chat core in mobile or CLI clients.
|
||||
data ChatHooks = ChatHooks
|
||||
{ -- preCmdHook can be used to process or modify the commands before they are processed.
|
||||
-- This hook should be used to process CustomChatCommand.
|
||||
-- if this hook returns ChatResponse, the command processing will be skipped.
|
||||
preCmdHook :: ChatController -> ChatCommand -> IO (Either ChatResponse ChatCommand),
|
||||
-- eventHook can be used to additionally process or modify events,
|
||||
-- it is called before the event is sent to the user (or to the UI).
|
||||
eventHook :: ChatController -> ChatResponse -> IO ChatResponse
|
||||
}
|
||||
|
||||
defaultChatHooks :: ChatHooks
|
||||
defaultChatHooks =
|
||||
ChatHooks
|
||||
{ preCmdHook = \_ -> pure . Right,
|
||||
eventHook = \_ -> pure
|
||||
}
|
||||
|
||||
data DefaultAgentServers = DefaultAgentServers
|
||||
{ smp :: NonEmpty SMPServerWithAuth,
|
||||
ntf :: [NtfServer],
|
||||
|
|
@ -471,6 +490,9 @@ data ChatCommand
|
|||
| GetAgentSubsDetails
|
||||
| GetAgentWorkers
|
||||
| GetAgentWorkersDetails
|
||||
-- The parser will return this command for strings that start from "//".
|
||||
-- This command should be processed in preCmdHook
|
||||
| CustomChatCommand ByteString
|
||||
deriving (Show)
|
||||
|
||||
allowRemoteCommand :: ChatCommand -> Bool -- XXX: consider using Relay/Block/ForceLocal
|
||||
|
|
@ -597,10 +619,9 @@ data ChatResponse
|
|||
| CRContactRequestAlreadyAccepted {user :: User, contact :: Contact}
|
||||
| CRLeftMemberUser {user :: User, groupInfo :: GroupInfo}
|
||||
| CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo}
|
||||
| CRRcvFileDescrReady {user :: User, chatItem :: AChatItem}
|
||||
| CRRcvFileDescrReady {user :: User, chatItem :: AChatItem, rcvFileTransfer :: RcvFileTransfer, rcvFileDescr :: RcvFileDescr}
|
||||
| CRRcvFileAccepted {user :: User, chatItem :: AChatItem}
|
||||
| CRRcvFileAcceptedSndCancelled {user :: User, rcvFileTransfer :: RcvFileTransfer}
|
||||
| CRRcvFileDescrNotReady {user :: User, chatItem :: AChatItem}
|
||||
| CRStandaloneFileInfo {fileMeta :: Maybe J.Value}
|
||||
| CRRcvStandaloneFileCreated {user :: User, rcvFileTransfer :: RcvFileTransfer} -- returned by _download
|
||||
| CRRcvFileStart {user :: User, chatItem :: AChatItem} -- sent by chats
|
||||
|
|
@ -726,6 +747,7 @@ data ChatResponse
|
|||
| CRArchiveImported {archiveErrors :: [ArchiveError]}
|
||||
| CRAppSettings {appSettings :: AppSettings}
|
||||
| CRTimedAction {action :: String, durationMilliseconds :: Int64}
|
||||
| CRCustomChatResponse {user_ :: Maybe User, response :: Text}
|
||||
deriving (Show)
|
||||
|
||||
-- some of these can only be used as command responses
|
||||
|
|
@ -1278,9 +1300,9 @@ throwChatError = throwError . ChatError
|
|||
|
||||
-- | Emit local events.
|
||||
toView :: ChatMonad' m => ChatResponse -> m ()
|
||||
toView event = do
|
||||
localQ <- asks outputQ
|
||||
session <- asks remoteCtrlSession
|
||||
toView ev = do
|
||||
cc@ChatController {outputQ = localQ, remoteCtrlSession = session, config = ChatConfig {chatHooks}} <- ask
|
||||
event <- liftIO $ eventHook chatHooks cc ev
|
||||
atomically $
|
||||
readTVar session >>= \case
|
||||
Just (_, RCSessionConnected {remoteOutputQ})
|
||||
|
|
|
|||
20
src/Simplex/Chat/Migrations/M20240324_custom_data.hs
Normal file
20
src/Simplex/Chat/Migrations/M20240324_custom_data.hs
Normal file
|
|
@ -0,0 +1,20 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20240324_custom_data where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20240324_custom_data :: Query
|
||||
m20240324_custom_data =
|
||||
[sql|
|
||||
ALTER TABLE contacts ADD COLUMN custom_data BLOB;
|
||||
ALTER TABLE groups ADD COLUMN custom_data BLOB;
|
||||
|]
|
||||
|
||||
down_m20240324_custom_data :: Query
|
||||
down_m20240324_custom_data =
|
||||
[sql|
|
||||
ALTER TABLE contacts DROP COLUMN custom_data;
|
||||
ALTER TABLE groups DROP COLUMN custom_data;
|
||||
|]
|
||||
|
|
@ -73,6 +73,7 @@ CREATE TABLE contacts(
|
|||
REFERENCES group_members(group_member_id) ON DELETE SET NULL,
|
||||
contact_grp_inv_sent INTEGER NOT NULL DEFAULT 0,
|
||||
contact_status TEXT NOT NULL DEFAULT 'active',
|
||||
custom_data BLOB,
|
||||
FOREIGN KEY(user_id, local_display_name)
|
||||
REFERENCES display_names(user_id, local_display_name)
|
||||
ON DELETE CASCADE
|
||||
|
|
@ -120,7 +121,8 @@ CREATE TABLE groups(
|
|||
favorite INTEGER NOT NULL DEFAULT 0,
|
||||
send_rcpts INTEGER,
|
||||
via_group_link_uri_hash BLOB,
|
||||
user_member_profile_sent_at TEXT, -- received
|
||||
user_member_profile_sent_at TEXT,
|
||||
custom_data BLOB, -- received
|
||||
FOREIGN KEY(user_id, local_display_name)
|
||||
REFERENCES display_names(user_id, local_display_name)
|
||||
ON DELETE CASCADE
|
||||
|
|
|
|||
|
|
@ -75,19 +75,19 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
|
|||
[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
|
||||
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
|
||||
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)] -> 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)] =
|
||||
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)] =
|
||||
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}
|
||||
in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, customData}
|
||||
toContact' _ _ _ = Left $ SEInternalError "referenced contact not found"
|
||||
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
getGroupAndMember_ groupMemberId c = ExceptT $ do
|
||||
|
|
@ -99,7 +99,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.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, 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,
|
||||
|
|
|
|||
|
|
@ -68,6 +68,7 @@ module Simplex.Chat.Store.Direct
|
|||
updateContactSettings,
|
||||
setConnConnReqInv,
|
||||
resetContactConnInitiated,
|
||||
setContactCustomData,
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -175,7 +176,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,
|
||||
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,
|
||||
-- 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,
|
||||
|
|
@ -221,7 +222,7 @@ 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}
|
||||
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}
|
||||
|
||||
deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO ()
|
||||
deleteContactConnectionsAndFiles db userId Contact {contactId} = do
|
||||
|
|
@ -578,7 +579,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,
|
||||
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,
|
||||
-- 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,
|
||||
|
|
@ -724,7 +725,7 @@ 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}
|
||||
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}
|
||||
|
||||
getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64
|
||||
getContactIdByName db User {userId} cName =
|
||||
|
|
@ -743,7 +744,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,
|
||||
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,
|
||||
-- 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,
|
||||
|
|
@ -883,3 +884,8 @@ resetContactConnInitiated db User {userId} Connection {connId} = do
|
|||
WHERE user_id = ? AND connection_id = ?
|
||||
|]
|
||||
(updatedAt, userId, connId)
|
||||
|
||||
setContactCustomData :: DB.Connection -> User -> Contact -> Maybe CustomData -> IO ()
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -116,6 +116,7 @@ module Simplex.Chat.Store.Groups
|
|||
createNewUnknownGroupMember,
|
||||
updateUnknownMemberAnnounced,
|
||||
updateUserMemberProfileSentAt,
|
||||
setGroupCustomData,
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -148,19 +149,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) :. 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 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 :: (PQSupport -> VersionRangeChat) -> Int64 -> GroupInfoRow -> GroupInfo
|
||||
toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. userMemberRow) =
|
||||
toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt, customData) :. userMemberRow) =
|
||||
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr PQSupportOff}
|
||||
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}
|
||||
in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, 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)) =
|
||||
|
|
@ -271,7 +272,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.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, 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,
|
||||
|
|
@ -344,7 +345,8 @@ createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = Exc
|
|||
createdAt = currentTs,
|
||||
updatedAt = currentTs,
|
||||
chatTs = Just currentTs,
|
||||
userMemberProfileSentAt = Just currentTs
|
||||
userMemberProfileSentAt = Just currentTs,
|
||||
customData = Nothing
|
||||
}
|
||||
|
||||
-- | creates a new group record for the group the current user was invited to, or returns an existing one
|
||||
|
|
@ -409,7 +411,8 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ
|
|||
createdAt = currentTs,
|
||||
updatedAt = currentTs,
|
||||
chatTs = Just currentTs,
|
||||
userMemberProfileSentAt = Just currentTs
|
||||
userMemberProfileSentAt = Just currentTs,
|
||||
customData = Nothing
|
||||
},
|
||||
groupMemberId
|
||||
)
|
||||
|
|
@ -628,7 +631,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.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, 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
|
||||
|
|
@ -1293,7 +1296,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.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, 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,
|
||||
|
|
@ -1389,7 +1392,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.created_at, g.updated_at, g.chat_ts, g.user_member_profile_sent_at, 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,
|
||||
|
|
@ -1951,7 +1954,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}
|
||||
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}
|
||||
|
||||
getMemberContact :: DB.Connection -> (PQSupport -> VersionRangeChat) -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
|
||||
getMemberContact db vr user contactId = do
|
||||
|
|
@ -1988,7 +1991,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}
|
||||
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}
|
||||
m' = m {memberContactId = Just contactId}
|
||||
pure (mCt', m')
|
||||
where
|
||||
|
|
@ -2188,3 +2191,8 @@ updateUserMemberProfileSentAt db User {userId} GroupInfo {groupId} sentTs =
|
|||
db
|
||||
"UPDATE groups SET user_member_profile_sent_at = ? WHERE user_id = ? AND group_id = ?"
|
||||
(sentTs, userId, groupId)
|
||||
|
||||
setGroupCustomData :: DB.Connection -> User -> GroupInfo -> Maybe CustomData -> IO ()
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@ module Simplex.Chat.Store.Messages
|
|||
getDirectChatItemLast,
|
||||
getAllChatItems,
|
||||
getAChatItem,
|
||||
getAChatItemBySharedMsgId,
|
||||
updateDirectChatItem,
|
||||
updateDirectChatItem',
|
||||
addInitialAndNewCIVersions,
|
||||
|
|
@ -2202,6 +2203,15 @@ getAChatItem db vr user chatRef itemId = case chatRef of
|
|||
pure $ AChatItem SCTLocal msgDir (LocalChat nf) ci
|
||||
_ -> throwError $ SEChatItemNotFound itemId
|
||||
|
||||
getAChatItemBySharedMsgId :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> SharedMsgId -> ExceptT StoreError IO AChatItem
|
||||
getAChatItemBySharedMsgId db user cd sharedMsgId = case cd of
|
||||
CDDirectRcv ct@Contact {contactId} -> do
|
||||
(CChatItem msgDir ci) <- getDirectChatItemBySharedMsgId db user contactId sharedMsgId
|
||||
pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci
|
||||
CDGroupRcv g@GroupInfo {groupId} GroupMember {groupMemberId} -> do
|
||||
(CChatItem msgDir ci) <- getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
|
||||
pure $ AChatItem SCTGroup msgDir (GroupChat g) ci
|
||||
|
||||
getChatItemVersions :: DB.Connection -> ChatItemId -> IO [ChatItemVersion]
|
||||
getChatItemVersions db itemId = do
|
||||
map toChatItemVersion
|
||||
|
|
|
|||
|
|
@ -103,6 +103,7 @@ import Simplex.Chat.Migrations.M20240222_app_settings
|
|||
import Simplex.Chat.Migrations.M20240226_users_restrict
|
||||
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.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
|
|
@ -205,7 +206,8 @@ schemaMigrations =
|
|||
("20240222_app_settings", m20240222_app_settings, Just down_m20240222_app_settings),
|
||||
("20240226_users_restrict", m20240226_users_restrict, Just down_m20240226_users_restrict),
|
||||
("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)
|
||||
("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)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
|
|
|||
|
|
@ -371,16 +371,16 @@ 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)
|
||||
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)
|
||||
|
||||
toContact :: (PQSupport -> 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)) :. connRow) =
|
||||
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) =
|
||||
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}
|
||||
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, customData}
|
||||
|
||||
getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile
|
||||
getProfileById db userId profileId =
|
||||
|
|
|
|||
64
src/Simplex/Chat/Terminal/Main.hs
Normal file
64
src/Simplex/Chat/Terminal/Main.hs
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module Simplex.Chat.Terminal.Main where
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.LocalTime (getCurrentTimeZone)
|
||||
import Network.Socket
|
||||
import Simplex.Chat.Controller (ChatConfig, ChatController (..), ChatResponse (..), currentRemoteHost, versionNumber, versionString)
|
||||
import Simplex.Chat.Core
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Terminal
|
||||
import Simplex.Chat.View (serializeChatResponse)
|
||||
import Simplex.Messaging.Client (NetworkConfig (..))
|
||||
import System.Directory (getAppUserDataDirectory)
|
||||
import System.Exit (exitFailure)
|
||||
import System.Terminal (withTerminal)
|
||||
|
||||
simplexChatCLI :: ChatConfig -> Maybe (ServiceName -> ChatConfig -> ChatOpts -> IO ()) -> IO ()
|
||||
simplexChatCLI cfg server_ = do
|
||||
appDir <- getAppUserDataDirectory "simplex"
|
||||
opts@ChatOpts {chatCmd, chatServerPort} <- getChatOpts appDir "simplex_v1"
|
||||
if null chatCmd
|
||||
then case chatServerPort of
|
||||
Just chatPort -> case server_ of
|
||||
Just server -> server chatPort cfg opts
|
||||
Nothing -> putStrLn "Not allowed to run as a WebSockets server" >> exitFailure
|
||||
_ -> runCLI opts
|
||||
else simplexChatCore cfg opts $ runCommand opts
|
||||
where
|
||||
runCLI opts = do
|
||||
welcome opts
|
||||
t <- withTerminal pure
|
||||
simplexChatTerminal cfg opts t
|
||||
runCommand ChatOpts {chatCmd, chatCmdLog, chatCmdDelay} user cc = do
|
||||
when (chatCmdLog /= CCLNone) . void . forkIO . forever $ do
|
||||
(_, _, r') <- atomically . readTBQueue $ outputQ cc
|
||||
case r' of
|
||||
CRNewChatItem {} -> printResponse r'
|
||||
_ -> when (chatCmdLog == CCLAll) $ printResponse r'
|
||||
sendChatCmdStr cc chatCmd >>= printResponse
|
||||
threadDelay $ chatCmdDelay * 1000000
|
||||
where
|
||||
printResponse r = do
|
||||
ts <- getCurrentTime
|
||||
tz <- getCurrentTimeZone
|
||||
rh <- readTVarIO $ currentRemoteHost cc
|
||||
putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r
|
||||
|
||||
welcome :: ChatOpts -> IO ()
|
||||
welcome ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, networkConfig}} =
|
||||
mapM_
|
||||
putStrLn
|
||||
[ versionString versionNumber,
|
||||
"db: " <> dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db",
|
||||
maybe
|
||||
"direct network connection - use `/network` command or `-x` CLI option to connect via SOCKS5 at :9050"
|
||||
(("using SOCKS5 proxy " <>) . show)
|
||||
(socksProxy networkConfig),
|
||||
"type \"/help\" or \"/h\" for usage info"
|
||||
]
|
||||
|
|
@ -174,10 +174,25 @@ data Contact = Contact
|
|||
updatedAt :: UTCTime,
|
||||
chatTs :: Maybe UTCTime,
|
||||
contactGroupMemberId :: Maybe GroupMemberId,
|
||||
contactGrpInvSent :: Bool
|
||||
contactGrpInvSent :: Bool,
|
||||
customData :: Maybe CustomData
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
newtype CustomData = CustomData J.Object
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance ToJSON CustomData where
|
||||
toJSON (CustomData v) = toJSON v
|
||||
toEncoding (CustomData v) = toEncoding v
|
||||
|
||||
instance FromJSON CustomData where
|
||||
parseJSON = J.withObject "CustomData" (pure . CustomData)
|
||||
|
||||
instance ToField CustomData where toField (CustomData v) = toField $ J.encode v
|
||||
|
||||
instance FromField CustomData where fromField = fromBlobField_ J.eitherDecodeStrict
|
||||
|
||||
contactConn :: Contact -> Maybe Connection
|
||||
contactConn Contact {activeConn} = activeConn
|
||||
|
||||
|
|
@ -356,7 +371,8 @@ data GroupInfo = GroupInfo
|
|||
createdAt :: UTCTime,
|
||||
updatedAt :: UTCTime,
|
||||
chatTs :: Maybe UTCTime,
|
||||
userMemberProfileSentAt :: Maybe UTCTime
|
||||
userMemberProfileSentAt :: Maybe UTCTime,
|
||||
customData :: Maybe CustomData
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
|
|
|||
|
|
@ -183,8 +183,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
|||
CRUnknownMemberBlocked u g byM um -> ttyUser u [ttyGroup' g <> ": " <> ttyMember byM <> " blocked an unknown member, creating unknown member record " <> ttyMember um]
|
||||
CRUnknownMemberAnnounced u g _ um m -> ttyUser u [ttyGroup' g <> ": unknown member " <> ttyMember um <> " updated to " <> ttyMember m]
|
||||
CRGroupDeletedUser u g -> ttyUser u [ttyGroup' g <> ": you deleted the group"]
|
||||
CRRcvFileDescrReady _ _ -> []
|
||||
CRRcvFileDescrNotReady _ _ -> []
|
||||
CRRcvFileDescrReady _ _ _ _ -> []
|
||||
CRRcvFileProgressXFTP {} -> []
|
||||
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
|
||||
CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
|
||||
|
|
@ -391,6 +390,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
|||
CRArchiveImported archiveErrs -> if null archiveErrs then ["ok"] else ["archive import errors: " <> plain (show archiveErrs)]
|
||||
CRAppSettings as -> ["app settings: " <> plain (LB.unpack $ J.encode as)]
|
||||
CRTimedAction _ _ -> []
|
||||
CRCustomChatResponse u r -> ttyUser' u $ [plain r]
|
||||
where
|
||||
ttyUser :: User -> [StyledString] -> [StyledString]
|
||||
ttyUser user@User {showNtfs, activeUser} ss
|
||||
|
|
@ -1167,7 +1167,7 @@ viewNetworkConfig NetworkConfig {socksProxy, tcpTimeout} =
|
|||
]
|
||||
|
||||
viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString]
|
||||
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn} stats incognitoProfile =
|
||||
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn, customData} stats incognitoProfile =
|
||||
["contact ID: " <> sShow contactId]
|
||||
<> maybe [] viewConnectionStats stats
|
||||
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact l)]) contactLink
|
||||
|
|
@ -1179,12 +1179,17 @@ 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
|
||||
<> viewCustomData customData
|
||||
|
||||
viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString]
|
||||
viewGroupInfo GroupInfo {groupId} s =
|
||||
viewGroupInfo GroupInfo {groupId, customData} s =
|
||||
[ "group ID: " <> sShow groupId,
|
||||
"current members: " <> sShow (currentMembers s)
|
||||
]
|
||||
<> viewCustomData customData
|
||||
|
||||
viewCustomData :: Maybe CustomData -> [StyledString]
|
||||
viewCustomData = maybe [] (\(CustomData v) -> ["custom data: " <> plain (LB.toStrict . J.encode $ J.Object v)])
|
||||
|
||||
viewGroupMemberInfo :: GroupInfo -> GroupMember -> Maybe ConnectionStats -> [StyledString]
|
||||
viewGroupMemberInfo GroupInfo {groupId} m@GroupMember {groupMemberId, memberProfile = LocalProfile {localAlias, contactLink}, activeConn} stats =
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue