From a5ca2c216345e2bd7b4d0bd5afcb342073bdf66b Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Tue, 5 Apr 2022 10:01:08 +0400 Subject: [PATCH] core: new files protocol (#492) --- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 147 ++++++++++--- src/Simplex/Chat/Controller.hs | 4 +- .../Migrations/M20220404_files_cancelled.hs | 12 ++ src/Simplex/Chat/Protocol.hs | 16 +- src/Simplex/Chat/Store.hs | 194 ++++++++++++++++-- src/Simplex/Chat/Terminal/Input.hs | 2 + src/Simplex/Chat/Types.hs | 31 ++- src/Simplex/Chat/View.hs | 43 ++-- tests/ChatClient.hs | 1 + tests/ChatTests.hs | 153 +++++++++++++- tests/ProtocolTests.hs | 17 +- 12 files changed, 551 insertions(+), 70 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20220404_files_cancelled.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 884a7693c8..6b91a1e3b7 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 8464195b40..f620e034fb 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 99a9fb1f72..00faac4349 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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} diff --git a/src/Simplex/Chat/Migrations/M20220404_files_cancelled.hs b/src/Simplex/Chat/Migrations/M20220404_files_cancelled.hs new file mode 100644 index 0000000000..c1187a7ec3 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20220404_files_cancelled.hs @@ -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 +|] diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index dfa4497b9d..5dfea4c6b0 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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] diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index df9fb5b09c..c4f25e1540 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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 diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index cc7aa47cf5..6b215bd344 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -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 diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index a25a674e6a..03eda5f6f5 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index d6f230b4e2..5ef9be10c3 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index b27780430d..42cc82b908 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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 diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 7a3492af27..dd450b132a 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -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 [/ | ] 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 [/ | ] to receive it", + do + cath <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)" + cath <## "use /fr 1 [/ | ] 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 [/ | ] 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" diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 344c7e0bb7..bd898a00f4 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -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" $