core: keep chat item edit history (#2410)

This commit is contained in:
spaced4ndy 2023-05-08 20:07:51 +04:00 committed by GitHub
parent 27762492d7
commit c87f4e68f7
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
14 changed files with 415 additions and 30 deletions

View File

@ -4,6 +4,7 @@ module Main where
import Control.Concurrent (threadDelay)
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Server
import Simplex.Chat.Controller (versionNumber, versionString)
import Simplex.Chat.Core
@ -29,7 +30,8 @@ main = do
else simplexChatCore terminalChatConfig opts Nothing $ \user cc -> do
r <- sendChatCmd cc chatCmd
ts <- getCurrentTime
putStrLn $ serializeChatResponse (Just user) ts r
tz <- getCurrentTimeZone
putStrLn $ serializeChatResponse (Just user) ts tz r
threadDelay $ chatCmdDelay opts * 1000000
welcome :: ChatOpts -> IO ()

View File

@ -94,6 +94,7 @@ library
Simplex.Chat.Migrations.M20230420_rcv_files_to_receive
Simplex.Chat.Migrations.M20230422_profile_contact_links
Simplex.Chat.Migrations.M20230504_recreate_msg_delivery_events_cleanup_messages
Simplex.Chat.Migrations.M20230505_chat_item_versions
Simplex.Chat.Mobile
Simplex.Chat.Mobile.WebRTC
Simplex.Chat.Options

View File

@ -457,6 +457,14 @@ processChatCommand = \case
APIGetChatItems pagination search -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user pagination search
pure $ CRChatItems user chatItems
APIGetChatItemInfo itemId -> withUser $ \user -> do
(chatItem@(AChatItem _ _ _ ChatItem {meta}), itemVersions) <- withStore $ \db -> do
ci <- getAChatItem db user itemId
versions <- liftIO $ getChatItemVersions db itemId
pure (ci, versions)
let CIMeta {itemTs, createdAt, updatedAt} = meta
ciInfo = ChatItemInfo {chatItemId = itemId, itemTs, createdAt, updatedAt, itemVersions}
pure $ CRChatItemInfo user chatItem ciInfo
APISendMessage (ChatRef cType chatId) live (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of
CTDirect -> do
ct@Contact {contactId, localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
@ -637,9 +645,12 @@ processChatCommand = \case
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive}, content = ciContent} -> do
case (ciContent, itemSharedMsgId) of
(CISndMsgContent _, Just itemSharedMId) -> do
(CISndMsgContent oldMC, Just itemSharedMId) -> do
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
ci' <- withStore' $ \db -> updateDirectChatItem' db user contactId ci (CISndMsgContent mc) live $ Just msgId
ci' <- withStore' $ \db -> do
currentTs <- liftIO getCurrentTime
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
updateDirectChatItem' db user contactId ci (CISndMsgContent mc) live $ Just msgId
startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci'
setActive $ ActiveC c
pure $ CRChatItemUpdated user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci')
@ -652,9 +663,12 @@ processChatCommand = \case
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive}, content = ciContent} -> do
case (ciContent, itemSharedMsgId) of
(CISndMsgContent _, Just itemSharedMId) -> do
(CISndMsgContent oldMC, Just itemSharedMId) -> do
SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
ci' <- withStore' $ \db -> updateGroupChatItem db user groupId ci (CISndMsgContent mc) live $ Just msgId
ci' <- withStore' $ \db -> do
currentTs <- liftIO getCurrentTime
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
updateGroupChatItem db user groupId ci (CISndMsgContent mc) live $ Just msgId
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
setActive $ ActiveG gName
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
@ -1402,6 +1416,10 @@ processChatCommand = \case
ShowChatItem Nothing -> withUser $ \user -> do
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast 1) Nothing
pure $ CRChatItems user chatItems
ShowChatItemInfo chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName
itemId <- getChatItemIdByText user chatRef msg
processChatCommand $ APIGetChatItemInfo itemId
ShowLiveItems on -> withUser $ \_ ->
asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_
SendFile chatName f -> withUser $ \user -> do
@ -1582,6 +1600,11 @@ processChatCommand = \case
CTDirect -> withStore $ \db -> getDirectChatItemIdByText db userId cId SMDSnd msg
CTGroup -> withStore $ \db -> getGroupChatItemIdByText db user cId (Just localDisplayName) msg
_ -> throwChatError $ CECommandError "not supported"
getChatItemIdByText :: User -> ChatRef -> Text -> m Int64
getChatItemIdByText user (ChatRef cType cId) msg = case cType of
CTDirect -> withStore $ \db -> getDirectChatItemIdByText' db user cId msg
CTGroup -> withStore $ \db -> getGroupChatItemIdByText' db user cId msg
_ -> throwChatError $ CECommandError "not supported"
connectViaContact :: User -> ConnectionRequestUri 'CMContact -> m ChatResponse
connectViaContact user@User {userId} cReq@(CRContactUri ConnReqUriData {crClientData}) = withChatLock "connectViaContact" $ do
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
@ -3283,21 +3306,26 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvContactCITimed ct ttl
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta content Nothing timed_ live
ci' <- withStore' $ \db -> updateDirectChatItem' db user contactId ci content live Nothing
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
updateDirectChatItem' db user contactId ci content live Nothing
toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci')
setActive $ ActiveC c
_ -> throwError e
where
MsgMeta {broker = (_, brokerTs)} = msgMeta
content = CIRcvMsgContent mc
live = fromMaybe False live_
updateRcvChatItem = do
CChatItem msgDir ci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
case msgDir of
SMDRcv -> do
ci' <- withStore' $ \db -> updateDirectChatItem' db user contactId ci content live $ Just msgId
cci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
case cci of
CChatItem SMDRcv ci@ChatItem {content = CIRcvMsgContent oldMC} -> do
ci' <- withStore' $ \db -> do
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
updateDirectChatItem' db user contactId ci content live $ Just msgId
toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci')
startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci'
SMDSnd -> messageError "x.msg.update: contact attempted invalid message update"
_ -> messageError "x.msg.update: contact attempted invalid message update"
messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> m ()
messageDelete ct@Contact {contactId} sharedMsgId RcvMessage {msgId} msgMeta = do
@ -3347,25 +3375,30 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvGroupCITimed gInfo ttl_
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live
ci' <- withStore' $ \db -> updateGroupChatItem db user groupId ci content live Nothing
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
updateGroupChatItem db user groupId ci content live Nothing
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
setActive $ ActiveG g
_ -> throwError e
where
MsgMeta {broker = (_, brokerTs)} = msgMeta
content = CIRcvMsgContent mc
live = fromMaybe False live_
updateRcvChatItem = do
CChatItem msgDir ci@ChatItem {chatDir} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
case (msgDir, chatDir) of
(SMDRcv, CIGroupRcv m') ->
cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
case cci of
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', content = CIRcvMsgContent oldMC} -> do
if sameMemberId memberId m'
then do
ci' <- withStore' $ \db -> updateGroupChatItem db user groupId ci content live $ Just msgId
ci' <- withStore' $ \db -> do
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
updateGroupChatItem db user groupId ci content live $ Just msgId
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
setActive $ ActiveG g
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
else messageError "x.msg.update: group member attempted to update a message of another member" -- shouldn't happen now that query includes group member id
(SMDSnd, _) -> messageError "x.msg.update: group member attempted invalid message update"
_ -> messageError "x.msg.update: group member attempted invalid message update"
groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> m ()
groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} = do
@ -4594,6 +4627,7 @@ chatCommandP =
"/_get chats " *> (APIGetChats <$> A.decimal <*> (" pcc=on" $> True <|> " pcc=off" $> False <|> pure False)),
"/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)),
"/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)),
"/_get item info " *> (APIGetChatItemInfo <$> A.decimal),
"/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))),
"/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP),
"/_delete item " *> (APIDeleteChatItem <$> chatRefP <* A.space <*> A.decimal <* A.space <*> ciDeleteMode),
@ -4723,6 +4757,7 @@ chatCommandP =
"/last_item_id" *> (LastChatItemId <$> optional (A.space *> chatNameP) <*> (A.space *> A.decimal <|> pure 0)),
"/show" *> (ShowLiveItems <$> (A.space *> onOffP <|> pure True)),
"/show " *> (ShowChatItem . Just <$> A.decimal),
"/item info " *> (ShowChatItemInfo <$> chatNameP <* A.space <*> msgTextP),
("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> filePath),
("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> filePath),
("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal),

View File

@ -213,6 +213,7 @@ data ChatCommand
| APIGetChats {userId :: UserId, pendingConnections :: Bool}
| APIGetChat ChatRef ChatPagination (Maybe String)
| APIGetChatItems ChatPagination (Maybe String)
| APIGetChatItemInfo ChatItemId
| APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, composedMessage :: ComposedMessage}
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent}
| APIDeleteChatItem ChatRef ChatItemId CIDeleteMode
@ -341,6 +342,7 @@ data ChatCommand
| LastMessages (Maybe ChatName) Int (Maybe String) -- UserId (not used in UI)
| LastChatItemId (Maybe ChatName) Int -- UserId (not used in UI)
| ShowChatItem (Maybe ChatItemId) -- UserId (not used in UI)
| ShowChatItemInfo ChatName Text
| ShowLiveItems Bool
| SendFile ChatName FilePath
| SendImage ChatName FilePath
@ -378,6 +380,7 @@ data ChatResponse
| CRChats {chats :: [AChat]}
| CRApiChat {user :: User, chat :: AChat}
| CRChatItems {user :: User, chatItems :: [AChatItem]}
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
| CRChatItemId User (Maybe ChatItemId)
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
| CRUserProtoServers {user :: User, servers :: AUserProtoServers}

View File

@ -1451,3 +1451,24 @@ jsonCIDeleted :: CIDeleted d -> JSONCIDeleted
jsonCIDeleted = \case
CIDeleted -> JCIDDeleted
CIModerated m -> JCIDModerated m
data ChatItemInfo = ChatItemInfo
{ chatItemId :: ChatItemId,
itemTs :: UTCTime,
createdAt :: UTCTime,
updatedAt :: UTCTime,
itemVersions :: [ChatItemVersion]
}
deriving (Eq, Show, Generic)
instance ToJSON ChatItemInfo where toEncoding = J.genericToEncoding J.defaultOptions
data ChatItemVersion = ChatItemVersion
{ chatItemVersionId :: Int64,
msgContent :: MsgContent,
itemVersionTs :: UTCTime,
createdAt :: UTCTime
}
deriving (Eq, Show, Generic)
instance ToJSON ChatItemVersion where toEncoding = J.genericToEncoding J.defaultOptions

View File

@ -0,0 +1,29 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20230505_chat_item_versions where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20230505_chat_item_versions :: Query
m20230505_chat_item_versions =
[sql|
CREATE TABLE chat_item_versions ( -- contains versions only for edited chat items, including current version
chat_item_version_id INTEGER PRIMARY KEY AUTOINCREMENT,
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
msg_content TEXT NOT NULL,
item_version_ts TEXT NOT NULL,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE INDEX idx_chat_item_versions_chat_item_id ON chat_item_versions(chat_item_id);
|]
down_m20230505_chat_item_versions :: Query
down_m20230505_chat_item_versions =
[sql|
DROP INDEX idx_chat_item_versions_chat_item_id;
DROP TABLE chat_item_versions;
|]

View File

@ -454,6 +454,15 @@ CREATE TABLE msg_delivery_events(
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE TABLE chat_item_versions(
-- contains versions only for edited chat items, including current version
chat_item_version_id INTEGER PRIMARY KEY AUTOINCREMENT,
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
msg_content TEXT NOT NULL,
item_version_ts TEXT NOT NULL,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
CREATE INDEX contact_profiles_index ON contact_profiles(
display_name,
full_name
@ -595,3 +604,6 @@ CREATE INDEX idx_extra_xftp_file_descriptions_user_id ON extra_xftp_file_descrip
CREATE INDEX idx_xftp_file_descriptions_user_id ON xftp_file_descriptions(
user_id
);
CREATE INDEX idx_chat_item_versions_chat_item_id ON chat_item_versions(
chat_item_id
);

View File

@ -358,6 +358,9 @@ msgContentText = \case
MCFile t -> t
MCUnknown {text} -> text
toMCText :: MsgContent -> MsgContent
toMCText = MCText . msgContentText
durationText :: Int -> Text
durationText duration =
let (mins, secs) = duration `divMod` 60 in T.pack $ "(" <> with0 mins <> ":" <> with0 secs <> ")"

View File

@ -226,6 +226,7 @@ module Simplex.Chat.Store
getGroupChat,
getAllChatItems,
getAChatItem,
getChatItemVersions,
getChatItemIdByAgentMsgId,
getDirectChatItem,
getDirectChatItemBySharedMsgId,
@ -236,13 +237,17 @@ module Simplex.Chat.Store
getGroupMemberCIBySharedMsgId,
getGroupMemberChatItemLast,
getDirectChatItemIdByText,
getDirectChatItemIdByText',
getGroupChatItemIdByText,
getGroupChatItemIdByText',
getChatItemByFileId,
getChatItemByGroupId,
updateDirectChatItemStatus,
updateDirectCIFileStatus,
updateDirectChatItem,
updateDirectChatItem',
addInitialAndNewCIVersions,
createChatItemVersion,
deleteDirectChatItem,
markDirectChatItemDeleted,
updateGroupChatItem,
@ -377,6 +382,7 @@ import Simplex.Chat.Migrations.M20230411_extra_xftp_file_descriptions
import Simplex.Chat.Migrations.M20230420_rcv_files_to_receive
import Simplex.Chat.Migrations.M20230422_profile_contact_links
import Simplex.Chat.Migrations.M20230504_recreate_msg_delivery_events_cleanup_messages
import Simplex.Chat.Migrations.M20230505_chat_item_versions
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Util (week)
@ -453,7 +459,8 @@ schemaMigrations =
("20230411_extra_xftp_file_descriptions", m20230411_extra_xftp_file_descriptions, Just down_m20230411_extra_xftp_file_descriptions),
("20230420_rcv_files_to_receive", m20230420_rcv_files_to_receive, Just down_m20230420_rcv_files_to_receive),
("20230422_profile_contact_links", m20230422_profile_contact_links, Just down_m20230422_profile_contact_links),
("20230504_recreate_msg_delivery_events_cleanup_messages", m20230504_recreate_msg_delivery_events_cleanup_messages, Just down_m20230504_recreate_msg_delivery_events_cleanup_messages)
("20230504_recreate_msg_delivery_events_cleanup_messages", m20230504_recreate_msg_delivery_events_cleanup_messages, Just down_m20230504_recreate_msg_delivery_events_cleanup_messages),
("20230505_chat_item_versions", m20230505_chat_item_versions, Just down_m20230505_chat_item_versions)
]
-- | The list of migrations in ascending order by date
@ -4399,10 +4406,35 @@ updateDirectChatItem_ db userId contactId ChatItem {meta, content} msgId_ = do
((content, itemText, itemStatus, itemDeleted', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, contactId, itemId))
forM_ msgId_ $ \msgId -> liftIO $ insertChatItemMessage_ db itemId msgId updatedAt
addInitialAndNewCIVersions :: DB.Connection -> ChatItemId -> (UTCTime, MsgContent) -> (UTCTime, MsgContent) -> IO ()
addInitialAndNewCIVersions db itemId (initialTs, initialMC) (newTs, newMC) = do
versionsCount <- getChatItemVersionsCount db itemId
when (versionsCount == 0) $
createChatItemVersion db itemId initialTs initialMC
createChatItemVersion db itemId newTs newMC
getChatItemVersionsCount :: DB.Connection -> ChatItemId -> IO Int
getChatItemVersionsCount db itemId = do
count <-
maybeFirstRow fromOnly $
DB.query db "SELECT COUNT(1) FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId)
pure $ fromMaybe 0 count
createChatItemVersion :: DB.Connection -> ChatItemId -> UTCTime -> MsgContent -> IO ()
createChatItemVersion db itemId itemVersionTs msgContent =
DB.execute
db
[sql|
INSERT INTO chat_item_versions (chat_item_id, msg_content, item_version_ts)
VALUES (?,?,?)
|]
(itemId, toMCText msgContent, itemVersionTs)
deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO ()
deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
DB.execute
db
[sql|
@ -4425,6 +4457,10 @@ deleteChatItemMessages_ db itemId =
|]
(Only itemId)
deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO ()
deleteChatItemVersions_ db itemId =
DB.execute db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId)
markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> MessageId -> IO ()
markDirectChatItemDeleted db User {userId} Contact {contactId} (CChatItem _ ci) msgId = do
currentTs <- liftIO getCurrentTime
@ -4489,18 +4525,32 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do
getDirectChatItemIdByText :: DB.Connection -> UserId -> Int64 -> SMsgDirection d -> Text -> ExceptT StoreError IO ChatItemId
getDirectChatItemIdByText db userId contactId msgDir quotedMsg =
ExceptT . firstRow fromOnly SEQuotedChatItemNotFound $
ExceptT . firstRow fromOnly (SEChatItemNotFoundByText quotedMsg) $
DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_sent = ? AND item_text like ?
WHERE user_id = ? AND contact_id = ? AND item_sent = ? AND item_text LIKE ?
ORDER BY chat_item_id DESC
LIMIT 1
|]
(userId, contactId, msgDir, quotedMsg <> "%")
getDirectChatItemIdByText' :: DB.Connection -> User -> ContactId -> Text -> ExceptT StoreError IO ChatItemId
getDirectChatItemIdByText' db User {userId} contactId msg =
ExceptT . firstRow fromOnly (SEChatItemNotFoundByText msg) $
DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND contact_id = ? AND item_text LIKE ?
ORDER BY chat_item_id DESC
LIMIT 1
|]
(userId, contactId, msg <> "%")
updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> CIContent d -> Bool -> Maybe MessageId -> IO (ChatItem 'CTGroup d)
updateGroupChatItem db user groupId ci newContent live msgId_ = do
currentTs <- liftIO getCurrentTime
@ -4528,6 +4578,7 @@ deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup
deleteGroupChatItem db User {userId} GroupInfo {groupId} (CChatItem _ ci) = do
let itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
DB.execute
db
[sql|
@ -4543,6 +4594,7 @@ updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatIt
toText = ciModeratedText
itemId = chatItemId' ci
deleteChatItemMessages_ db itemId
deleteChatItemVersions_ db itemId
liftIO $
DB.execute
db
@ -4648,9 +4700,9 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|]
(userId, groupId, itemId)
getGroupChatItemIdByText :: DB.Connection -> User -> Int64 -> Maybe ContactName -> Text -> ExceptT StoreError IO ChatItemId
getGroupChatItemIdByText :: DB.Connection -> User -> GroupId -> Maybe ContactName -> Text -> ExceptT StoreError IO ChatItemId
getGroupChatItemIdByText db User {userId, localDisplayName = userName} groupId contactName_ quotedMsg =
ExceptT . firstRow fromOnly SEQuotedChatItemNotFound $ case contactName_ of
ExceptT . firstRow fromOnly (SEChatItemNotFoundByText quotedMsg) $ case contactName_ of
Nothing -> anyMemberChatItem_
Just cName
| userName == cName -> userChatItem_
@ -4692,6 +4744,20 @@ getGroupChatItemIdByText db User {userId, localDisplayName = userName} groupId c
|]
(userId, groupId, cName, quotedMsg <> "%")
getGroupChatItemIdByText' :: DB.Connection -> User -> GroupId -> Text -> ExceptT StoreError IO ChatItemId
getGroupChatItemIdByText' db User {userId} groupId msg =
ExceptT . firstRow fromOnly (SEChatItemNotFoundByText msg) $
DB.query
db
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND item_text like ?
ORDER BY chat_item_id DESC
LIMIT 1
|]
(userId, groupId, msg <> "%")
getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db user@User {userId} fileId = do
(itemId, chatRef) <-
@ -4748,6 +4814,22 @@ getAChatItem_ db user itemId = \case
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci
_ -> throwError $ SEChatItemNotFound itemId
getChatItemVersions :: DB.Connection -> ChatItemId -> IO [ChatItemVersion]
getChatItemVersions db itemId = do
map toChatItemVersion
<$> DB.query
db
[sql|
SELECT chat_item_version_id, msg_content, item_version_ts, created_at
FROM chat_item_versions
WHERE chat_item_id = ?
ORDER BY chat_item_version_id DESC
|]
(Only itemId)
where
toChatItemVersion :: (Int64, MsgContent, UTCTime, UTCTime) -> ChatItemVersion
toChatItemVersion (chatItemVersionId, msgContent, itemVersionTs, createdAt) = ChatItemVersion {chatItemVersionId, msgContent, itemVersionTs, createdAt}
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db user fileId fileStatus = do
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId
@ -5353,7 +5435,7 @@ data StoreError
| SENoMsgDelivery {connId :: Int64, agentMsgId :: AgentMsgId}
| SEBadChatItem {itemId :: ChatItemId}
| SEChatItemNotFound {itemId :: ChatItemId}
| SEQuotedChatItemNotFound
| SEChatItemNotFoundByText {text :: Text}
| SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId}
| SEChatItemNotFoundByFileId {fileId :: FileTransferId}
| SEChatItemNotFoundByGroupId {groupId :: GroupId}

View File

@ -14,6 +14,7 @@ import Control.Monad.Except
import Control.Monad.Reader
import Data.List (intercalate)
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (getCurrentTimeZone)
import Simplex.Chat (processChatCommand)
import Simplex.Chat.Controller
import Simplex.Chat.Messages hiding (NewChatItem (..))
@ -137,7 +138,8 @@ responseString :: ChatController -> Bool -> ChatResponse -> IO [StyledString]
responseString cc liveItems r = do
user <- readTVarIO $ currentUser cc
ts <- getCurrentTime
pure $ responseToView user (config cc) liveItems ts r
tz <- getCurrentTimeZone
pure $ responseToView user (config cc) liveItems ts tz r
printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
printToTerminal ct s =

View File

@ -26,7 +26,7 @@ import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1)
import Data.Time.Clock (DiffTime, UTCTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime (ZonedTime (..), localDay, localTimeOfDay, timeOfDayToTime, utcToZonedTime)
import Data.Time.LocalTime (TimeZone, ZonedTime (..), localDay, localTimeOfDay, timeOfDayToTime, utcToLocalTime, utcToZonedTime)
import Data.Word (Word32)
import GHC.Generics (Generic)
import qualified Network.HTTP.Types as Q
@ -57,11 +57,11 @@ import System.Console.ANSI.Types
type CurrentTime = UTCTime
serializeChatResponse :: Maybe User -> CurrentTime -> ChatResponse -> String
serializeChatResponse user_ ts = unlines . map unStyle . responseToView user_ defaultChatConfig False ts
serializeChatResponse :: Maybe User -> CurrentTime -> TimeZone -> ChatResponse -> String
serializeChatResponse user_ ts tz = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz
responseToView :: Maybe User -> ChatConfig -> Bool -> CurrentTime -> ChatResponse -> [StyledString]
responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
responseToView :: Maybe User -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> ChatResponse -> [StyledString]
responseToView user_ ChatConfig {logLevel, testView} liveItems ts tz = \case
CRActiveUser User {profile} -> viewUserProfile $ fromLocalProfile profile
CRUsersList users -> viewUsersList users
CRChatStarted -> ["chat started"]
@ -85,6 +85,7 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView
CRNewChatItem u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewChatItem chat item False ts
CRChatItems u chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts) chatItems
CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz
CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
CRChatItemStatusUpdated u _ -> ttyUser u []
CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewItemUpdate chat item liveItems ts
@ -415,6 +416,29 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file}
plainContent = plain . ciContentToText
prohibited = styled (colored Red) ("[unexpected chat item created, please report to developers]" :: String)
viewChatItemInfo :: AChatItem -> ChatItemInfo -> TimeZone -> [StyledString]
viewChatItemInfo (AChatItem _ msgDir _ _) ChatItemInfo {itemTs, createdAt, itemVersions} tz = case msgDir of
SMDRcv ->
[ "sent at: " <> ts itemTs,
"received at: " <> ts createdAt
]
<> versions
SMDSnd ->
["sent at: " <> ts itemTs] <> versions
where
ts = styleTime . localTs tz
versions =
if null itemVersions
then []
else ["message history:"] <> concatMap version itemVersions
version ChatItemVersion {msgContent, itemVersionTs} = prependFirst (ts itemVersionTs <> styleTime ": ") $ ttyMsgContent msgContent
localTs :: TimeZone -> UTCTime -> String
localTs tz ts = do
let localTime = utcToLocalTime tz ts
formattedTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" localTime
formattedTime
viewItemUpdate :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> [StyledString]
viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemEdited, itemLive}, content, quotedItem} liveItems ts = case chat of
DirectChat c -> case chatDir of
@ -1368,7 +1392,7 @@ viewChatError logLevel = \case
SEContactRequestNotFoundByName c -> ["no contact request from " <> ttyContact c]
SEFileIdNotFoundBySharedMsgId _ -> [] -- recipient tried to accept cancelled file
SEConnectionNotFound agentConnId -> ["event connection not found, agent ID: " <> sShow agentConnId | logLevel <= CLLWarning] -- mutes delete group error
SEQuotedChatItemNotFound -> ["message not found - reply is not sent"]
SEChatItemNotFoundByText text -> ["message not found by text: " <> plain text]
SEDuplicateGroupLink g -> ["you already have link for this group, to show: " <> highlight ("/show link #" <> groupName' g)]
SEGroupLinkNotFound g -> ["no group link, to create: " <> highlight ("/create link #" <> groupName' g)]
e -> ["chat db error: " <> sShow e]

View File

@ -31,6 +31,7 @@ chatDirectTests = do
it "deleting contact deletes profile" testDeleteContactDeletesProfile
it "direct message quoted replies" testDirectMessageQuotedReply
it "direct message update" testDirectMessageUpdate
it "direct message edit history" testDirectMessageEditHistory
it "direct message delete" testDirectMessageDelete
it "direct live message" testDirectLiveMessage
it "repeat AUTH errors disable contact" testRepeatAuthErrorsDisableContact
@ -268,6 +269,73 @@ testDirectMessageUpdate =
alice #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((1, "greetings 🤝"), Nothing), ((0, "hey Alice"), Just (1, "hello 🙂")), ((0, "greetings Alice"), Just (1, "hey 👋"))])
bob #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "greetings 🤝"), Nothing), ((1, "hey Alice"), Just (0, "hello 🙂")), ((1, "greetings Alice"), Just (0, "hey 👋"))])
testDirectMessageEditHistory :: HasCallStack => FilePath -> IO ()
testDirectMessageEditHistory =
testChat2 aliceProfile bobProfile $
\alice bob -> do
connectUsers alice bob
alice #> "@bob hello!"
bob <# "alice> hello!"
alice ##> ("/_get item info " <> itemId 1)
alice <##. "sent at: "
bob ##> ("/_get item info " <> itemId 1)
bob <##. "sent at: "
bob <##. "received at: "
alice ##> ("/_update item @2 " <> itemId 1 <> " text hey 👋")
alice <# "@bob [edited] hey 👋"
bob <# "alice> [edited] hey 👋"
alice ##> ("/_get item info " <> itemId 1)
alice <##. "sent at: "
alice <## "message history:"
alice .<## ": hey 👋"
alice .<## ": hello!"
bob ##> ("/_get item info " <> itemId 1)
bob <##. "sent at: "
bob <##. "received at: "
bob <## "message history:"
bob .<## ": hey 👋"
bob .<## ": hello!"
alice ##> ("/_update item @2 " <> itemId 1 <> " text hello there")
alice <# "@bob [edited] hello there"
bob <# "alice> [edited] hello there"
alice ##> "/item info @bob hello"
alice <##. "sent at: "
alice <## "message history:"
alice .<## ": hello there"
alice .<## ": hey 👋"
alice .<## ": hello!"
bob ##> "/item info @alice hello"
bob <##. "sent at: "
bob <##. "received at: "
bob <## "message history:"
bob .<## ": hello there"
bob .<## ": hey 👋"
bob .<## ": hello!"
bob #$> ("/_delete item @2 " <> itemId 1 <> " internal", id, "message deleted")
alice ##> ("/_update item @2 " <> itemId 1 <> " text hey there")
alice <# "@bob [edited] hey there"
bob <# "alice> [edited] hey there"
alice ##> "/item info @bob hey"
alice <##. "sent at: "
alice <## "message history:"
alice .<## ": hey there"
alice .<## ": hello there"
alice .<## ": hey 👋"
alice .<## ": hello!"
bob ##> "/item info @alice hey"
bob <##. "sent at: "
bob <##. "received at: "
bob <## "message history:"
bob .<## ": hey there"
testDirectMessageDelete :: HasCallStack => FilePath -> IO ()
testDirectMessageDelete =
testChat2 aliceProfile bobProfile $
@ -359,6 +427,18 @@ testDirectLiveMessage =
alice ##> ("/_update item @2 " <> itemId 2 <> " text hello 2")
alice <# "@bob [LIVE] hello 2"
bob <# "alice> [LIVE ended] hello 2"
-- live message has edit history
alice ##> ("/_get item info " <> itemId 2)
alice <##. "sent at: "
alice <## "message history:"
alice .<## ": hello 2"
alice .<## ":"
bob ##> ("/_get item info " <> itemId 2)
bob <##. "sent at: "
bob <##. "received at: "
bob <## "message history:"
bob .<## ": hello 2"
bob .<## ":"
testRepeatAuthErrorsDisableContact :: HasCallStack => FilePath -> IO ()
testRepeatAuthErrorsDisableContact =

View File

@ -32,6 +32,7 @@ chatGroupTests = do
it "list groups containing group invitations" testGroupList
it "group message quoted replies" testGroupMessageQuotedReply
it "group message update" testGroupMessageUpdate
it "group message edit history" testGroupMessageEditHistory
it "group message delete" testGroupMessageDelete
it "group live message" testGroupLiveMessage
it "update group profile" testUpdateGroupProfile
@ -875,6 +876,76 @@ testGroupMessageUpdate =
bob #$> ("/_get chat #1 count=3", chat', [((0, "greetings 🤝"), Nothing), ((1, "hi alice"), Just (0, "hey 👋")), ((0, "greetings!"), Just (0, "greetings 🤝"))])
cath #$> ("/_get chat #1 count=3", chat', [((0, "greetings 🤝"), Nothing), ((0, "hi alice"), Just (0, "hey 👋")), ((1, "greetings!"), Just (0, "greetings 🤝"))])
testGroupMessageEditHistory :: HasCallStack => FilePath -> IO ()
testGroupMessageEditHistory =
testChat2 aliceProfile bobProfile $
\alice bob -> do
createGroup2 "team" alice bob
threadDelay 1000000
alice #> "#team hello!"
bob <# "#team alice> hello!"
aliceItemId <- lastItemId alice
bobItemId <- lastItemId bob
alice ##> ("/_get item info " <> aliceItemId)
alice <##. "sent at: "
bob ##> ("/_get item info " <> bobItemId)
bob <##. "sent at: "
bob <##. "received at: "
alice ##> ("/_update item #1 " <> aliceItemId <> " text hey 👋")
alice <# "#team [edited] hey 👋"
bob <# "#team alice> [edited] hey 👋"
alice ##> ("/_get item info " <> aliceItemId)
alice <##. "sent at: "
alice <## "message history:"
alice .<## ": hey 👋"
alice .<## ": hello!"
bob ##> ("/_get item info " <> bobItemId)
bob <##. "sent at: "
bob <##. "received at: "
bob <## "message history:"
bob .<## ": hey 👋"
bob .<## ": hello!"
alice ##> ("/_update item #1 " <> aliceItemId <> " text hello there")
alice <# "#team [edited] hello there"
bob <# "#team alice> [edited] hello there"
alice ##> "/item info #team hello"
alice <##. "sent at: "
alice <## "message history:"
alice .<## ": hello there"
alice .<## ": hey 👋"
alice .<## ": hello!"
bob ##> "/item info #team hello"
bob <##. "sent at: "
bob <##. "received at: "
bob <## "message history:"
bob .<## ": hello there"
bob .<## ": hey 👋"
bob .<## ": hello!"
bob #$> ("/_delete item #1 " <> bobItemId <> " internal", id, "message deleted")
alice ##> ("/_update item #1 " <> aliceItemId <> " text hey there")
alice <# "#team [edited] hey there"
bob <# "#team alice> [edited] hey there"
alice ##> "/item info #team hey"
alice <##. "sent at: "
alice <## "message history:"
alice .<## ": hey there"
alice .<## ": hello there"
alice .<## ": hey 👋"
alice .<## ": hello!"
bob ##> "/item info #team hey"
bob <##. "sent at: "
bob <##. "received at: "
bob <## "message history:"
bob .<## ": hey there"
testGroupMessageDelete :: HasCallStack => FilePath -> IO ()
testGroupMessageDelete =
testChat3 aliceProfile bobProfile cathProfile $
@ -981,6 +1052,19 @@ testGroupLiveMessage =
alice <# "#team [LIVE] hello 2"
bob <# "#team alice> [LIVE ended] hello 2"
cath <# "#team alice> [LIVE ended] hello 2"
-- live message has edit history
alice ##> ("/_get item info " <> msgItemId2)
alice <##. "sent at: "
alice <## "message history:"
alice .<## ": hello 2"
alice .<## ":"
bobItemId <- lastItemId bob
bob ##> ("/_get item info " <> bobItemId)
bob <##. "sent at: "
bob <##. "received at: "
bob <## "message history:"
bob .<## ": hello 2"
bob .<## ":"
testUpdateGroupProfile :: HasCallStack => FilePath -> IO ()
testUpdateGroupProfile =

View File

@ -231,6 +231,13 @@ cc <##. line = do
unless prefix $ print ("expected to start from: " <> line, ", got: " <> l)
prefix `shouldBe` True
(.<##) :: HasCallStack => TestCC -> String -> Expectation
cc .<## line = do
l <- getTermLine cc
let suffix = line `isSuffixOf` l
unless suffix $ print ("expected to end with: " <> line, ", got: " <> l)
suffix `shouldBe` True
(<#.) :: HasCallStack => TestCC -> String -> Expectation
cc <#. line = do
l <- dropTime <$> getTermLine cc