From 28103825fa97ef565fb0f8de829fbe26257e3094 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 5 Sep 2021 14:08:29 +0100 Subject: [PATCH] send files to groups (#97) * add sender/recipient info to file types * send file to group (WIP) * send file to group, test * show file status when sending file to group * notification when cancelled sending to group, remove chunks when file complete or canceleld --- src/Simplex/Chat.hs | 106 ++++++++++++++------- src/Simplex/Chat/Store.hs | 133 ++++++++++++++++++--------- src/Simplex/Chat/Types.hs | 5 +- src/Simplex/Chat/View.hs | 188 +++++++++++++++++++++++++------------- stack.yaml | 2 +- tests/ChatTests.hs | 77 ++++++++++++---- 6 files changed, 351 insertions(+), 160 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 8d334181f..5427f7af9 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -51,7 +51,7 @@ import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Parsers (parseAll) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Util (bshow, raceAny_) +import Simplex.Messaging.Util (bshow, raceAny_, tryError) import System.Exit (exitFailure, exitSuccess) import System.FilePath (combine, splitExtensions, takeFileName) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout) @@ -163,6 +163,8 @@ inputSubscriber = do case cmd of SendMessage c msg -> showSentMessage c msg SendGroupMessage g msg -> showSentGroupMessage g msg + SendFile c f -> showSentFileInvitation c f + SendGroupFile g f -> showSentGroupFileInvitation g f _ -> printToView [plain s] user <- readTVarIO =<< asks currentUser withAgentLock a . withLock l . void . runExceptT $ @@ -264,33 +266,47 @@ processChatCommand user@User {userId, profile} = \case sendGroupMessage members msgEvent setActive $ ActiveG gName SendFile cName f -> do - unlessM (doesFileExist f) . chatError $ CEFileNotFound f - contact@Contact {contactId} <- withStore $ \st -> getContact st userId cName + (fileSize, chSize) <- checkSndFile f + contact <- withStore $ \st -> getContact st userId cName (agentConnId, fileQInfo) <- withAgent createConnection - fileSize <- getFileSize f let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileQInfo} - chSize <- asks $ fileChunkSize . config - ft <- withStore $ \st -> createSndFileTransfer st userId contactId f fileInv agentConnId chSize + SndFileTransfer {fileId} <- withStore $ \st -> + createSndFileTransfer st userId contact f fileInv agentConnId chSize sendDirectMessage (contactConnId contact) $ XFile fileInv - showSentFileInvitation cName ft + showSentFileInfo fileId setActive $ ActiveC cName - SendGroupFile _gName _file -> pure () + SendGroupFile gName f -> do + (fileSize, chSize) <- checkSndFile f + group@Group {members, membership} <- withStore $ \st -> getGroup st user gName + unless (memberActive membership) $ chatError CEGroupMemberUserRemoved + let fileName = takeFileName f + ms <- forM (filter memberActive members) $ \m -> do + (connId, fileQInfo) <- withAgent createConnection + pure (m, connId, FileInvitation {fileName, fileSize, fileQInfo}) + fileId <- withStore $ \st -> createSndGroupFileTransfer st userId group ms f fileSize chSize + forM_ ms $ \(m, _, fileInv) -> + traverse (`sendDirectMessage` XFile fileInv) $ memberConnId m + showSentFileInfo fileId + setActive $ ActiveG gName ReceiveFile fileId filePath_ -> do - RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileQInfo}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId + ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileQInfo}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId unless (fileStatus == RFSNew) . chatError $ CEFileAlreadyReceiving fileName - agentConnId <- withAgent $ \a -> joinConnection a fileQInfo . directMessage $ XFileAcpt fileName - filePath <- getRcvFilePath fileId filePath_ fileName - withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath - -- TODO include file sender in the message - showRcvFileAccepted fileId filePath + tryError (withAgent $ \a -> joinConnection a fileQInfo . directMessage $ XFileAcpt fileName) >>= \case + Right agentConnId -> do + filePath <- getRcvFilePath fileId filePath_ fileName + withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath + showRcvFileAccepted ft filePath + Left (ChatErrorAgent (SMP SMP.AUTH)) -> showRcvFileSndCancelled ft + Left (ChatErrorAgent (CONN DUPLICATE)) -> showRcvFileSndCancelled ft + Left e -> throwError e CancelFile fileId -> withStore (\st -> getFileTransfer st userId fileId) >>= \case FTSnd fts -> do - mapM_ cancelSndFileTransfer fts - showSndFileCancelled fileId + forM_ fts $ \ft -> cancelSndFileTransfer ft + showSndGroupFileCancelled fts FTRcv ft -> do cancelRcvFileTransfer ft - showRcvFileCancelled fileId + showRcvFileCancelled ft FileStatus fileId -> withStore (\st -> getFileTransferProgress st userId fileId) >>= showFileTransferStatus UpdateProfile p -> unless (p == profile) $ do @@ -306,6 +322,10 @@ processChatCommand user@User {userId, profile} = \case contactMember Contact {contactId} = find $ \GroupMember {memberContactId = cId, memberStatus = s} -> cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft + checkSndFile :: FilePath -> m (Integer, Integer) + checkSndFile f = do + unlessM (doesFileExist f) . chatError $ CEFileNotFound f + (,) <$> getFileSize f <*> asks (fileChunkSize . config) getRcvFilePath :: Int64 -> Maybe FilePath -> String -> m FilePath getRcvFilePath fileId filePath fileName = case filePath of Nothing -> do @@ -449,7 +469,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody case chatMsgEvent of XMsgNew (MsgContent MTText [] body) -> newTextMessage c meta $ find (isSimplexContentType XCText) body - XFile fInv -> processFileInvitation ct fInv + XFile fInv -> processFileInvitation ct meta fInv XInfo p -> xInfo ct p XGrpInv gInv -> processGroupInvitation ct gInv XInfoProbe probe -> xInfoProbe ct probe @@ -567,6 +587,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do case chatMsgEvent of XMsgNew (MsgContent MTText [] body) -> newGroupTextMessage gName m meta $ find (isSimplexContentType XCText) body + XFile fInv -> processGroupFileInvitation gName m meta fInv XGrpMemNew memInfo -> xGrpMemNew gName m memInfo XGrpMemIntro memInfo -> xGrpMemIntro gName m memInfo XGrpMemInv memId introInv -> xGrpMemInv gName m memId introInv @@ -591,7 +612,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do _ -> messageError "REQ from file connection must have x.file.acpt" CON -> do withStore $ \st -> updateSndFileStatus st ft FSConnected - showSndFileStart fileId + showSndFileStart ft sendFileChunk ft SENT msgId -> do withStore $ \st -> updateSndFileChunkSent st ft msgId @@ -599,7 +620,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do MERR _ err -> do cancelSndFileTransfer ft case err of - SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ showSndFileRcvCancelled fileId + SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ showSndFileRcvCancelled ft _ -> chatError $ CEFileSend fileId err MSG meta _ -> withAckMessage agentConnId meta $ pure () @@ -610,12 +631,12 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do case agentMsg of CON -> do withStore $ \st -> updateRcvFileStatus st ft FSConnected - showRcvFileStart fileId + showRcvFileStart ft MSG meta@MsgMeta {recipient = (msgId, _), integrity} msgBody -> withAckMessage agentConnId meta $ do parseFileChunk msgBody >>= \case (0, _) -> do cancelRcvFileTransfer ft - showRcvFileSndCancelled fileId + showRcvFileSndCancelled ft (chunkNo, chunk) -> do case integrity of MsgOk -> pure () @@ -632,8 +653,10 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do then badRcvFileChunk ft "incorrect chunk size" else do appendFileChunk ft chunkNo chunk - withStore $ \st -> updateRcvFileStatus st ft FSComplete - showRcvFileComplete fileId + withStore $ \st -> do + updateRcvFileStatus st ft FSComplete + deleteRcvFileChunks st ft + showRcvFileComplete ft closeFileHandle fileId rcvFiles withAgent (`deleteConnection` agentConnId) RcvChunkDuplicate -> pure () @@ -681,7 +704,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do newTextMessage c meta = \case Just MsgContentBody {contentData = bs} -> do let text = safeDecodeUtf8 bs - showReceivedMessage c (snd $ broker meta) text (integrity meta) + showReceivedMessage c (snd $ broker meta) (msgPlain text) (integrity meta) showToast (c <> "> ") text setActive $ ActiveC c _ -> messageError "x.msg.new: no expected message body" @@ -690,19 +713,26 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do newGroupTextMessage gName GroupMember {localDisplayName = c} meta = \case Just MsgContentBody {contentData = bs} -> do let text = safeDecodeUtf8 bs - showReceivedGroupMessage gName c (snd $ broker meta) text (integrity meta) + showReceivedGroupMessage gName c (snd $ broker meta) (msgPlain text) (integrity meta) showToast ("#" <> gName <> " " <> c <> "> ") text setActive $ ActiveG gName _ -> messageError "x.msg.new: no expected message body" - processFileInvitation :: Contact -> FileInvitation -> m () - processFileInvitation Contact {contactId, localDisplayName = c} fInv = do + processFileInvitation :: Contact -> MsgMeta -> FileInvitation -> m () + processFileInvitation contact@Contact {localDisplayName = c} meta fInv = do -- TODO chunk size has to be sent as part of invitation chSize <- asks $ fileChunkSize . config - ft <- withStore $ \st -> createRcvFileTransfer st userId contactId fInv chSize - showReceivedFileInvitation c ft + ft <- withStore $ \st -> createRcvFileTransfer st userId contact fInv chSize + showReceivedMessage c (snd $ broker meta) (receivedFileInvitation ft) (integrity meta) setActive $ ActiveC c + processGroupFileInvitation :: GroupName -> GroupMember -> MsgMeta -> FileInvitation -> m () + processGroupFileInvitation gName m@GroupMember {localDisplayName = c} meta fInv = do + chSize <- asks $ fileChunkSize . config + ft <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize + showReceivedGroupMessage gName c (snd $ broker meta) (receivedFileInvitation ft) (integrity meta) + setActive $ ActiveG gName + processGroupInvitation :: Contact -> GroupInvitation -> m () processGroupInvitation ct@Contact {localDisplayName} inv@(GroupInvitation (fromMemId, fromRole) (memId, memRole) _ _) = do when (fromRole < GRAdmin || fromRole < memRole) $ chatError (CEGroupContactRole localDisplayName) @@ -852,8 +882,10 @@ sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} = withStore (`createSndFileChunk` ft) >>= \case Just chunkNo -> sendFileChunkNo ft chunkNo Nothing -> do - withStore $ \st -> updateSndFileStatus st ft FSComplete - showSndFileComplete fileId + withStore $ \st -> do + updateSndFileStatus st ft FSComplete + deleteSndFileChunks st ft + showSndFileComplete ft closeFileHandle fileId sndFiles withAgent (`deleteConnection` agentConnId) @@ -915,7 +947,9 @@ isFileActive fileId files = do cancelRcvFileTransfer :: ChatMonad m => RcvFileTransfer -> m () cancelRcvFileTransfer ft@RcvFileTransfer {fileId, fileStatus} = do closeFileHandle fileId rcvFiles - withStore $ \st -> updateRcvFileStatus st ft FSCancelled + withStore $ \st -> do + updateRcvFileStatus st ft FSCancelled + deleteRcvFileChunks st ft case fileStatus of RFSAccepted RcvFileInfo {agentConnId} -> withAgent (`suspendConnection` agentConnId) RFSConnected RcvFileInfo {agentConnId} -> withAgent (`suspendConnection` agentConnId) @@ -924,9 +958,11 @@ cancelRcvFileTransfer ft@RcvFileTransfer {fileId, fileStatus} = do cancelSndFileTransfer :: ChatMonad m => SndFileTransfer -> m () cancelSndFileTransfer ft@SndFileTransfer {agentConnId, fileStatus} = unless (fileStatus == FSCancelled || fileStatus == FSComplete) $ do - withStore $ \st -> updateSndFileStatus st ft FSCancelled + withStore $ \st -> do + updateSndFileStatus st ft FSCancelled + deleteSndFileChunks st ft withAgent $ \a -> do - void $ sendMessage a agentConnId "0 " + void (sendMessage a agentConnId "0 ") `catchError` \_ -> pure () suspendConnection a agentConnId closeFileHandle :: ChatMonad m => Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> m () diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 4896ea56e..d63c31df0 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -63,21 +63,26 @@ module Simplex.Chat.Store matchSentProbe, mergeContactRecords, createSndFileTransfer, + createSndGroupFileTransfer, updateSndFileStatus, createSndFileChunk, updateSndFileChunkMsg, updateSndFileChunkSent, + deleteSndFileChunks, createRcvFileTransfer, + createRcvGroupFileTransfer, getRcvFileTransfer, acceptRcvFileTransfer, updateRcvFileStatus, createRcvFileChunk, updatedRcvFileChunkStored, + deleteRcvFileChunks, getFileTransfer, getFileTransferProgress, ) where +import Control.Applicative ((<|>)) import Control.Concurrent.STM (stateTVar) import Control.Exception (Exception) import qualified Control.Exception as E @@ -107,7 +112,7 @@ import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>)) -import System.FilePath (takeBaseName, takeExtension) +import System.FilePath (takeBaseName, takeExtension, takeFileName) import UnliftIO.STM -- | The list of migrations in ascending order by date @@ -635,7 +640,7 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId = [sql| SELECT g.local_display_name, - m.group_member_id, m.member_id, m.member_role, m.member_category, m.member_status, + 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 FROM group_members m JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id @@ -655,14 +660,19 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId = <$> DB.query db [sql| - SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path + SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, cs.local_display_name, m.local_display_name 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) WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ? |] (userId, fileId, connId) - sndFileTransfer_ :: Int64 -> Int64 -> [(FileStatus, String, Integer, Integer, FilePath)] -> Either StoreError SndFileTransfer - sndFileTransfer_ fileId connId [(fileStatus, fileName, fileSize, chunkSize, filePath)] = Right SndFileTransfer {..} + sndFileTransfer_ :: Int64 -> Int64 -> [(FileStatus, String, Integer, Integer, FilePath, Maybe ContactName, Maybe ContactName)] -> Either StoreError SndFileTransfer + sndFileTransfer_ fileId connId [(fileStatus, fileName, fileSize, chunkSize, filePath, contactName_, memberName_)] = + case contactName_ <|> memberName_ of + Just recipientDisplayName -> Right SndFileTransfer {..} + Nothing -> Left $ SESndFileInvalid fileId sndFileTransfer_ fileId _ _ = Left $ SESndFileNotFound fileId updateConnectionStatus :: MonadUnliftIO m => SQLiteStore -> Connection -> ConnStatus -> m () @@ -738,7 +748,7 @@ getGroup_ db User {userId, userContactId} localDisplayName = do db [sql| SELECT - m.group_member_id, m.member_id, m.member_role, m.member_category, m.member_status, + 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, 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.created_at @@ -790,13 +800,14 @@ getGroupInvitation st user localDisplayName = findFromContact (IBContact contactId) = find ((== Just contactId) . memberContactId) findFromContact _ = const Nothing -type GroupMemberRow = (Int64, ByteString, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text) +type GroupMemberRow = (Int64, Int64, ByteString, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text) toGroupMember :: Int64 -> GroupMemberRow -> GroupMember -toGroupMember userContactId (groupMemberId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName) = +toGroupMember userContactId (groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName) = let memberProfile = Profile {displayName, fullName} invitedBy = toInvitedBy userContactId invitedById - in GroupMember {groupMemberId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile, memberContactId, activeConn = Nothing} + activeConn = Nothing + in GroupMember {..} createContactGroupMember :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> Int64 -> Contact -> GroupMemberRole -> ConnId -> m GroupMember createContactGroupMember st gVar user groupId contact memberRole agentConnId = @@ -861,6 +872,7 @@ createNewMember_ memProfileId } = do let invitedById = fromInvitedBy userContactId invitedBy + activeConn = Nothing DB.execute db [sql| @@ -870,19 +882,7 @@ createNewMember_ |] (groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memProfileId, memberContactId) groupMemberId <- insertedRowId db - pure $ - GroupMember - { groupMemberId, - memberId, - memberRole, - memberStatus, - memberCategory, - invitedBy, - memberProfile, - localDisplayName, - memberContactId, - activeConn = Nothing - } + pure GroupMember {..} deleteGroupMemberConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> m () deleteGroupMemberConnection st userId m = @@ -982,11 +982,11 @@ getIntroduction_ db reMember toMember = ExceptT $ do toIntro _ = Left SEIntroNotFound createIntroReMember :: StoreMonad m => SQLiteStore -> User -> Group -> GroupMember -> MemberInfo -> ConnId -> ConnId -> m GroupMember -createIntroReMember st user@User {userId} group _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId = +createIntroReMember st user@User {userId} group@Group {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId = liftIOEither . withTransaction st $ \db -> runExceptT $ do let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn Connection {connId = directConnId} <- liftIO $ createConnection_ db userId directAgentConnId memberContactId cLevel - (localDisplayName, contactId, memProfileId) <- ExceptT $ createContact_ db userId directConnId memberProfile (Just $ groupId group) + (localDisplayName, contactId, memProfileId) <- ExceptT $ createContact_ db userId directConnId memberProfile (Just groupId) liftIO $ do let newMember = NewGroupMember @@ -1059,7 +1059,8 @@ createContactMember_ db User {userId, userContactId} groupId userOrContact (memb let memberProfile = profile' userOrContact memberContactId = Just $ contactId' userOrContact localDisplayName = localDisplayName' userOrContact - pure GroupMember {groupMemberId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile, memberContactId, activeConn = Nothing} + activeConn = Nothing + pure GroupMember {..} where insertMember_ = DB.executeNamed @@ -1094,7 +1095,7 @@ getViaGroupMember st User {userId, userContactId} Contact {contactId} = [sql| SELECT g.local_display_name, - m.group_member_id, m.member_id, m.member_role, m.member_category, m.member_status, + 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, 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.created_at @@ -1148,8 +1149,8 @@ getViaGroupContact st User {userId} GroupMember {groupMemberId} = in Just Contact {contactId, localDisplayName, profile, activeConn, viaGroup} toContact _ = Nothing -createSndFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> FilePath -> FileInvitation -> ConnId -> Integer -> m SndFileTransfer -createSndFileTransfer st userId contactId filePath FileInvitation {fileName, fileSize} agentConnId chunkSize = +createSndFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FilePath -> FileInvitation -> ConnId -> Integer -> m SndFileTransfer +createSndFileTransfer st userId Contact {contactId, localDisplayName = recipientDisplayName} filePath FileInvitation {fileName, fileSize} agentConnId chunkSize = liftIO . withTransaction st $ \db -> do DB.execute db "INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size) VALUES (?, ?, ?, ?, ?, ?)" (userId, contactId, fileName, filePath, fileSize, chunkSize) fileId <- insertedRowId db @@ -1158,6 +1159,17 @@ createSndFileTransfer st userId contactId filePath FileInvitation {fileName, fil DB.execute db "INSERT INTO snd_files (file_id, file_status, connection_id) VALUES (?, ?, ?)" (fileId, fileStatus, connId) pure SndFileTransfer {..} +createSndGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Group -> [(GroupMember, ConnId, FileInvitation)] -> FilePath -> Integer -> Integer -> m Int64 +createSndGroupFileTransfer st userId Group {groupId} ms filePath fileSize chunkSize = + liftIO . withTransaction st $ \db -> do + let fileName = takeFileName filePath + DB.execute db "INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size) VALUES (?, ?, ?, ?, ?, ?)" (userId, groupId, fileName, filePath, fileSize, chunkSize) + fileId <- insertedRowId db + forM_ ms $ \(GroupMember {groupMemberId}, agentConnId, _) -> do + Connection {connId} <- createSndFileConnection_ db userId fileId agentConnId + DB.execute db "INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id) VALUES (?, ?, ?, ?)" (fileId, FSNew, connId, groupMemberId) + pure fileId + createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection createSndFileConnection_ db userId fileId agentConnId = do createdAt <- getCurrentTime @@ -1218,13 +1230,26 @@ updateSndFileChunkSent st SndFileTransfer {fileId, connId} msgId = |] (fileId, connId, msgId) -createRcvFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> FileInvitation -> Integer -> m RcvFileTransfer -createRcvFileTransfer st userId contactId f@FileInvitation {fileName, fileSize, fileQInfo} chunkSize = +deleteSndFileChunks :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> m () +deleteSndFileChunks st SndFileTransfer {fileId, connId} = + liftIO . withTransaction st $ \db -> + DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId) + +createRcvFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FileInvitation -> Integer -> m RcvFileTransfer +createRcvFileTransfer st userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileQInfo} chunkSize = liftIO . withTransaction st $ \db -> do DB.execute db "INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size) VALUES (?, ?, ?, ?, ?)" (userId, contactId, fileName, fileSize, chunkSize) fileId <- insertedRowId db DB.execute db "INSERT INTO rcv_files (file_id, file_status, file_queue_info) VALUES (?, ?, ?)" (fileId, FSNew, fileQInfo) - pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, chunkSize} + pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize} + +createRcvGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> FileInvitation -> Integer -> m RcvFileTransfer +createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileQInfo} chunkSize = + liftIO . withTransaction st $ \db -> do + DB.execute db "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size) VALUES (?, ?, ?, ?, ?)" (userId, groupId, fileName, fileSize, chunkSize) + fileId <- insertedRowId db + DB.execute db "INSERT INTO rcv_files (file_id, file_status, file_queue_info, group_member_id) VALUES (?, ?, ?, ?)" (fileId, FSNew, fileQInfo, groupMemberId) + pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize} getRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m RcvFileTransfer getRcvFileTransfer st userId fileId = @@ -1238,28 +1263,34 @@ getRcvFileTransfer_ db userId fileId = db [sql| SELECT r.file_status, r.file_queue_info, f.file_name, - f.file_size, f.chunk_size, f.file_path, c.connection_id, c.agent_conn_id + f.file_size, f.chunk_size, 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) LEFT JOIN connections c ON r.file_id = c.rcv_file_id + LEFT JOIN contacts cs USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) WHERE f.user_id = ? AND f.file_id = ? |] (userId, fileId) where rcvFileTransfer :: - [(FileStatus, SMPQueueInfo, String, Integer, Integer, Maybe FilePath, Maybe Int64, Maybe ConnId)] -> + [(FileStatus, SMPQueueInfo, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe ConnId)] -> Either StoreError RcvFileTransfer - rcvFileTransfer [(fileStatus', fileQInfo, fileName, fileSize, chunkSize, filePath_, connId_, agentConnId_)] = + rcvFileTransfer [(fileStatus', fileQInfo, fileName, fileSize, chunkSize, contactName_, memberName_, filePath_, connId_, agentConnId_)] = let fileInv = FileInvitation {fileName, fileSize, fileQInfo} fileInfo = (filePath_, connId_, agentConnId_) - in case fileStatus' of - FSNew -> Right RcvFileTransfer {fileId, fileInvitation = fileInv, fileStatus = RFSNew, chunkSize} - FSAccepted -> ft fileInv RFSAccepted fileInfo - FSConnected -> ft fileInv RFSConnected fileInfo - FSComplete -> ft fileInv RFSComplete fileInfo - FSCancelled -> ft fileInv RFSCancelled fileInfo + 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} + FSAccepted -> ft name fileInv RFSAccepted fileInfo + FSConnected -> ft name fileInv RFSConnected fileInfo + FSComplete -> ft name fileInv RFSComplete fileInfo + FSCancelled -> ft name fileInv RFSCancelled fileInfo where - ft fileInvitation rfs = \case + ft senderDisplayName fileInvitation rfs = \case (Just filePath, Just connId, Just agentConnId) -> let fileStatus = rfs RcvFileInfo {filePath, connId, agentConnId} in Right RcvFileTransfer {..} @@ -1315,6 +1346,11 @@ updatedRcvFileChunkStored st RcvFileTransfer {fileId} chunkNo = |] (fileId, chunkNo) +deleteRcvFileChunks :: MonadUnliftIO m => SQLiteStore -> RcvFileTransfer -> m () +deleteRcvFileChunks st RcvFileTransfer {fileId} = + liftIO . withTransaction st $ \db -> + DB.execute db "DELETE FROM rcv_file_chunks WHERE file_id = ?" (Only fileId) + getFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m FileTransfer getFileTransfer st userId fileId = liftIOEither . withTransaction st $ \db -> @@ -1354,18 +1390,24 @@ getSndFileTransfers_ db userId fileId = <$> DB.query db [sql| - SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.connection_id, c.agent_conn_id + SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.connection_id, c.agent_conn_id, + cs.local_display_name, m.local_display_name FROM snd_files s JOIN files f USING (file_id) JOIN connections c USING (connection_id) + LEFT JOIN contacts cs USING (contact_id) + LEFT JOIN group_members m USING (group_member_id) WHERE f.user_id = ? AND f.file_id = ? |] (userId, fileId) where - sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, ConnId)] -> Either StoreError [SndFileTransfer] + sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, ConnId, Maybe ContactName, Maybe ContactName)] -> Either StoreError [SndFileTransfer] sndFileTransfers [] = Left $ SESndFileNotFound fileId - sndFileTransfers fts = Right $ map sndFileTransfer fts - sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId) = SndFileTransfer {..} + sndFileTransfers fts = mapM sndFileTransfer fts + sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId, contactName_, memberName_) = + case contactName_ <|> memberName_ of + Just recipientDisplayName -> Right SndFileTransfer {..} + Nothing -> Left $ SESndFileInvalid fileId -- | Saves unique local display name based on passed displayName, suffixed with _N if required. -- This function should be called inside transaction. @@ -1432,6 +1474,7 @@ data StoreError | SEGroupAlreadyJoined | SEGroupInvitationNotFound | SESndFileNotFound Int64 + | SESndFileInvalid Int64 | SERcvFileNotFound Int64 | SEFileNotFound Int64 | SERcvFileInvalid Int64 diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index b73deab15..ffd656a1f 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -123,6 +123,7 @@ data ReceivedGroupInvitation = ReceivedGroupInvitation data GroupMember = GroupMember { groupMemberId :: Int64, + groupId :: Int64, memberId :: MemberId, memberRole :: GroupMemberRole, memberCategory :: GroupMemberCategory, @@ -305,6 +306,7 @@ data SndFileTransfer = SndFileTransfer filePath :: String, fileSize :: Integer, chunkSize :: Integer, + recipientDisplayName :: ContactName, connId :: Int64, agentConnId :: ConnId, fileStatus :: FileStatus @@ -322,6 +324,7 @@ data RcvFileTransfer = RcvFileTransfer { fileId :: Int64, fileInvitation :: FileInvitation, fileStatus :: RcvFileStatus, + senderDisplayName :: ContactName, chunkSize :: Integer } deriving (Eq, Show) @@ -343,7 +346,7 @@ data RcvFileInfo = RcvFileInfo data FileTransfer = FTSnd [SndFileTransfer] | FTRcv RcvFileTransfer -data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Show) +data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Ord, Show) instance FromField FileStatus where fromField = fromTextField_ fileStatusT diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 5139a94d9..b2108eb79 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -25,11 +25,14 @@ module Simplex.Chat.View showSentMessage, showSentGroupMessage, showSentFileInvitation, + showSentGroupFileInvitation, + showSentFileInfo, showSndFileStart, showSndFileComplete, showSndFileCancelled, + showSndGroupFileCancelled, showSndFileRcvCancelled, - showReceivedFileInvitation, + receivedFileInvitation, showRcvFileAccepted, showRcvFileStart, showRcvFileComplete, @@ -58,6 +61,7 @@ module Simplex.Chat.View showContactUpdated, showMessageError, safeDecodeUtf8, + msgPlain, ) where @@ -65,7 +69,9 @@ import Control.Monad.IO.Unlift import Control.Monad.Reader import Data.ByteString.Char8 (ByteString) import Data.Composition ((.:), (.:.)) +import Data.Function (on) import Data.Int (Int64) +import Data.List (groupBy, intersperse, sortOn) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (DiffTime, UTCTime) @@ -123,13 +129,13 @@ showGroupRemoved = printToView . groupRemoved showMemberSubError :: ChatReader m => GroupName -> ContactName -> ChatError -> m () showMemberSubError = printToView .:. memberSubError -showReceivedMessage :: ChatReader m => ContactName -> UTCTime -> Text -> MsgIntegrity -> m () +showReceivedMessage :: ChatReader m => ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> m () showReceivedMessage = showReceivedMessage_ . ttyFromContact -showReceivedGroupMessage :: ChatReader m => GroupName -> ContactName -> UTCTime -> Text -> MsgIntegrity -> m () +showReceivedGroupMessage :: ChatReader m => GroupName -> ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> m () showReceivedGroupMessage = showReceivedMessage_ .: ttyFromGroup -showReceivedMessage_ :: ChatReader m => StyledString -> UTCTime -> Text -> MsgIntegrity -> m () +showReceivedMessage_ :: ChatReader m => StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> m () showReceivedMessage_ from utcTime msg mOk = printToView =<< liftIO (receivedMessage from utcTime msg mOk) showSentMessage :: ChatReader m => ContactName -> ByteString -> m () @@ -141,37 +147,46 @@ showSentGroupMessage = showSentMessage_ . ttyToGroup showSentMessage_ :: ChatReader m => StyledString -> ByteString -> m () showSentMessage_ to msg = printToView =<< liftIO (sentMessage to msg) -showSentFileInvitation :: ChatReader m => ContactName -> SndFileTransfer -> m () -showSentFileInvitation = printToView .: sentFileInvitation +showSentFileInvitation :: ChatReader m => ContactName -> FilePath -> m () +showSentFileInvitation = showSentFileInvitation_ . ttyToContact -showSndFileStart :: ChatReader m => Int64 -> m () +showSentGroupFileInvitation :: ChatReader m => GroupName -> FilePath -> m () +showSentGroupFileInvitation = showSentFileInvitation_ . ttyToGroup + +showSentFileInvitation_ :: ChatReader m => StyledString -> FilePath -> m () +showSentFileInvitation_ to filePath = printToView =<< liftIO (sentFileInvitation to filePath) + +showSentFileInfo :: ChatReader m => Int64 -> m () +showSentFileInfo = printToView . sentFileInfo + +showSndFileStart :: ChatReader m => SndFileTransfer -> m () showSndFileStart = printToView . sndFileStart -showSndFileComplete :: ChatReader m => Int64 -> m () +showSndFileComplete :: ChatReader m => SndFileTransfer -> m () showSndFileComplete = printToView . sndFileComplete -showSndFileCancelled :: ChatReader m => Int64 -> m () +showSndFileCancelled :: ChatReader m => SndFileTransfer -> m () showSndFileCancelled = printToView . sndFileCancelled -showSndFileRcvCancelled :: ChatReader m => Int64 -> m () +showSndGroupFileCancelled :: ChatReader m => [SndFileTransfer] -> m () +showSndGroupFileCancelled = printToView . sndGroupFileCancelled + +showSndFileRcvCancelled :: ChatReader m => SndFileTransfer -> m () showSndFileRcvCancelled = printToView . sndFileRcvCancelled -showReceivedFileInvitation :: ChatReader m => ContactName -> RcvFileTransfer -> m () -showReceivedFileInvitation = printToView .: receivedFileInvitation - -showRcvFileAccepted :: ChatReader m => Int64 -> FilePath -> m () +showRcvFileAccepted :: ChatReader m => RcvFileTransfer -> FilePath -> m () showRcvFileAccepted = printToView .: rcvFileAccepted -showRcvFileStart :: ChatReader m => Int64 -> m () +showRcvFileStart :: ChatReader m => RcvFileTransfer -> m () showRcvFileStart = printToView . rcvFileStart -showRcvFileComplete :: ChatReader m => Int64 -> m () +showRcvFileComplete :: ChatReader m => RcvFileTransfer -> m () showRcvFileComplete = printToView . rcvFileComplete -showRcvFileCancelled :: ChatReader m => Int64 -> m () +showRcvFileCancelled :: ChatReader m => RcvFileTransfer -> m () showRcvFileCancelled = printToView . rcvFileCancelled -showRcvFileSndCancelled :: ChatReader m => Int64 -> m () +showRcvFileSndCancelled :: ChatReader m => RcvFileTransfer -> m () showRcvFileSndCancelled = printToView . rcvFileSndCancelled showFileTransferStatus :: ChatReader m => (FileTransfer, [Integer]) -> m () @@ -409,10 +424,10 @@ contactUpdated messageError :: Text -> Text -> [StyledString] messageError prefix err = [plain prefix <> ": " <> plain err] -receivedMessage :: StyledString -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString] +receivedMessage :: StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString] receivedMessage from utcTime msg mOk = do t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime - pure $ prependFirst (t <> " " <> from) (msgPlain msg) ++ showIntegrity mOk + pure $ prependFirst (t <> " " <> from) msg ++ showIntegrity mOk where formatUTCTime :: TimeZone -> ZonedTime -> StyledString formatUTCTime localTz currentTime = @@ -436,9 +451,15 @@ receivedMessage from utcTime msg mOk = do msgError s = [styled (Colored Red) s] sentMessage :: StyledString -> ByteString -> IO [StyledString] -sentMessage to msg = do +sentMessage to msg = sendWithTime_ to . msgPlain $ safeDecodeUtf8 msg + +sentFileInvitation :: StyledString -> FilePath -> IO [StyledString] +sentFileInvitation to f = sendWithTime_ ("/f " <> to) [ttyFilePath f] + +sendWithTime_ :: StyledString -> [StyledString] -> IO [StyledString] +sendWithTime_ to styledMsg = do time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime - pure $ prependFirst (styleTime time <> " " <> to) (msgPlain $ safeDecodeUtf8 msg) + pure $ prependFirst (styleTime time <> " " <> to) styledMsg prependFirst :: StyledString -> [StyledString] -> [StyledString] prependFirst s [] = [s] @@ -447,27 +468,39 @@ prependFirst s (s' : ss) = (s <> s') : ss msgPlain :: Text -> [StyledString] msgPlain = map styleMarkdownText . T.lines -sentFileInvitation :: ContactName -> SndFileTransfer -> [StyledString] -sentFileInvitation cName SndFileTransfer {fileId, fileName} = - [ "offered to send the file " <> plain fileName <> " to " <> ttyContact cName, - "use " <> highlight ("/fc " <> show fileId) <> " to cancel sending" - ] +sentFileInfo :: Int64 -> [StyledString] +sentFileInfo fileId = + ["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"] -sndFileStart :: Int64 -> [StyledString] -sndFileStart fileId = ["started sending the file " <> sShow fileId] +sndFileStart :: SndFileTransfer -> [StyledString] +sndFileStart = sendingFile_ "started" -sndFileComplete :: Int64 -> [StyledString] -sndFileComplete fileId = ["completed sending the file " <> sShow fileId] +sndFileComplete :: SndFileTransfer -> [StyledString] +sndFileComplete = sendingFile_ "completed" -sndFileCancelled :: Int64 -> [StyledString] -sndFileCancelled fileId = ["cancelled sending the file " <> sShow fileId] +sndFileCancelled :: SndFileTransfer -> [StyledString] +sndFileCancelled = sendingFile_ "cancelled" -sndFileRcvCancelled :: Int64 -> [StyledString] -sndFileRcvCancelled fileId = ["recipient cancelled receiving the file " <> sShow fileId] +sndGroupFileCancelled :: [SndFileTransfer] -> [StyledString] +sndGroupFileCancelled 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] -receivedFileInvitation :: ContactName -> RcvFileTransfer -> [StyledString] -receivedFileInvitation c RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} = - [ ttyContact c <> " wants to send you the file " <> plain fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)", +sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString] +sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} = + [status <> " sending " <> sndFile ft <> " to " <> ttyContact c] + +sndFileRcvCancelled :: SndFileTransfer -> [StyledString] +sndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} = + [ttyContact c <> " cancelled receiving " <> sndFile ft] + +sndFile :: SndFileTransfer -> StyledString +sndFile SndFileTransfer {fileId, fileName} = fileTransfer fileId fileName + +receivedFileInvitation :: RcvFileTransfer -> [StyledString] +receivedFileInvitation RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} = + [ "sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)", "use " <> highlight ("/fr " <> show fileId <> " [/ | ]") <> " to receive it" ] @@ -483,41 +516,71 @@ humanReadableSize size mB = kB * 1024 gB = mB * 1024 -rcvFileAccepted :: Int64 -> FilePath -> [StyledString] -rcvFileAccepted fileId filePath = ["saving file " <> sShow fileId <> " to " <> plain filePath] +rcvFileAccepted :: RcvFileTransfer -> FilePath -> [StyledString] +rcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath = + ["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath] -rcvFileStart :: Int64 -> [StyledString] -rcvFileStart fileId = ["started receiving the file " <> sShow fileId] +rcvFileStart :: RcvFileTransfer -> [StyledString] +rcvFileStart = receivingFile_ "started" -rcvFileComplete :: Int64 -> [StyledString] -rcvFileComplete fileId = ["completed receiving the file " <> sShow fileId] +rcvFileComplete :: RcvFileTransfer -> [StyledString] +rcvFileComplete = receivingFile_ "completed" -rcvFileCancelled :: Int64 -> [StyledString] -rcvFileCancelled fileId = ["cancelled receiving the file " <> sShow fileId] +rcvFileCancelled :: RcvFileTransfer -> [StyledString] +rcvFileCancelled = receivingFile_ "cancelled" -rcvFileSndCancelled :: Int64 -> [StyledString] -rcvFileSndCancelled fileId = ["sender cancelled sending the file " <> sShow fileId] +receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString] +receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} = + [status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c] + +rcvFileSndCancelled :: RcvFileTransfer -> [StyledString] +rcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} = + [ttyContact c <> " cancelled sending " <> rcvFile ft] + +rcvFile :: RcvFileTransfer -> StyledString +rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = fileTransfer fileId fileName + +fileTransfer :: Int64 -> String -> StyledString +fileTransfer fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath fileName <> ")" fileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString] -fileTransferStatus (FTSnd [SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) = - ["sent file transfer " <> sndStatus] +fileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) = + ["sending " <> sndFile ft <> " " <> sndStatus] where sndStatus = case fileStatus of - FSNew -> "is not accepted yet" + FSNew -> "not accepted yet" FSAccepted -> "just started" - FSConnected -> "progress: " <> fileProgress chunksNum chunkSize fileSize - FSComplete -> "is complete" - FSCancelled -> "is cancelled" -fileTransferStatus (FTSnd _fts, _chunks) = [] -- TODO group transfer -fileTransferStatus (FTRcv RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, fileStatus, chunkSize}, chunksNum) = - ["received file transfer " <> rcvStatus] + FSConnected -> "progress " <> fileProgress chunksNum chunkSize fileSize + FSComplete -> "complete" + FSCancelled -> "cancelled" +fileTransferStatus (FTSnd [], _) = ["no file transfers (empty group)"] +fileTransferStatus (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 + where + fs = fileStatus :: SndFileTransfer -> FileStatus + membersTransferStatus [] = [] + membersTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listMembers ts] + where + sndStatus = case fileStatus of + FSNew -> "not accepted" + FSAccepted -> "just started" + FSConnected -> "in progress (" <> sShow (sum chunksNum * chunkSize * 100 `div` (toInteger (length chunksNum) * fileSize)) <> "%)" + FSComplete -> "complete" + FSCancelled -> "cancelled" +fileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, fileStatus, chunkSize}, chunksNum) = + ["receiving " <> rcvFile ft <> " " <> rcvStatus] where rcvStatus = case fileStatus of - RFSNew -> "is not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file" + RFSNew -> "not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file" RFSAccepted _ -> "just started" - RFSConnected _ -> "progress: " <> fileProgress chunksNum chunkSize fileSize - RFSComplete RcvFileInfo {filePath} -> "is complete, path: " <> plain filePath - RFSCancelled RcvFileInfo {filePath} -> "is cancelled, received part path: " <> plain filePath + RFSConnected _ -> "progress " <> fileProgress chunksNum chunkSize fileSize + 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) fileProgress :: [Integer] -> Integer -> Integer -> StyledString fileProgress chunksNum chunkSize fileSize = @@ -606,6 +669,9 @@ ttyFromGroup g c = styled (Colored Yellow) $ "#" <> g <> " " <> c <> "> " ttyToGroup :: GroupName -> StyledString ttyToGroup g = styled (Colored Cyan) $ "#" <> g <> " " +ttyFilePath :: FilePath -> StyledString +ttyFilePath = plain + optFullName :: ContactName -> Text -> StyledString optFullName localDisplayName fullName | T.null fullName || localDisplayName == fullName = "" diff --git a/stack.yaml b/stack.yaml index 9a58b8394..83a08338b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -43,7 +43,7 @@ extra-deps: # - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688 # - ../simplexmq - github: simplex-chat/simplexmq - commit: 2ac903a2dd37c11a8612b19cd132cf43fe771fe4 + commit: e07bedac0e59346f076d71635ce6cd25de67ca7e # # extra-deps: [] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 0afdf62ef..195b7227b 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -44,6 +44,7 @@ chatTests = do it "send and receive file" testFileTransfer it "sender cancelled file transfer" testFileSndCancel it "recipient cancelled file transfer" testFileRcvCancel + it "send and receive file to group" testGroupFileTransfer testAddContact :: IO () testAddContact = @@ -410,10 +411,10 @@ testFileTransfer = concurrentlyN_ [ do bob #> "@alice receiving here..." - bob <## "completed receiving the file 1", + bob <## "completed receiving file 1 (test.jpg) from alice", do alice <# "bob> receiving here..." - alice <## "completed sending the file 1" + alice <## "completed sending file 1 (test.jpg) to bob" ] src <- B.readFile "./tests/fixtures/test.jpg" dest <- B.readFile "./tests/tmp/test.jpg" @@ -428,13 +429,13 @@ testFileSndCancel = alice ##> "/fc 1" concurrentlyN_ [ do - alice <## "cancelled sending the file 1" + alice <## "cancelled sending file 1 (test.jpg) to bob" alice ##> "/fs 1" - alice <## "sent file transfer is cancelled", + alice <## "sending file 1 (test.jpg) cancelled", do - bob <## "sender cancelled sending the file 1" + bob <## "alice cancelled sending file 1 (test.jpg)" bob ##> "/fs 1" - bob <## "received file transfer is cancelled, received part path: ./tests/tmp/test.jpg" + bob <## "receiving file 1 (test.jpg) cancelled, received part path: ./tests/tmp/test.jpg" ] checkPartialTransfer @@ -445,35 +446,77 @@ testFileRcvCancel = connectUsers alice bob startFileTransfer alice bob bob ##> "/fs 1" - getTermLine bob >>= (`shouldStartWith` "received file transfer progress:") + getTermLine bob >>= (`shouldStartWith` "receiving file 1 (test.jpg) progress") waitFileExists "./tests/tmp/test.jpg" bob ##> "/fc 1" concurrentlyN_ [ do - bob <## "cancelled receiving the file 1" + bob <## "cancelled receiving file 1 (test.jpg) from alice" bob ##> "/fs 1" - bob <## "received file transfer is cancelled, received part path: ./tests/tmp/test.jpg", + bob <## "receiving file 1 (test.jpg) cancelled, received part path: ./tests/tmp/test.jpg", do - alice <## "recipient cancelled receiving the file 1" + alice <## "bob cancelled receiving file 1 (test.jpg)" alice ##> "/fs 1" - alice <## "sent file transfer is cancelled" + alice <## "sending file 1 (test.jpg) cancelled" ] checkPartialTransfer where waitFileExists f = unlessM (doesFileExist f) $ waitFileExists f +testGroupFileTransfer :: IO () +testGroupFileTransfer = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + 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) not accepted") + 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):" + alice <### [" complete: bob", " not accepted: cath"], + 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" + ] + startFileTransfer :: TestCC -> TestCC -> IO () startFileTransfer alice bob = do - alice ##> "/f bob ./tests/fixtures/test.jpg" - alice <## "offered to send the file test.jpg to bob" + alice #> "/f @bob ./tests/fixtures/test.jpg" alice <## "use /fc 1 to cancel sending" - bob <## "alice wants to send you the file test.jpg (136.5 KiB / 139737 bytes)" + 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 to ./tests/tmp/test.jpg" + bob <## "saving file 1 from alice to ./tests/tmp/test.jpg" concurrently_ - (bob <## "started receiving the file 1") - (alice <## "started sending the file 1") + (bob <## "started receiving file 1 (test.jpg) from alice") + (alice <## "started sending file 1 (test.jpg) to bob") checkPartialTransfer :: IO () checkPartialTransfer = do