dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-03-30 16:25:57 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: new files protocol (#492)

Browse Source
This commit is contained in:
JRoberts
2022-04-05 10:01:08 +04:00
committed by GitHub
parent a17ddede53
commit a5ca2c2163
12 changed files with 551 additions and 70 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
simplex-chat.cabal
View File

@@ -34,6 +34,7 @@ library
Simplex.Chat.Migrations.M20220302_profile_images
Simplex.Chat.Migrations.M20220304_msg_quotes
Simplex.Chat.Migrations.M20220321_chat_item_edited
Simplex.Chat.Migrations.M20220404_files_cancelled
Simplex.Chat.Mobile
Simplex.Chat.Options
Simplex.Chat.Protocol

147
src/Simplex/Chat.hs
View File

@@ -463,25 +463,37 @@ processChatCommand = \case
editedItemId <- withStore $ \st -> getGroupChatItemIdByText st user groupId (Just localDisplayName) (safeDecodeUtf8 editedMsg)
let mc = MCText $ safeDecodeUtf8 msg
processChatCommand $ APIUpdateChatItem CTGroup groupId editedItemId mc
-- old file protocol
SendFile cName f -> withUser $ \user@User {userId} -> withChatLock $ do
(fileSize, chSize) <- checkSndFile f
contact <- withStore $ \st -> getContactByName st userId cName
(agentConnId, connReq) <- withAgent (`createConnection` SCMInvitation)
let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileConnReq = ACR SCMInvitation connReq}
(agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation)
let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileConnReq = Just fileConnReq}
SndFileTransfer {fileId} <- withStore $ \st ->
createSndFileTransfer st userId contact f fileInv agentConnId chSize
ci <- sendDirectChatItem user contact (XFile fileInv) (CISndFileInvitation fileId f) Nothing
withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci
setActive $ ActiveC cName
pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci
-- new file protocol
SendFileInv cName f -> withUser $ \user@User {userId} -> withChatLock $ do
(fileSize, chSize) <- checkSndFile f
contact <- withStore $ \st -> getContactByName st userId cName
let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileConnReq = Nothing}
fileId <- withStore $ \st -> createSndFileTransferV2 st userId contact f fileInv chSize
ci <- sendDirectChatItem user contact (XFile fileInv) (CISndFileInvitation fileId f) Nothing
withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci
setActive $ ActiveC cName
pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci
-- old file protocol
SendGroupFile gName f -> withUser $ \user@User {userId} -> withChatLock $ do
(fileSize, chSize) <- checkSndFile f
Group gInfo@GroupInfo {groupId, membership} members <- withStore $ \st -> getGroupByName st user gName
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
let fileName = takeFileName f
ms <- forM (filter memberActive members) $ \m -> do
(connId, connReq) <- withAgent (`createConnection` SCMInvitation)
pure (m, connId, FileInvitation {fileName, fileSize, fileConnReq = ACR SCMInvitation connReq})
(connId, fileConnReq) <- withAgent (`createConnection` SCMInvitation)
pure (m, connId, FileInvitation {fileName, fileSize, fileConnReq = Just fileConnReq})
fileId <- withStore $ \st -> createSndGroupFileTransfer st userId gInfo ms f fileSize chSize
-- TODO sendGroupChatItem - same file invitation to all
forM_ ms $ \(m, _, fileInv) ->
@@ -493,27 +505,69 @@ processChatCommand = \case
cItem@ChatItem {meta = CIMeta {itemId}} <- saveSndChatItem user (CDGroupSnd gInfo) msg ciContent Nothing
withStore $ \st -> updateFileTransferChatItemId st fileId itemId
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) cItem
ReceiveFile fileId filePath_ -> withUser $ \User {userId} -> do
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq = ACR _ fileConnReq}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
-- new file protocol
SendGroupFileInv gName f -> withUser $ \user@User {userId} -> withChatLock $ do
(fileSize, chSize) <- checkSndFile f
g@(Group gInfo@GroupInfo {membership} _) <- withStore $ \st -> getGroupByName st user gName
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileConnReq = Nothing}
fileId <- withStore $ \st -> createSndGroupFileTransferV2 st userId gInfo f fileInv chSize
ci <- sendGroupChatItem user g (XFile fileInv) (CISndFileInvitation fileId f) Nothing
withStore $ \st -> updateFileTransferChatItemId st fileId $ chatItemId' ci
setActive $ ActiveG gName
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
ReceiveFile fileId filePath_ -> withUser $ \user@User {userId} -> do
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileConnReq}, fileStatus, senderDisplayName, grpMemberId} <- withStore $ \st -> getRcvFileTransfer st userId fileId
unless (fileStatus == RFSNew) . throwChatError $ CEFileAlreadyReceiving fileName
withChatLock . procCmd $ do
tryError (withAgent $ \a -> joinConnection a fileConnReq . directMessage $ XFileAcpt fileName) >>= \case
Right agentConnId -> do
filePath <- getRcvFilePath fileId filePath_ fileName
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
pure $ CRRcvFileAccepted ft filePath
Left (ChatErrorAgent (SMP SMP.AUTH)) -> pure $ CRRcvFileAcceptedSndCancelled ft
Left (ChatErrorAgent (CONN DUPLICATE)) -> pure $ CRRcvFileAcceptedSndCancelled ft
Left e -> throwError e
case fileConnReq of
-- old file protocol
Just connReq ->
withChatLock . procCmd $ do
tryError (withAgent $ \a -> joinConnection a connReq . directMessage $ XFileAcpt fileName) >>= \case
Right agentConnId -> do
filePath <- getRcvFilePath fileId filePath_ fileName
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
pure $ CRRcvFileAccepted ft filePath
Left (ChatErrorAgent (SMP SMP.AUTH)) -> pure $ CRRcvFileAcceptedSndCancelled ft
Left (ChatErrorAgent (CONN DUPLICATE)) -> pure $ CRRcvFileAcceptedSndCancelled ft
Left e -> throwError e
-- new file protocol
Nothing ->
case grpMemberId of
Nothing ->
withChatLock . procCmd $ do
ct <- withStore $ \st -> getContactByName st userId senderDisplayName
acceptFileV2 $ \sharedMsgId fileInvConnReq -> sendDirectContactMessage ct $ XFileAcptInv sharedMsgId fileInvConnReq fileName
Just memId ->
withChatLock . procCmd $ do
(GroupInfo {groupId}, GroupMember {activeConn}) <- withStore $ \st -> getGroupAndMember st user memId
case activeConn of
Just conn ->
acceptFileV2 $ \sharedMsgId fileInvConnReq -> sendDirectMessage conn (XFileAcptInv sharedMsgId fileInvConnReq fileName) (GroupId groupId)
_ -> throwChatError $ CEFileInternal "member connection not active" -- should not happen
where
acceptFileV2 :: (SharedMsgId -> ConnReqInvitation -> m SndMessage) -> m ChatResponse
acceptFileV2 sendXFileAcptInv = do
sharedMsgId <- withStore $ \st -> getSharedMsgIdByFileId st userId fileId
(agentConnId, fileInvConnReq) <- withAgent (`createConnection` SCMInvitation)
filePath <- getRcvFilePath fileId filePath_ fileName
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
void $ sendXFileAcptInv sharedMsgId fileInvConnReq
pure $ CRRcvFileAccepted ft filePath
CancelFile fileId -> withUser $ \User {userId} -> do
ft' <- withStore (\st -> getFileTransfer st userId fileId)
withChatLock . procCmd $ case ft' of
FTSnd fts -> do
forM_ fts $ \ft -> cancelSndFileTransfer ft
pure $ CRSndGroupFileCancelled fts
FTRcv ft -> do
cancelRcvFileTransfer ft
pure $ CRRcvFileCancelled ft
withChatLock . procCmd $ do
unless (fileTransferCancelled ft') $
withStore $ \st -> updateFileCancelled st userId fileId
case ft' of
FTSnd ftm [] -> do
pure $ CRSndGroupFileCancelled ftm []
FTSnd ftm fts -> do
forM_ fts $ \ft -> cancelSndFileTransfer ft
pure $ CRSndGroupFileCancelled ftm fts
FTRcv ft -> do
cancelRcvFileTransfer ft
pure $ CRRcvFileCancelled ft
FileStatus fileId ->
CRFileTransferStatus <$> withUser (\User {userId} -> withStore $ \st -> getFileTransferProgress st userId fileId)
ShowProfile -> withUser $ \User {profile} -> pure $ CRUserProfile profile
@@ -772,6 +826,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
XMsgUpdate sharedMsgId mContent -> messageUpdate ct sharedMsgId mContent msg msgMeta
XMsgDel sharedMsgId -> messageDelete ct sharedMsgId msg msgMeta
XFile fInv -> processFileInvitation ct fInv msg msgMeta
XFileAcptInv sharedMsgId fileConnReq fName -> xFileAcptInv ct sharedMsgId fileConnReq fName msgMeta
XInfo p -> xInfo ct p
XGrpInv gInv -> processGroupInvitation ct gInv
XInfoProbe probe -> xInfoProbe ct probe
@@ -913,6 +968,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
XMsgUpdate sharedMsgId mContent -> groupMessageUpdate gInfo m sharedMsgId mContent msg
XMsgDel sharedMsgId -> groupMessageDelete gInfo m sharedMsgId msg
XFile fInv -> processGroupFileInvitation gInfo m fInv msg msgMeta
XFileAcptInv sharedMsgId fileConnReq fName -> xFileAcptInvGroup gInfo m sharedMsgId fileConnReq fName msgMeta
XGrpMemNew memInfo -> xGrpMemNew gInfo m memInfo
XGrpMemIntro memInfo -> xGrpMemIntro conn gInfo m memInfo
XGrpMemInv memId introInv -> xGrpMemInv gInfo m memId introInv
@@ -933,6 +989,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
processSndFileConn :: ACommand 'Agent -> Connection -> SndFileTransfer -> m ()
processSndFileConn agentMsg conn ft@SndFileTransfer {fileId, fileName, fileStatus} =
case agentMsg of
-- old file protocol
CONF confId connInfo -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
case chatMsgEvent of
@@ -963,8 +1020,14 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
_ -> pure ()
processRcvFileConn :: ACommand 'Agent -> Connection -> RcvFileTransfer -> m ()
processRcvFileConn agentMsg _conn ft@RcvFileTransfer {fileId, chunkSize} =
processRcvFileConn agentMsg conn ft@RcvFileTransfer {fileId, chunkSize} =
case agentMsg of
-- new file protocol
CONF confId connInfo -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
case chatMsgEvent of
XOk -> allowAgentConnection conn confId XOk
_ -> pure ()
CON -> do
withStore $ \st -> updateRcvFileStatus st ft FSConnected
toView $ CRRcvFileStart ft
@@ -1170,6 +1233,42 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
showToast ("#" <> g <> " " <> c <> "> ") "wants to send a file"
setActive $ ActiveG g
xFileAcptInv :: Contact -> SharedMsgId -> ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInv Contact {contactId} sharedMsgId fileConnReq fName msgMeta = do
checkIntegrity msgMeta $ toView . CRMsgIntegrityError
fileId <- withStore $ \st -> getFileIdBySharedMsgId st userId contactId sharedMsgId
withStore (\st -> getFileTransfer st userId fileId) >>= \case
FTSnd FileTransferMeta {fileName, cancelled} _ ->
if not cancelled
then
if fName == fileName
then
tryError (withAgent $ \a -> joinConnection a fileConnReq . directMessage $ XOk) >>= \case
Right acId ->
withStore $ \st -> createSndFileTransferV2Connection st userId fileId acId
Left e -> throwError e
else messageError "x.file.acpt.inv: fileName is different from expected"
else pure () -- TODO send "file cancelled" message
_ -> messageError "x.file.acpt.inv: bad file direction"
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInvGroup GroupInfo {groupId} m sharedMsgId fileConnReq fName msgMeta = do
checkIntegrity msgMeta $ toView . CRMsgIntegrityError
fileId <- withStore $ \st -> getGroupFileIdBySharedMsgId st userId groupId sharedMsgId
withStore (\st -> getFileTransfer st userId fileId) >>= \case
FTSnd FileTransferMeta {fileName, cancelled} _ ->
if not cancelled
then
if fName == fileName
then
tryError (withAgent $ \a -> joinConnection a fileConnReq . directMessage $ XOk) >>= \case
Right acId ->
withStore $ \st -> createSndGroupFileTransferV2Connection st userId fileId acId m
Left e -> throwError e
else messageError "x.file.acpt.inv: fileName is different from expected"
else pure () -- TODO send "file cancelled" message
_ -> messageError "x.file.acpt.inv: bad file direction"
groupMsgToView :: GroupInfo -> ChatItem 'CTGroup 'MDRcv -> MsgMeta -> m ()
groupMsgToView gInfo ci msgMeta = do
toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
@@ -1696,7 +1795,9 @@ chatCommandP =
<|> ("!@" <|> "! @") *> (EditMessage <$> displayName <* A.space <*> quotedMsg <*> A.takeByteString)
<|> "/feed " *> (SendMessageBroadcast <$> A.takeByteString)
<|> ("/file #" <|> "/f #") *> (SendGroupFile <$> displayName <* A.space <*> filePath)
<|> ("/file_v2 #" <|> "/f_v2 #") *> (SendGroupFileInv <$> displayName <* A.space <*> filePath)
<|> ("/file @" <|> "/file " <|> "/f @" <|> "/f ") *> (SendFile <$> displayName <* A.space <*> filePath)
<|> ("/file_v2 @" <|> "/file_v2 " <|> "/f_v2 @" <|> "/f_v2 ") *> (SendFileInv <$> displayName <* A.space <*> filePath)
<|> ("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> optional (A.space *> filePath))
<|> ("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal)
<|> ("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal)

4
src/Simplex/Chat/Controller.hs
View File

@@ -138,7 +138,9 @@ data ChatCommand
| DeleteGroupMessage GroupName ByteString
| EditGroupMessage {groupName :: ContactName, editedMsg :: ByteString, message :: ByteString}
| SendFile ContactName FilePath
| SendFileInv ContactName FilePath
| SendGroupFile GroupName FilePath
| SendGroupFileInv GroupName FilePath
| ReceiveFile FileTransferId (Maybe FilePath)
| CancelFile FileTransferId
| FileStatus FileTransferId
@@ -205,7 +207,7 @@ data ChatResponse
| CRSndFileComplete {sndFileTransfer :: SndFileTransfer}
| CRSndFileCancelled {sndFileTransfer :: SndFileTransfer}
| CRSndFileRcvCancelled {sndFileTransfer :: SndFileTransfer}
| CRSndGroupFileCancelled {sndFileTransfers :: [SndFileTransfer]}
| CRSndGroupFileCancelled {fileTransferMeta :: FileTransferMeta, sndFileTransfers :: [SndFileTransfer]}
| CRUserProfileUpdated {fromProfile :: Profile, toProfile :: Profile}
| CRContactConnecting {contact :: Contact}
| CRContactConnected {contact :: Contact}

12
src/Simplex/Chat/Migrations/M20220404_files_cancelled.hs Normal file
View File

@@ -0,0 +1,12 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20220404_files_cancelled where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220404_files_cancelled :: Query
m20220404_files_cancelled =
[sql|
ALTER TABLE files ADD COLUMN cancelled INTEGER; -- 1 for cancelled
|]

16
src/Simplex/Chat/Protocol.hs
View File

@@ -113,7 +113,8 @@ data ChatMsgEvent
| XMsgDel SharedMsgId
| XMsgDeleted
| XFile FileInvitation
| XFileAcpt String
| XFileAcpt String -- old file protocol
| XFileAcptInv SharedMsgId ConnReqInvitation String -- new file protocol
| XInfo Profile
| XContact Profile (Maybe XContactId)
| XGrpInv GroupInvitation
@@ -261,6 +262,7 @@ data CMEventTag
| XMsgDeleted_
| XFile_
| XFileAcpt_
| XFileAcptInv_
| XInfo_
| XContact_
| XGrpInv_
@@ -290,6 +292,7 @@ instance StrEncoding CMEventTag where
XMsgDeleted_ -> "x.msg.deleted"
XFile_ -> "x.file"
XFileAcpt_ -> "x.file.acpt"
XFileAcptInv_ -> "x.file.acpt.inv"
XInfo_ -> "x.info"
XContact_ -> "x.contact"
XGrpInv_ -> "x.grp.inv"
@@ -316,6 +319,7 @@ instance StrEncoding CMEventTag where
"x.msg.deleted" -> Right XMsgDeleted_
"x.file" -> Right XFile_
"x.file.acpt" -> Right XFileAcpt_
"x.file.acpt.inv" -> Right XFileAcptInv_
"x.info" -> Right XInfo_
"x.contact" -> Right XContact_
"x.grp.inv" -> Right XGrpInv_
@@ -345,6 +349,7 @@ toCMEventTag = \case
XMsgDeleted -> XMsgDeleted_
XFile _ -> XFile_
XFileAcpt _ -> XFileAcpt_
XFileAcptInv {} -> XFileAcptInv_
XInfo _ -> XInfo_
XContact _ _ -> XContact_
XGrpInv _ -> XGrpInv_
@@ -392,6 +397,7 @@ appToChatMessage AppMessage {msgId, event, params} = do
XMsgDeleted_ -> pure XMsgDeleted
XFile_ -> XFile <$> p "file"
XFileAcpt_ -> XFileAcpt <$> p "fileName"
XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> p "fileConnReq" <*> p "fileName"
XInfo_ -> XInfo <$> p "profile"
XContact_ -> XContact <$> p "profile" <*> opt "contactReqId"
XGrpInv_ -> XGrpInv <$> p "groupInvitation"
@@ -424,8 +430,9 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p
XMsgUpdate msgId' content -> o ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' -> o ["msgId" .= msgId']
XMsgDeleted -> JM.empty
XFile fileInv -> o ["file" .= fileInv]
XFile fileInv -> o ["file" .= fileInvitationJSON fileInv]
XFileAcpt fileName -> o ["fileName" .= fileName]
XFileAcptInv sharedMsgId fileConnReq fileName -> o ["msgId" .= sharedMsgId, "fileConnReq" .= fileConnReq, "fileName" .= fileName]
XInfo profile -> o ["profile" .= profile]
XContact profile xContactId -> o $ ("contactReqId" .=? xContactId) ["profile" .= profile]
XGrpInv groupInv -> o ["groupInvitation" .= groupInv]
@@ -445,3 +452,8 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p
XInfoProbeOk probe -> o ["probe" .= probe]
XOk -> JM.empty
XUnknown _ ps -> ps
fileInvitationJSON :: FileInvitation -> J.Object
fileInvitationJSON FileInvitation {fileName, fileSize, fileConnReq} = case fileConnReq of
Nothing -> JM.fromList ["fileName" .= fileName, "fileSize" .= fileSize]
Just fConnReq -> JM.fromList ["fileName" .= fileName, "fileSize" .= fileSize, "fileConnReq" .= fConnReq]

194
src/Simplex/Chat/Store.hs
View File

@@ -52,6 +52,7 @@ module Simplex.Chat.Store
getPendingConnections,
getContactConnections,
getConnectionEntity,
getGroupAndMember,
updateConnectionStatus,
createNewGroup,
createGroupInvitation,
@@ -87,8 +88,16 @@ module Simplex.Chat.Store
matchReceivedProbeHash,
matchSentProbe,
mergeContactRecords,
createSndFileTransfer,
createSndGroupFileTransfer,
createSndFileTransfer, -- old file protocol
createSndFileTransferV2,
createSndFileTransferV2Connection,
createSndGroupFileTransfer, -- old file protocol
createSndGroupFileTransferV2,
createSndGroupFileTransferV2Connection,
updateFileCancelled,
getSharedMsgIdByFileId,
getFileIdBySharedMsgId,
getGroupFileIdBySharedMsgId,
updateSndFileStatus,
createSndFileChunk,
updateSndFileChunkMsg,
@@ -179,10 +188,11 @@ import Simplex.Chat.Migrations.M20220301_smp_servers
import Simplex.Chat.Migrations.M20220302_profile_images
import Simplex.Chat.Migrations.M20220304_msg_quotes
import Simplex.Chat.Migrations.M20220321_chat_item_edited
import Simplex.Chat.Migrations.M20220404_files_cancelled
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Util (eitherToMaybe)
import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri, AgentMsgId, ConnId, InvitationId, MsgMeta (..), SMPServer (..))
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, InvitationId, MsgMeta (..), SMPServer (..))
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, firstRow, withTransaction)
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
import qualified Simplex.Messaging.Crypto as C
@@ -202,7 +212,8 @@ schemaMigrations =
("20220301_smp_servers", m20220301_smp_servers),
("20220302_profile_images", m20220302_profile_images),
("20220304_msg_quotes", m20220304_msg_quotes),
("20220321_chat_item_edited", m20220321_chat_item_edited)
("20220321_chat_item_edited", m20220321_chat_item_edited),
("20220404_files_cancelled", m20220404_files_cancelled)
]
-- | The list of migrations in ascending order by date
@@ -1139,7 +1150,7 @@ getConnectionEntity st User {userId, userContactId} agentConnId =
FROM snd_files s
JOIN files f USING (file_id)
LEFT JOIN contacts cs USING (contact_id)
LEFT JOIN group_members m USING (group_member_id)
LEFT JOIN group_members m USING (group_member_id)
WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ?
|]
(userId, fileId, connId)
@@ -1165,6 +1176,47 @@ getConnectionEntity st User {userId, userContactId} agentConnId =
userContact_ [Only cReq] = Right UserContact {userContactLinkId, connReqContact = cReq}
userContact_ _ = Left SEUserContactLinkNotFound
getGroupAndMember :: StoreMonad m => SQLiteStore -> User -> Int64 -> m (GroupInfo, GroupMember)
getGroupAndMember st User {userId, userContactId} groupMemberId =
liftIOEither . withTransaction st $ \db ->
firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
DB.query
db
[sql|
SELECT
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at,
-- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id,
-- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.image,
-- from GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
JOIN groups g ON g.group_id = m.group_id
JOIN group_profiles gp USING (group_profile_id)
JOIN group_members mu ON g.group_id = mu.group_id
JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id
LEFT JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.group_member_id = m.group_member_id
)
WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ?
|]
(groupMemberId, userId, userContactId)
where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
updateConnectionStatus :: MonadUnliftIO m => SQLiteStore -> Connection -> ConnStatus -> m ()
updateConnectionStatus st Connection {connId} connStatus =
liftIO . withTransaction st $ \db -> do
@@ -1748,6 +1800,26 @@ createSndFileTransfer st userId Contact {contactId, localDisplayName = recipient
(fileId, fileStatus, connId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName, connId, fileStatus, agentConnId = AgentConnId acId}
createSndFileTransferV2 :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FilePath -> FileInvitation -> Integer -> m Int64
createSndFileTransferV2 st userId Contact {contactId} filePath FileInvitation {fileName, fileSize} chunkSize =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, filePath, fileSize, chunkSize, currentTs, currentTs)
insertedRowId db
createSndFileTransferV2Connection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> m ()
createSndFileTransferV2Connection st userId fileId acId =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
Connection {connId} <- createSndFileConnection_ db userId fileId acId
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, FSAccepted, connId, currentTs, currentTs)
createSndGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupInfo -> [(GroupMember, ConnId, FileInvitation)] -> FilePath -> Integer -> Integer -> m Int64
createSndGroupFileTransfer st userId GroupInfo {groupId} ms filePath fileSize chunkSize =
liftIO . withTransaction st $ \db -> do
@@ -1766,6 +1838,74 @@ createSndGroupFileTransfer st userId GroupInfo {groupId} ms filePath fileSize ch
(fileId, FSNew, connId, groupMemberId, currentTs, currentTs)
pure fileId
createSndGroupFileTransferV2 :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> m Int64
createSndGroupFileTransferV2 st userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize} chunkSize =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, filePath, fileSize, chunkSize, currentTs, currentTs)
insertedRowId db
createSndGroupFileTransferV2Connection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> GroupMember -> m ()
createSndGroupFileTransferV2Connection st userId fileId acId GroupMember {groupMemberId} =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
Connection {connId} <- createSndFileConnection_ db userId fileId acId
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs)
updateFileCancelled :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m ()
updateFileCancelled st userId fileId =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
DB.execute db "UPDATE files SET cancelled = 1, updated_at = ? WHERE user_id = ? AND file_id = ?" (currentTs, userId, fileId)
getSharedMsgIdByFileId :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m SharedMsgId
getSharedMsgIdByFileId st userId fileId =
liftIOEither . withTransaction st $ \db ->
firstRow fromOnly (SESharedMsgIdNotFoundByFileId fileId) $
DB.query
db
[sql|
SELECT i.shared_msg_id
FROM chat_items i
JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
getFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> Int64 -> UserId -> SharedMsgId -> m Int64
getFileIdBySharedMsgId st userId contactId sharedMsgId =
liftIOEither . withTransaction st $ \db ->
firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
DB.query
db
[sql|
SELECT f.file_id
FROM files f
JOIN chat_items i ON i.chat_item_id = f.chat_item_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ?
|]
(userId, contactId, sharedMsgId)
getGroupFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> Int64 -> UserId -> SharedMsgId -> m Int64
getGroupFileIdBySharedMsgId st userId groupId sharedMsgId =
liftIOEither . withTransaction st $ \db ->
firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
DB.query
db
[sql|
SELECT f.file_id
FROM files f
JOIN chat_items i ON i.chat_item_id = f.chat_item_id
WHERE i.user_id = ? AND i.group_id = ? AND i.shared_msg_id = ?
|]
(userId, groupId, sharedMsgId)
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection
createSndFileConnection_ db userId fileId agentConnId = do
currentTs <- getCurrentTime
@@ -1842,7 +1982,7 @@ createRcvFileTransfer st userId Contact {contactId, localDisplayName = c} f@File
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, FSNew, fileConnReq, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize}
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
createRcvGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> FileInvitation -> Integer -> m RcvFileTransfer
createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize =
@@ -1857,7 +1997,7 @@ createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localD
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, groupMemberId, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize}
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
getRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m RcvFileTransfer
getRcvFileTransfer st userId fileId =
@@ -1870,8 +2010,8 @@ getRcvFileTransfer_ db userId fileId =
<$> DB.query
db
[sql|
SELECT r.file_status, r.file_queue_info, f.file_name,
f.file_size, f.chunk_size, cs.local_display_name, m.local_display_name,
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
f.file_path, c.connection_id, c.agent_conn_id
FROM rcv_files r
JOIN files f USING (file_id)
@@ -1883,16 +2023,16 @@ getRcvFileTransfer_ db userId fileId =
(userId, fileId)
where
rcvFileTransfer ::
[(FileStatus, AConnectionRequestUri, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe AgentConnId)] ->
[(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe AgentConnId)] ->
Either StoreError RcvFileTransfer
rcvFileTransfer [(fileStatus', fileConnReq, fileName, fileSize, chunkSize, contactName_, memberName_, filePath_, connId_, agentConnId_)] =
rcvFileTransfer [(fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_, contactName_, memberName_, filePath_, connId_, agentConnId_)] =
let fileInv = FileInvitation {fileName, fileSize, fileConnReq}
fileInfo = (filePath_, connId_, agentConnId_)
in case contactName_ <|> memberName_ of
Nothing -> Left $ SERcvFileInvalid fileId
Just name ->
case fileStatus' of
FSNew -> Right RcvFileTransfer {fileId, fileInvitation = fileInv, fileStatus = RFSNew, senderDisplayName = name, chunkSize}
FSNew -> Right RcvFileTransfer {fileId, fileInvitation = fileInv, fileStatus = RFSNew, senderDisplayName = name, chunkSize, cancelled, grpMemberId}
FSAccepted -> ft name fileInv RFSAccepted fileInfo
FSConnected -> ft name fileInv RFSConnected fileInfo
FSComplete -> ft name fileInv RFSComplete fileInfo
@@ -1903,6 +2043,7 @@ getRcvFileTransfer_ db userId fileId =
let fileStatus = rfs RcvFileInfo {filePath, connId, agentConnId}
in Right RcvFileTransfer {..}
_ -> Left $ SERcvFileInvalid fileId
cancelled = fromMaybe False cancelled_
rcvFileTransfer _ = Left $ SERcvFileNotFound fileId
acceptRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ConnId -> FilePath -> m ()
@@ -1996,7 +2137,8 @@ getFileTransferProgress st userId fileId =
ft <- ExceptT $ getFileTransfer_ db userId fileId
liftIO $
(ft,) . map fromOnly <$> case ft of
FTSnd _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId)
FTSnd _ [] -> pure [Only 0]
FTSnd _ _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId)
FTRcv _ -> DB.query db "SELECT COUNT(*) FROM rcv_file_chunks WHERE file_id = ? AND chunk_stored = 1" (Only fileId)
getFileTransfer_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError FileTransfer)
@@ -2014,7 +2156,13 @@ getFileTransfer_ db userId fileId =
(userId, fileId)
where
fileTransfer :: [(Maybe Int64, Maybe Int64)] -> IO (Either StoreError FileTransfer)
fileTransfer ((Just _, Nothing) : _) = FTSnd <$$> getSndFileTransfers_ db userId fileId
fileTransfer [(Nothing, Nothing)] = runExceptT $ do
fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId
pure FTSnd {fileTransferMeta, sndFileTransfers = []}
fileTransfer ((Just _, Nothing) : _) = runExceptT $ do
fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId
sndFileTransfers <- ExceptT $ getSndFileTransfers_ db userId fileId
pure FTSnd {fileTransferMeta, sndFileTransfers}
fileTransfer [(Nothing, Just _)] = FTRcv <$$> getRcvFileTransfer_ db userId fileId
fileTransfer _ = pure . Left $ SEFileNotFound fileId
@@ -2043,6 +2191,22 @@ getSndFileTransfers_ db userId fileId =
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
getFileTransferMeta_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError FileTransferMeta)
getFileTransferMeta_ db userId fileId =
firstRow fileTransferMeta (SEFileNotFound fileId) $
DB.query
db
[sql|
SELECT f.file_name, f.file_size, f.chunk_size, f.file_path, f.cancelled
FROM files f
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
where
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe Bool) -> FileTransferMeta
fileTransferMeta (fileName, fileSize, chunkSize, filePath, cancelled_) =
FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, cancelled = fromMaybe False cancelled_}
createNewSndMessage :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage) -> m SndMessage
createNewSndMessage st gVar connOrGroupId mkMessage =
liftIOEither . withTransaction st $ \db ->
@@ -3380,6 +3544,8 @@ data StoreError
| SERcvFileNotFound {fileId :: FileTransferId}
| SEFileNotFound {fileId :: FileTransferId}
| SERcvFileInvalid {fileId :: FileTransferId}
| SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId}
| SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId}
| SEConnectionNotFound {agentConnId :: AgentConnId}
| SEIntroNotFound
| SEUniqueID

2
src/Simplex/Chat/Terminal/Input.hs
View File

@@ -47,7 +47,9 @@ runInputLoop ct cc = forever $ do
Right SendMessage {} -> True
Right SendGroupMessage {} -> True
Right SendFile {} -> True
Right SendFileInv {} -> True
Right SendGroupFile {} -> True
Right SendGroupFileInv {} -> True
Right SendMessageQuote {} -> True
Right SendGroupMessageQuote {} -> True
Right SendMessageBroadcast {} -> True

31
src/Simplex/Chat/Types.hs
View File

@@ -31,7 +31,7 @@ import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok (Ok (Ok))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri, ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId)
import Simplex.Messaging.Agent.Protocol (ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId)
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
@@ -522,7 +522,7 @@ type FileTransferId = Int64
data FileInvitation = FileInvitation
{ fileName :: String,
fileSize :: Integer,
fileConnReq :: AConnectionRequestUri
fileConnReq :: Maybe ConnReqInvitation
}
deriving (Eq, Show, Generic, FromJSON)
@@ -533,7 +533,9 @@ data RcvFileTransfer = RcvFileTransfer
fileInvitation :: FileInvitation,
fileStatus :: RcvFileStatus,
senderDisplayName :: ContactName,
chunkSize :: Integer
chunkSize :: Integer,
cancelled :: Bool,
grpMemberId :: Maybe Int64
}
deriving (Eq, Show, Generic, FromJSON)
@@ -601,13 +603,34 @@ instance FromField AgentInvId where fromField f = AgentInvId <$> fromField f
instance ToField AgentInvId where toField (AgentInvId m) = toField m
data FileTransfer = FTSnd {sndFileTransfers :: [SndFileTransfer]} | FTRcv RcvFileTransfer
data FileTransfer
= FTSnd
{ fileTransferMeta :: FileTransferMeta,
sndFileTransfers :: [SndFileTransfer]
}
| FTRcv {rcvFileTransfer :: RcvFileTransfer}
deriving (Show, Generic)
instance ToJSON FileTransfer where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "FT"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "FT"
data FileTransferMeta = FileTransferMeta
{ fileId :: FileTransferId,
fileName :: String,
filePath :: String,
fileSize :: Integer,
chunkSize :: Integer,
cancelled :: Bool
}
deriving (Eq, Show, Generic)
instance ToJSON FileTransferMeta where toEncoding = J.genericToEncoding J.defaultOptions
fileTransferCancelled :: FileTransfer -> Bool
fileTransferCancelled (FTSnd FileTransferMeta {cancelled} _) = cancelled
fileTransferCancelled (FTRcv RcvFileTransfer {cancelled}) = cancelled
data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Ord, Show)
instance FromField FileStatus where fromField = fromTextField_ decodeText

43
src/Simplex/Chat/View.hs
View File

@@ -93,7 +93,7 @@ responseToView testView = \case
CRRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath ->
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
CRRcvFileAcceptedSndCancelled ft -> viewRcvFileSndCancelled ft
CRSndGroupFileCancelled fts -> viewSndGroupFileCancelled fts
CRSndGroupFileCancelled ftm fts -> viewSndGroupFileCancelled ftm fts
CRRcvFileCancelled ft -> receivingFile_ "cancelled" ft
CRUserProfileUpdated p p' -> viewUserProfileUpdated p p'
CRContactUpdated c c' -> viewContactUpdated c c'
@@ -488,11 +488,11 @@ viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
[ttyContact c <> " cancelled sending " <> rcvFile ft]
viewSndGroupFileCancelled :: [SndFileTransfer] -> [StyledString]
viewSndGroupFileCancelled fts =
viewSndGroupFileCancelled :: FileTransferMeta -> [SndFileTransfer] -> [StyledString]
viewSndGroupFileCancelled FileTransferMeta {fileId, fileName} fts =
case filter (\SndFileTransfer {fileStatus = s} -> s /= FSCancelled && s /= FSComplete) fts of
[] -> ["sending file can't be cancelled"]
ts@(ft : _) -> ["cancelled sending " <> sndFile ft <> " to " <> listMembers ts]
[] -> ["cancelled sending " <> fileTransferStr fileId fileName]
ts -> ["cancelled sending " <> fileTransferStr fileId fileName <> " to " <> listRecipients ts]
sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString]
sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
@@ -533,24 +533,20 @@ fileTransferStr :: Int64 -> String -> StyledString
fileTransferStr fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath fileName <> ")"
viewFileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
viewFileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) =
["sending " <> sndFile ft <> " " <> sndStatus]
where
sndStatus = case fileStatus of
FSNew -> "not accepted yet"
FSAccepted -> "just started"
FSConnected -> "progress " <> fileProgress chunksNum chunkSize fileSize
FSComplete -> "complete"
FSCancelled -> "cancelled"
viewFileTransferStatus (FTSnd [], _) = ["no file transfers (empty group)"]
viewFileTransferStatus (FTSnd fts@(ft : _), chunksNum) =
case concatMap membersTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of
[membersStatus] -> ["sending " <> sndFile ft <> " " <> membersStatus]
membersStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) membersStatuses
viewFileTransferStatus (FTSnd FileTransferMeta {fileId, fileName, cancelled} [], _) =
[ "sending " <> fileTransferStr fileId fileName <> ": no file transfers"
<> if cancelled then ", file transfer cancelled" else ""
]
viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksNum) =
recipientStatuses <> ["file transfer cancelled" | cancelled]
where
recipientStatuses =
case concatMap recipientsTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
fs = fileStatus :: SndFileTransfer -> FileStatus
membersTransferStatus [] = []
membersTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listMembers ts]
recipientsTransferStatus [] = []
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
where
sndStatus = case fileStatus of
FSNew -> "not accepted"
@@ -568,8 +564,8 @@ viewFileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileI
RFSComplete RcvFileInfo {filePath} -> "complete, path: " <> plain filePath
RFSCancelled RcvFileInfo {filePath} -> "cancelled, received part path: " <> plain filePath
listMembers :: [SndFileTransfer] -> StyledString
listMembers = mconcat . intersperse ", " . map (ttyContact . recipientDisplayName)
listRecipients :: [SndFileTransfer] -> StyledString
listRecipients = mconcat . intersperse ", " . map (ttyContact . recipientDisplayName)
fileProgress :: [Integer] -> Integer -> Integer -> StyledString
fileProgress chunksNum chunkSize fileSize =
@@ -622,6 +618,7 @@ viewChatError = \case
SEDuplicateContactLink -> ["you already have chat address, to show: " <> highlight' "/sa"]
SEUserContactLinkNotFound -> ["no chat address, to create: " <> highlight' "/ad"]
SEContactRequestNotFoundByName c -> ["no contact request from " <> ttyContact c]
SEFileIdNotFoundBySharedMsgId _ -> [] -- recipient tried to accept cancelled file
SEConnectionNotFound _ -> [] -- TODO mutes delete group error, but also mutes any error from getConnectionEntity
SEQuotedChatItemNotFound -> ["message not found - reply is not sent"]
e -> ["chat db error: " <> sShow e]

1
tests/ChatClient.hs
View File

@@ -135,6 +135,7 @@ getTermLine :: TestCC -> IO String
getTermLine = atomically . readTQueue . termQ
-- Use code below to echo virtual terminal
-- getTermLine :: TestCC -> IO String
-- getTermLine cc = do
-- s <- atomically . readTQueue $ termQ cc
-- name <- userName cc

153
tests/ChatTests.hs
View File

@@ -57,6 +57,12 @@ chatTests = do
it "sender cancelled file transfer" testFileSndCancel
it "recipient cancelled file transfer" testFileRcvCancel
it "send and receive file to group" testGroupFileTransfer
describe "sending and receiving files v2" $ do
it "send and receive file" testFileTransferV2
it "send and receive a small file" testSmallFileTransferV2
it "sender cancelled file transfer" testFileSndCancelV2
it "recipient cancelled file transfer" testFileRcvCancelV2
it "send and receive file to group" testGroupFileTransferV2
describe "user contact link" $ do
it "create and connect via contact link" testUserContactLink
it "auto accept contact requests" testUserContactLinkAutoAccept
@@ -995,7 +1001,8 @@ testFileSndCancel =
[ do
alice <## "cancelled sending file 1 (test.jpg) to bob"
alice ##> "/fs 1"
alice <## "sending file 1 (test.jpg) cancelled",
alice <## "sending file 1 (test.jpg) cancelled: bob"
alice <## "file transfer cancelled",
do
bob <## "alice cancelled sending file 1 (test.jpg)"
bob ##> "/fs 1"
@@ -1021,7 +1028,7 @@ testFileRcvCancel =
do
alice <## "bob cancelled receiving file 1 (test.jpg)"
alice ##> "/fs 1"
alice <## "sending file 1 (test.jpg) cancelled"
alice <## "sending file 1 (test.jpg) cancelled: bob"
]
checkPartialTransfer
where
@@ -1070,6 +1077,135 @@ testGroupFileTransfer =
cath <## "completed receiving file 1 (test.jpg) from alice"
]
testFileTransferV2 :: IO ()
testFileTransferV2 =
testChat2 aliceProfile bobProfile $
\alice bob -> do
connectUsers alice bob
startFileTransferV2 alice bob
concurrentlyN_
[ do
bob #> "@alice receiving here..."
bob <## "completed receiving file 1 (test.jpg) from alice",
do
alice <# "bob> receiving here..."
alice <## "completed sending file 1 (test.jpg) to bob"
]
src <- B.readFile "./tests/fixtures/test.jpg"
dest <- B.readFile "./tests/tmp/test.jpg"
dest `shouldBe` src
testSmallFileTransferV2 :: IO ()
testSmallFileTransferV2 =
testChat2 aliceProfile bobProfile $
\alice bob -> do
connectUsers alice bob
alice `send` "/f_v2 @bob ./tests/fixtures/test.txt"
alice <# "/f @bob ./tests/fixtures/test.txt"
alice <## "use /fc 1 to cancel sending"
bob <# "alice> sends file test.txt (11 bytes / 11 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
bob ##> "/fr 1 ./tests/tmp"
bob <## "saving file 1 from alice to ./tests/tmp/test.txt"
concurrentlyN_
[ do
bob <## "started receiving file 1 (test.txt) from alice"
bob <## "completed receiving file 1 (test.txt) from alice",
do
alice <## "started sending file 1 (test.txt) to bob"
alice <## "completed sending file 1 (test.txt) to bob"
]
src <- B.readFile "./tests/fixtures/test.txt"
dest <- B.readFile "./tests/tmp/test.txt"
dest `shouldBe` src
testFileSndCancelV2 :: IO ()
testFileSndCancelV2 =
testChat2 aliceProfile bobProfile $
\alice bob -> do
connectUsers alice bob
startFileTransferV2 alice bob
alice ##> "/fc 1"
concurrentlyN_
[ do
alice <## "cancelled sending file 1 (test.jpg) to bob"
alice ##> "/fs 1"
alice <## "sending file 1 (test.jpg) cancelled: bob"
alice <## "file transfer cancelled",
do
bob <## "alice cancelled sending file 1 (test.jpg)"
bob ##> "/fs 1"
bob <## "receiving file 1 (test.jpg) cancelled, received part path: ./tests/tmp/test.jpg"
]
checkPartialTransfer
testFileRcvCancelV2 :: IO ()
testFileRcvCancelV2 =
testChat2 aliceProfile bobProfile $
\alice bob -> do
connectUsers alice bob
startFileTransferV2 alice bob
bob ##> "/fs 1"
getTermLine bob >>= (`shouldStartWith` "receiving file 1 (test.jpg) progress")
waitFileExists "./tests/tmp/test.jpg"
bob ##> "/fc 1"
concurrentlyN_
[ do
bob <## "cancelled receiving file 1 (test.jpg) from alice"
bob ##> "/fs 1"
bob <## "receiving file 1 (test.jpg) cancelled, received part path: ./tests/tmp/test.jpg",
do
alice <## "bob cancelled receiving file 1 (test.jpg)"
alice ##> "/fs 1"
alice <## "sending file 1 (test.jpg) cancelled: bob"
]
checkPartialTransfer
where
waitFileExists f = unlessM (doesFileExist f) $ waitFileExists f
testGroupFileTransferV2 :: IO ()
testGroupFileTransferV2 =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
alice `send` "/f_v2 #team ./tests/fixtures/test.jpg"
alice <# "/f #team ./tests/fixtures/test.jpg"
alice <## "use /fc 1 to cancel sending"
concurrentlyN_
[ do
bob <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it",
do
cath <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
cath <## "use /fr 1 [<dir>/ | <path>] to receive it"
]
alice ##> "/fs 1"
getTermLine alice >>= (`shouldStartWith` "sending file 1 (test.jpg): no file transfers")
bob ##> "/fr 1 ./tests/tmp/"
bob <## "saving file 1 from alice to ./tests/tmp/test.jpg"
concurrentlyN_
[ do
alice <## "started sending file 1 (test.jpg) to bob"
alice <## "completed sending file 1 (test.jpg) to bob"
alice ##> "/fs 1"
alice <## "sending file 1 (test.jpg) complete: bob",
do
bob <## "started receiving file 1 (test.jpg) from alice"
bob <## "completed receiving file 1 (test.jpg) from alice"
]
cath ##> "/fr 1 ./tests/tmp/"
cath <## "saving file 1 from alice to ./tests/tmp/test_1.jpg"
concurrentlyN_
[ do
alice <## "started sending file 1 (test.jpg) to cath"
alice <## "completed sending file 1 (test.jpg) to cath"
alice ##> "/fs 1"
getTermLine alice >>= (`shouldStartWith` "sending file 1 (test.jpg) complete"),
do
cath <## "started receiving file 1 (test.jpg) from alice"
cath <## "completed receiving file 1 (test.jpg) from alice"
]
testUserContactLink :: IO ()
testUserContactLink = testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
@@ -1324,6 +1460,19 @@ startFileTransfer alice bob = do
(bob <## "started receiving file 1 (test.jpg) from alice")
(alice <## "started sending file 1 (test.jpg) to bob")
startFileTransferV2 :: TestCC -> TestCC -> IO ()
startFileTransferV2 alice bob = do
alice `send` "/f_v2 @bob ./tests/fixtures/test.jpg"
alice <# "/f @bob ./tests/fixtures/test.jpg"
alice <## "use /fc 1 to cancel sending"
bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
bob ##> "/fr 1 ./tests/tmp"
bob <## "saving file 1 from alice to ./tests/tmp/test.jpg"
concurrently_
(bob <## "started receiving file 1 (test.jpg) from alice")
(alice <## "started sending file 1 (test.jpg) to bob")
checkPartialTransfer :: IO ()
checkPartialTransfer = do
src <- B.readFile "./tests/fixtures/test.jpg"

17
tests/ProtocolTests.hs
View File

@@ -109,10 +109,25 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
it "x.msg.new" $
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}"
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew . MCForward $ MCText "hello")
it "x.msg.update" $
"{\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
#==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello")
it "x.msg.del" $
"{\"event\":\"x.msg.del\",\"params\":{\"msgId\":\"AQIDBA==\"}}"
#==# XMsgDel (SharedMsgId "\1\2\3\4")
it "x.msg.deleted" $
"{\"event\":\"x.msg.deleted\",\"params\":{}}"
#==# XMsgDeleted
it "x.file" $
"{\"event\":\"x.file\",\"params\":{\"file\":{\"fileConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%3D&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
#==# XFile FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = ACR SCMInvitation testConnReq}
#==# XFile FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Just testConnReq}
it "x.file without file invitation" $
"{\"event\":\"x.file\",\"params\":{\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
#==# XFile FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing}
it "x.file.acpt" $ "{\"event\":\"x.file.acpt\",\"params\":{\"fileName\":\"photo.jpg\"}}" #==# XFileAcpt "photo.jpg"
it "x.file.acpt.inv" $
"{\"event\":\"x.file.acpt.inv\",\"params\":{\"msgId\":\"AQIDBA==\",\"fileName\":\"photo.jpg\",\"fileConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%3D&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}"
#==# XFileAcptInv (SharedMsgId "\1\2\3\4") testConnReq "photo.jpg"
it "x.info" $ "{\"event\":\"x.info\",\"params\":{\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}}" #==# XInfo testProfile
it "x.info" $ "{\"event\":\"x.info\",\"params\":{\"profile\":{\"fullName\":\"\",\"displayName\":\"alice\"}}}" #==# XInfo Profile {displayName = "alice", fullName = "", image = Nothing}
it "x.contact with xContactId" $