From 0262ab53bfc4ed5017b2bf998d8ea030e7a093c3 Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Wed, 11 May 2022 16:18:28 +0400 Subject: [PATCH] core: improve file cancel (#627) Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- src/Simplex/Chat.hs | 225 ++++++++++++++++----------------- src/Simplex/Chat/Controller.hs | 1 + src/Simplex/Chat/Messages.hs | 12 ++ src/Simplex/Chat/Protocol.hs | 11 +- src/Simplex/Chat/Store.hs | 155 ++++++++++------------- src/Simplex/Chat/Types.hs | 2 +- src/Simplex/Chat/View.hs | 4 +- tests/ChatTests.hs | 70 +++++++++- tests/ProtocolTests.hs | 3 + 9 files changed, 273 insertions(+), 210 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 234d17298a..cc6cab47b2 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -254,7 +254,7 @@ processChatCommand = \case (fileSize, chSize) <- checkSndFile file let fileName = takeFileName file fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing} - fileId <- withStore $ \st -> createSndGroupFileTransferV2 st userId gInfo file fileInvitation chSize + fileId <- withStore $ \st -> createSndGroupFileTransfer st userId gInfo file fileInvitation chSize let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored} pure $ Just (fileInvitation, ciFile) prepareMsg :: Maybe FileInvitation -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup)) @@ -331,12 +331,12 @@ processChatCommand = \case (ct@Contact {localDisplayName = c}, CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file}) <- withStore $ \st -> (,) <$> getContact st userId chatId <*> getDirectChatItem st userId chatId itemId case (mode, msgDir, itemSharedMsgId) of (CIDMInternal, _, _) -> do - deleteFile user file + deleteCIFile user file toCi <- withStore $ \st -> deleteDirectChatItemInternal st userId ct itemId pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do SndMessage {msgId} <- sendDirectContactMessage ct (XMsgDel itemSharedMId) - deleteFile user file + deleteCIFile user file toCi <- withStore $ \st -> deleteDirectChatItemSndBroadcast st userId ct itemId msgId setActive $ ActiveC c pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) toCi @@ -347,12 +347,12 @@ processChatCommand = \case CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemSharedMsgId}, file} <- withStore $ \st -> getGroupChatItem st user chatId itemId case (mode, msgDir, itemSharedMsgId) of (CIDMInternal, _, _) -> do - deleteFile user file + deleteCIFile user file toCi <- withStore $ \st -> deleteGroupChatItemInternal st user gInfo itemId pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgDel itemSharedMId) - deleteFile user file + deleteCIFile user file toCi <- withStore $ \st -> deleteGroupChatItemSndBroadcast st user gInfo itemId msgId setActive $ ActiveG gName pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi @@ -360,8 +360,8 @@ processChatCommand = \case CTContactRequest -> pure $ chatCmdError "not supported" CTContactConnection -> pure $ chatCmdError "not supported" where - deleteFile :: MsgDirectionI d => User -> Maybe (CIFile d) -> m () - deleteFile user file = + deleteCIFile :: MsgDirectionI d => User -> Maybe (CIFile d) -> m () + deleteCIFile user file = forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do cancelFiles user [(fileId, AFS msgDirection fileStatus)] withFilesFolder $ \filesFolder -> @@ -641,9 +641,9 @@ processChatCommand = \case SendFile chatName f -> withUser $ \user -> do chatRef <- getChatRef user chatName processChatCommand . APISendMessage chatRef $ ComposedMessage (Just f) Nothing (MCFile "") - ReceiveFile fileId filePath_ -> withUser $ \user@User {userId} -> + ReceiveFile fileId filePath_ -> withUser $ \user -> withChatLock . procCmd $ do - ft <- withStore $ \st -> getRcvFileTransfer st userId fileId + ft <- withStore $ \st -> getRcvFileTransfer st user fileId (CRRcvFileAccepted <$> acceptFileReceive user ft filePath_) `catchError` processError ft where processError ft = \case @@ -651,11 +651,29 @@ processChatCommand = \case ChatErrorAgent (SMP SMP.AUTH) -> pure $ CRRcvFileAcceptedSndCancelled ft ChatErrorAgent (CONN DUPLICATE) -> pure $ CRRcvFileAcceptedSndCancelled ft e -> throwError e - CancelFile fileId -> withUser $ \user@User {userId} -> do - ft <- withStore (\st -> getFileTransfer st userId fileId) - withChatLock . procCmd $ cancelFile user fileId ft + CancelFile fileId -> withUser $ \user@User {userId} -> + withChatLock . procCmd $ + withStore (\st -> getFileTransfer st user fileId) >>= \case + FTSnd ftm@FileTransferMeta {cancelled} fts -> do + unless cancelled $ do + cancelSndFile user ftm fts + sharedMsgId <- withStore $ \st -> getSharedMsgIdByFileId st userId fileId + void $ + withStore (\st -> getChatRefByFileId st user fileId) >>= \case + ChatRef CTDirect contactId -> do + contact <- withStore $ \st -> getContact st userId contactId + sendDirectContactMessage contact $ XFileCancel sharedMsgId + ChatRef CTGroup groupId -> do + Group gInfo ms <- withStore $ \st -> getGroup st user groupId + sendGroupMessage gInfo ms $ XFileCancel sharedMsgId + _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" + ci <- withStore $ \st -> getChatItemByFileId st user fileId + pure $ CRSndGroupFileCancelled ci ftm fts + FTRcv ftr@RcvFileTransfer {cancelled} -> do + unless cancelled $ cancelRcvFileTransfer user ftr + pure $ CRRcvFileCancelled ftr FileStatus fileId -> - CRFileTransferStatus <$> withUser (\User {userId} -> withStore $ \st -> getFileTransferProgress st userId fileId) + CRFileTransferStatus <$> withUser (\user -> withStore $ \st -> getFileTransferProgress st user fileId) ShowProfile -> withUser $ \User {profile} -> pure $ CRUserProfile profile UpdateProfile displayName fullName -> withUser $ \user@User {profile} -> do let p = (profile :: Profile) {displayName = displayName, fullName = fullName} @@ -741,42 +759,15 @@ processChatCommand = \case removeFile fsFilePath `E.catch` \(_ :: E.SomeException) -> removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure () cancelFiles :: User -> [(Int64, ACIFileStatus)] -> m () - cancelFiles user@User {userId} files = mapM_ maybeCancelFile files - where - maybeCancelFile :: (Int64, ACIFileStatus) -> m () - maybeCancelFile (fileId, status) = case status of - AFS _ CIFSSndStored -> cancelById fileId - AFS _ CIFSSndTransfer -> cancelById fileId - AFS _ CIFSSndCancelled -> pure () - AFS _ CIFSSndComplete -> pure () - AFS _ CIFSRcvInvitation -> cancelById fileId - AFS _ CIFSRcvAccepted -> cancelById fileId - AFS _ CIFSRcvTransfer -> cancelById fileId - AFS _ CIFSRcvCancelled -> pure () - AFS _ CIFSRcvComplete -> pure () - cancelById :: Int64 -> m () - cancelById fileId = do - ft <- withStore (\st -> getFileTransfer st userId fileId) - void $ cancelFile user fileId ft - cancelFile :: User -> Int64 -> FileTransfer -> m ChatResponse - cancelFile user@User {userId} fileId ft = - case ft of - FTSnd ftm fts -> do - cancelFileTransfer CIFSSndCancelled - forM_ fts $ \ft' -> cancelSndFileTransfer ft' - ci <- withStore $ \st -> getChatItemByFileId st user fileId - pure $ CRSndGroupFileCancelled ci ftm fts - FTRcv ftr -> do - cancelFileTransfer CIFSRcvCancelled - cancelRcvFileTransfer ftr - pure $ CRRcvFileCancelled ftr - where - cancelFileTransfer :: MsgDirectionI d => CIFileStatus d -> m () - cancelFileTransfer ciFileStatus = - unless (fileTransferCancelled ft) $ - withStore $ \st -> do - updateFileCancelled st userId fileId - updateCIFileStatus st userId fileId ciFileStatus + cancelFiles user files = forM_ files $ \ (fileId, AFS dir status) -> + unless (ciFileEnded status) $ + case dir of + SMDSnd -> do + (ftm@FileTransferMeta {cancelled}, fts) <- withStore (\st -> getSndFileTransfer st user fileId) + unless cancelled $ cancelSndFile user ftm fts + SMDRcv -> do + ft@RcvFileTransfer {cancelled} <- withStore (\st -> getRcvFileTransfer st user fileId) + unless cancelled $ cancelRcvFileTransfer user ft withCurrentCall :: ContactId -> (UserId -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse withCurrentCall ctId action = withUser $ \User {userId} -> do ct <- withStore $ \st -> getContact st userId ctId @@ -838,37 +829,33 @@ toFSFilePath f = maybe f (<> "/" <> f) <$> (readTVarIO =<< asks filesFolder) acceptFileReceive :: forall m. ChatMonad m => User -> RcvFileTransfer -> Maybe FilePath -> m AChatItem -acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName = fName, fileConnReq}, fileStatus, senderDisplayName, grpMemberId} filePath_ = do - unless (fileStatus == RFSNew) . throwChatError $ CEFileAlreadyReceiving fName +acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName = fName, fileConnReq}, fileStatus, grpMemberId} filePath_ = do + unless (fileStatus == RFSNew) $ case fileStatus of + RFSCancelled _ -> throwChatError $ CEFileCancelled fName + _ -> throwChatError $ CEFileAlreadyReceiving fName case fileConnReq of - -- old file protocol + -- direct file protocol Just connReq -> tryError (withAgent $ \a -> joinConnection a connReq . directMessage $ XFileAcpt fName) >>= \case Right agentConnId -> do filePath <- getRcvFilePath filePath_ fName withStore $ \st -> acceptRcvFileTransfer st user fileId agentConnId filePath Left e -> throwError e - -- new file protocol + -- group file protocol Nothing -> case grpMemberId of - Nothing -> do - ct <- withStore $ \st -> getContactByName st userId senderDisplayName - acceptFileV2 $ \sharedMsgId fileInvConnReq -> sendDirectContactMessage ct $ XFileAcptInv sharedMsgId fileInvConnReq fName + Nothing -> throwChatError $ CEFileInternal "group member not found for file transfer" Just memId -> do (GroupInfo {groupId}, GroupMember {activeConn}) <- withStore $ \st -> getGroupAndMember st user memId case activeConn of - Just conn -> - acceptFileV2 $ \sharedMsgId fileInvConnReq -> sendDirectMessage conn (XFileAcptInv sharedMsgId fileInvConnReq fName) (GroupId groupId) - _ -> throwChatError $ CEFileInternal "member connection not active" -- should not happen - where - acceptFileV2 :: (SharedMsgId -> ConnReqInvitation -> m SndMessage) -> m AChatItem - acceptFileV2 sendXFileAcptInv = do - sharedMsgId <- withStore $ \st -> getSharedMsgIdByFileId st userId fileId - (agentConnId, fileInvConnReq) <- withAgent (`createConnection` SCMInvitation) - filePath <- getRcvFilePath filePath_ fName - ci <- withStore $ \st -> acceptRcvFileTransfer st user fileId agentConnId filePath - void $ sendXFileAcptInv sharedMsgId fileInvConnReq - pure ci + Just conn -> do + sharedMsgId <- withStore $ \st -> getSharedMsgIdByFileId st userId fileId + (agentConnId, fileInvConnReq) <- withAgent (`createConnection` SCMInvitation) + filePath <- getRcvFilePath filePath_ fName + ci <- withStore $ \st -> acceptRcvFileTransfer st user fileId agentConnId filePath + void $ sendDirectMessage conn (XFileAcptInv sharedMsgId fileInvConnReq fName) (GroupId groupId) + pure ci + _ -> throwChatError $ CEFileInternal "member connection not active" where getRcvFilePath :: Maybe FilePath -> String -> m FilePath getRcvFilePath fPath_ fn = case fPath_ of @@ -1077,7 +1064,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage XMsgDel sharedMsgId -> messageDelete ct sharedMsgId msg msgMeta -- TODO discontinue XFile XFile fInv -> processFileInvitation' ct fInv msg msgMeta - XFileAcptInv sharedMsgId fileConnReq fName -> xFileAcptInv ct sharedMsgId fileConnReq fName msgMeta + XFileCancel sharedMsgId -> xFileCancel ct sharedMsgId msgMeta XInfo p -> xInfo ct p XGrpInv gInv -> processGroupInvitation ct gInv XInfoProbe probe -> xInfoProbe ct probe @@ -1217,6 +1204,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage XMsgDel sharedMsgId -> groupMessageDelete gInfo m sharedMsgId msg -- TODO discontinue XFile XFile fInv -> processGroupFileInvitation' gInfo m fInv msg msgMeta + XFileCancel sharedMsgId -> xFileCancelGroup gInfo m sharedMsgId 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 @@ -1238,7 +1226,8 @@ 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 + -- SMP CONF for SndFileConnection happens for direct file protocol + -- when recipient of the file "joins" connection created by the sender CONF confId connInfo -> do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case chatMsgEvent of @@ -1273,9 +1262,11 @@ 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, cancelled} = case agentMsg of - -- new file protocol + -- SMP CONF for RcvFileConnection happens for group file protocol + -- when sender of the file "joins" connection created by the recipient + -- (sender doesn't create connections for all group members) CONF confId connInfo -> do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case chatMsgEvent of @@ -1284,14 +1275,15 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage CON -> do ci <- withStore $ \st -> do updateRcvFileStatus st ft FSConnected - updateCIFileStatus st userId fileId CIFSRcvTransfer + updateCIFileStatus st user fileId CIFSRcvTransfer getChatItemByFileId st user fileId toView $ CRRcvFileStart ci MSG meta@MsgMeta {recipient = (msgId, _), integrity} msgBody -> withAckMessage agentConnId meta $ do parseFileChunk msgBody >>= \case - FileChunkCancel -> do - cancelRcvFileTransfer ft - toView $ CRRcvFileSndCancelled ft + FileChunkCancel -> + unless cancelled $ do + cancelRcvFileTransfer user ft + toView (CRRcvFileSndCancelled ft) FileChunk {chunkNo, chunkBytes = chunk} -> do case integrity of MsgOk -> pure () @@ -1310,7 +1302,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage appendFileChunk ft chunkNo chunk ci <- withStore $ \st -> do updateRcvFileStatus st ft FSComplete - updateCIFileStatus st userId fileId CIFSRcvComplete + updateCIFileStatus st user fileId CIFSRcvComplete deleteRcvFileChunks st ft getChatItemByFileId st user fileId toView $ CRRcvFileComplete ci @@ -1368,12 +1360,10 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage agentErrToItemStatus err = CISSndError err badRcvFileChunk :: RcvFileTransfer -> String -> m () - badRcvFileChunk ft@RcvFileTransfer {fileStatus} err = - case fileStatus of - RFSCancelled _ -> pure () - _ -> do - cancelRcvFileTransfer ft - throwChatError $ CEFileRcvChunk err + badRcvFileChunk ft@RcvFileTransfer {cancelled} err = + unless cancelled $ do + cancelRcvFileTransfer user ft + throwChatError $ CEFileRcvChunk err notifyMemberConnected :: GroupInfo -> GroupMember -> m () notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} = do @@ -1501,41 +1491,44 @@ 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 + xFileCancel :: Contact -> SharedMsgId -> MsgMeta -> m () + xFileCancel Contact {contactId} sharedMsgId 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" + ft@RcvFileTransfer {cancelled} <- withStore (\st -> getRcvFileTransfer st user fileId) + unless cancelled $ do + cancelRcvFileTransfer user ft + toView $ CRRcvFileSndCancelled ft + + xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> MsgMeta -> m () + xFileCancelGroup GroupInfo {groupId} GroupMember {memberId} sharedMsgId msgMeta = do + checkIntegrity msgMeta $ toView . CRMsgIntegrityError + fileId <- withStore $ \st -> getGroupFileIdBySharedMsgId st userId groupId sharedMsgId + CChatItem msgDir ChatItem {chatDir} <- withStore $ \st -> getGroupChatItemBySharedMsgId st user groupId sharedMsgId + case (msgDir, chatDir) of + (SMDRcv, CIGroupRcv m) -> do + if sameMemberId memberId m + then do + ft@RcvFileTransfer {cancelled} <- withStore (\st -> getRcvFileTransfer st user fileId) + unless cancelled $ do + cancelRcvFileTransfer user ft + toView $ CRRcvFileSndCancelled ft + else messageError "x.file.cancel: group member attempted to cancel file of another member" + (SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel" 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" + (FileTransferMeta {fileName, cancelled}, _) <- withStore (\st -> getSndFileTransfer st user fileId) + unless cancelled $ + if fName == fileName + then + tryError (withAgent $ \a -> joinConnection a fileConnReq . directMessage $ XOk) >>= \case + Right acId -> + withStore $ \st -> createSndGroupFileTransferConnection st userId fileId acId m + Left e -> throwError e + else messageError "x.file.acpt.inv: fileName is different from expected" groupMsgToView :: GroupInfo -> ChatItem 'CTGroup 'MDRcv -> MsgMeta -> m () groupMsgToView gInfo ci msgMeta = do @@ -1869,10 +1862,11 @@ isFileActive fileId files = do fs <- asks files isJust . M.lookup fileId <$> readTVarIO fs -cancelRcvFileTransfer :: ChatMonad m => RcvFileTransfer -> m () -cancelRcvFileTransfer ft@RcvFileTransfer {fileId, fileStatus} = do +cancelRcvFileTransfer :: ChatMonad m => User -> RcvFileTransfer -> m () +cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, fileStatus} = do closeFileHandle fileId rcvFiles withStore $ \st -> do + updateFileCancelled st user fileId CIFSRcvCancelled updateRcvFileStatus st ft FSCancelled deleteRcvFileChunks st ft case fileStatus of @@ -1882,6 +1876,11 @@ cancelRcvFileTransfer ft@RcvFileTransfer {fileId, fileStatus} = do withAgent (`deleteConnection` acId) _ -> pure () +cancelSndFile :: ChatMonad m => User -> FileTransferMeta -> [SndFileTransfer] -> m () +cancelSndFile user FileTransferMeta {fileId} fts = do + withStore $ \st -> updateFileCancelled st user fileId CIFSSndCancelled + forM_ fts $ \ft' -> cancelSndFileTransfer ft' + cancelSndFileTransfer :: ChatMonad m => SndFileTransfer -> m () cancelSndFileTransfer ft@SndFileTransfer {agentConnId = AgentConnId acId, fileStatus} = unless (fileStatus == FSCancelled || fileStatus == FSComplete) $ do diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 0f0a48e5af..f43b42b449 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -335,6 +335,7 @@ data ChatErrorType | CEGroupInternal {message :: String} | CEFileNotFound {message :: String} | CEFileAlreadyReceiving {message :: String} + | CEFileCancelled {message :: String} | CEFileAlreadyExists {filePath :: FilePath} | CEFileRead {filePath :: FilePath, message :: String} | CEFileWrite {filePath :: FilePath, message :: String} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 525d283067..47e0aa8218 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -311,6 +311,18 @@ data CIFileStatus (d :: MsgDirection) where deriving instance Show (CIFileStatus d) +ciFileEnded :: CIFileStatus d -> Bool +ciFileEnded = \case + CIFSSndStored -> False + CIFSSndTransfer -> False + CIFSSndCancelled -> True + CIFSSndComplete -> True + CIFSRcvInvitation -> False + CIFSRcvAccepted -> False + CIFSRcvTransfer -> False + CIFSRcvCancelled -> True + CIFSRcvComplete -> True + instance MsgDirectionI d => ToJSON (CIFileStatus d) where toJSON = strToJSON toEncoding = strToJEncoding diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 6a61f96691..83b0d8c204 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -114,8 +114,9 @@ data ChatMsgEvent | XMsgDel SharedMsgId | XMsgDeleted | XFile FileInvitation -- TODO discontinue - | XFileAcpt String -- old file protocol - | XFileAcptInv SharedMsgId ConnReqInvitation String -- new file protocol + | XFileAcpt String -- direct file protocol + | XFileAcptInv SharedMsgId ConnReqInvitation String -- group file protocol + | XFileCancel SharedMsgId | XInfo Profile | XContact Profile (Maybe XContactId) | XGrpInv GroupInvitation @@ -295,6 +296,7 @@ data CMEventTag | XFile_ | XFileAcpt_ | XFileAcptInv_ + | XFileCancel_ | XInfo_ | XContact_ | XGrpInv_ @@ -330,6 +332,7 @@ instance StrEncoding CMEventTag where XFile_ -> "x.file" XFileAcpt_ -> "x.file.acpt" XFileAcptInv_ -> "x.file.acpt.inv" + XFileCancel_ -> "x.file.cancel" XInfo_ -> "x.info" XContact_ -> "x.contact" XGrpInv_ -> "x.grp.inv" @@ -362,6 +365,7 @@ instance StrEncoding CMEventTag where "x.file" -> Right XFile_ "x.file.acpt" -> Right XFileAcpt_ "x.file.acpt.inv" -> Right XFileAcptInv_ + "x.file.cancel" -> Right XFileCancel_ "x.info" -> Right XInfo_ "x.contact" -> Right XContact_ "x.grp.inv" -> Right XGrpInv_ @@ -397,6 +401,7 @@ toCMEventTag = \case XFile _ -> XFile_ XFileAcpt _ -> XFileAcpt_ XFileAcptInv {} -> XFileAcptInv_ + XFileCancel _ -> XFileCancel_ XInfo _ -> XInfo_ XContact _ _ -> XContact_ XGrpInv _ -> XGrpInv_ @@ -450,6 +455,7 @@ appToChatMessage AppMessage {msgId, event, params} = do XFile_ -> XFile <$> p "file" XFileAcpt_ -> XFileAcpt <$> p "fileName" XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> p "fileConnReq" <*> p "fileName" + XFileCancel_ -> XFileCancel <$> p "msgId" XInfo_ -> XInfo <$> p "profile" XContact_ -> XContact <$> p "profile" <*> opt "contactReqId" XGrpInv_ -> XGrpInv <$> p "groupInvitation" @@ -490,6 +496,7 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p XFile fileInv -> o ["file" .= fileInvitationJSON fileInv] XFileAcpt fileName -> o ["fileName" .= fileName] XFileAcptInv sharedMsgId fileConnReq fileName -> o ["msgId" .= sharedMsgId, "fileConnReq" .= fileConnReq, "fileName" .= fileName] + XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId] XInfo profile -> o ["profile" .= profile] XContact profile xContactId -> o $ ("contactReqId" .=? xContactId) ["profile" .= profile] XGrpInv groupInv -> o ["groupInvitation" .= groupInv] diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index f9aafdbade..30e8f8a4d2 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -90,17 +90,15 @@ module Simplex.Chat.Store matchReceivedProbeHash, matchSentProbe, mergeContactRecords, - createSndFileTransfer, -- old file protocol - createSndFileTransferV2, - createSndFileTransferV2Connection, - createSndGroupFileTransfer, -- old file protocol - createSndGroupFileTransferV2, - createSndGroupFileTransferV2Connection, + createSndFileTransfer, + createSndGroupFileTransfer, + createSndGroupFileTransferConnection, updateFileCancelled, updateCIFileStatus, getSharedMsgIdByFileId, getFileIdBySharedMsgId, getGroupFileIdBySharedMsgId, + getChatRefByFileId, updateSndFileStatus, createSndFileChunk, updateSndFileChunkMsg, @@ -117,6 +115,7 @@ module Simplex.Chat.Store updateFileTransferChatItemId, getFileTransfer, getFileTransferProgress, + getSndFileTransfer, getContactFiles, createNewSndMessage, createSndMsgDelivery, @@ -211,7 +210,6 @@ import Simplex.Messaging.Encoding.String (StrEncoding (strEncode)) import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Protocol (ProtocolServer (..), SMPServer, pattern SMPServer) import Simplex.Messaging.Util (liftIOEither, (<$$>)) -import System.FilePath (takeFileName) import UnliftIO.STM schemaMigrations :: [(String, Query)] @@ -1849,46 +1847,8 @@ createSndFileTransfer st userId Contact {contactId} filePath FileInvitation {fil (fileId, fileStatus, connId, currentTs, currentTs) pure fileId -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, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" - (userId, contactId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, 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 - let fileName = takeFileName filePath - currentTs <- getCurrentTime - DB.execute - db - "INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" - (userId, groupId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs) - 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, created_at, updated_at) VALUES (?,?,?,?,?,?)" - (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 = +createSndGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> m Int64 +createSndGroupFileTransfer st userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize} chunkSize = liftIO . withTransaction st $ \db -> do currentTs <- getCurrentTime DB.execute @@ -1897,8 +1857,8 @@ createSndGroupFileTransferV2 st userId GroupInfo {groupId} filePath FileInvitati (userId, groupId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs) insertedRowId db -createSndGroupFileTransferV2Connection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> GroupMember -> m () -createSndGroupFileTransferV2Connection st userId fileId acId GroupMember {groupMemberId} = +createSndGroupFileTransferConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> GroupMember -> m () +createSndGroupFileTransferConnection st userId fileId acId GroupMember {groupMemberId} = liftIO . withTransaction st $ \db -> do currentTs <- getCurrentTime Connection {connId} <- createSndFileConnection_ db userId fileId acId @@ -1907,18 +1867,18 @@ createSndGroupFileTransferV2Connection st userId fileId acId GroupMember {groupM "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 = +updateFileCancelled :: MsgDirectionI d => MonadUnliftIO m => SQLiteStore -> User -> Int64 -> CIFileStatus d -> m () +updateFileCancelled st User {userId} fileId ciFileStatus = 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) + DB.execute db "UPDATE files SET cancelled = 1, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) -updateCIFileStatus :: (MsgDirectionI d, MonadUnliftIO m) => SQLiteStore -> UserId -> Int64 -> CIFileStatus d -> m () -updateCIFileStatus st userId fileId ciFileStatus = - liftIO . withTransaction st $ \db -> updateCIFileStatus_ db userId fileId ciFileStatus +updateCIFileStatus :: (MsgDirectionI d, MonadUnliftIO m) => SQLiteStore -> User -> Int64 -> CIFileStatus d -> m () +updateCIFileStatus st user fileId ciFileStatus = + liftIO . withTransaction st $ \db -> updateCIFileStatus_ db user fileId ciFileStatus -updateCIFileStatus_ :: MsgDirectionI d => DB.Connection -> UserId -> Int64 -> CIFileStatus d -> IO () -updateCIFileStatus_ db userId fileId ciFileStatus = do +updateCIFileStatus_ :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO () +updateCIFileStatus_ db User {userId} fileId ciFileStatus = do currentTs <- getCurrentTime DB.execute db "UPDATE files SET ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?" (ciFileStatus, currentTs, userId, fileId) @@ -1936,7 +1896,7 @@ getSharedMsgIdByFileId st userId fileId = |] (userId, fileId) -getFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> Int64 -> UserId -> SharedMsgId -> m Int64 +getFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> SharedMsgId -> m Int64 getFileIdBySharedMsgId st userId contactId sharedMsgId = liftIOEither . withTransaction st $ \db -> firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ @@ -1950,7 +1910,7 @@ getFileIdBySharedMsgId st userId contactId sharedMsgId = |] (userId, contactId, sharedMsgId) -getGroupFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> Int64 -> UserId -> SharedMsgId -> m Int64 +getGroupFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> SharedMsgId -> m Int64 getGroupFileIdBySharedMsgId st userId groupId sharedMsgId = liftIOEither . withTransaction st $ \db -> firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $ @@ -1964,6 +1924,23 @@ getGroupFileIdBySharedMsgId st userId groupId sharedMsgId = |] (userId, groupId, sharedMsgId) +getChatRefByFileId :: StoreMonad m => SQLiteStore -> User -> Int64 -> m ChatRef +getChatRefByFileId st User {userId} fileId = do + r <- liftIO . withTransaction st $ \db -> do + DB.query + db + [sql| + SELECT contact_id, group_id + FROM files + WHERE user_id = ? AND file_id = ? + LIMIT 1 + |] + (userId, fileId) + case r of + [(Just contactId, Nothing)] -> pure $ ChatRef CTDirect contactId + [(Nothing, Just groupId)] -> pure $ ChatRef CTGroup groupId + _ -> throwError $ SEInternalError "could not retrieve chat ref by file id" + createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection createSndFileConnection_ db userId fileId agentConnId = do currentTs <- getCurrentTime @@ -2057,8 +2034,8 @@ createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localD (fileId, FSNew, fileConnReq, groupMemberId, currentTs, currentTs) 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 = +getRcvFileTransfer :: StoreMonad m => SQLiteStore -> User -> Int64 -> m RcvFileTransfer +getRcvFileTransfer st User {userId} fileId = liftIOEither . withTransaction st $ \db -> getRcvFileTransfer_ db userId fileId @@ -2090,17 +2067,18 @@ getRcvFileTransfer_ db userId fileId = Nothing -> Left $ SERcvFileInvalid fileId Just name -> case fileStatus' of - 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 - FSCancelled -> ft name fileInv RFSCancelled fileInfo + FSNew -> ft name fileInv RFSNew + FSAccepted -> ft name fileInv . RFSAccepted =<< rfi fileInfo + FSConnected -> ft name fileInv . RFSConnected =<< rfi fileInfo + FSComplete -> ft name fileInv . RFSComplete =<< rfi fileInfo + FSCancelled -> ft name fileInv . RFSCancelled $ rfi_ fileInfo where - ft senderDisplayName fileInvitation rfs = \case - (Just filePath, Just connId, Just agentConnId) -> - let fileStatus = rfs RcvFileInfo {filePath, connId, agentConnId} - in Right RcvFileTransfer {..} - _ -> Left $ SERcvFileInvalid fileId + ft senderDisplayName fileInvitation fileStatus = + Right RcvFileTransfer {fileId, fileInvitation, fileStatus, senderDisplayName, chunkSize, cancelled, grpMemberId} + rfi fileInfo = maybe (Left $ SERcvFileInvalid fileId) Right $ rfi_ fileInfo + rfi_ = \case + (Just filePath, Just connId, Just agentConnId) -> Just RcvFileInfo {filePath, connId, agentConnId} + _ -> Nothing cancelled = fromMaybe False cancelled_ rcvFileTransfer _ = Left $ SERcvFileNotFound fileId @@ -2185,13 +2163,13 @@ updateFileTransferChatItemId st fileId ciId = currentTs <- getCurrentTime DB.execute db "UPDATE files SET chat_item_id = ?, updated_at = ? WHERE file_id = ?" (ciId, currentTs, fileId) -getFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m FileTransfer -getFileTransfer st userId fileId = +getFileTransfer :: StoreMonad m => SQLiteStore -> User -> Int64 -> m FileTransfer +getFileTransfer st User {userId} fileId = liftIOEither . withTransaction st $ \db -> getFileTransfer_ db userId fileId -getFileTransferProgress :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m (FileTransfer, [Integer]) -getFileTransferProgress st userId fileId = +getFileTransferProgress :: StoreMonad m => SQLiteStore -> User -> Int64 -> m (FileTransfer, [Integer]) +getFileTransferProgress st User {userId} fileId = liftIOEither . withTransaction st $ \db -> runExceptT $ do ft <- ExceptT $ getFileTransfer_ db userId fileId liftIO $ @@ -2215,15 +2193,20 @@ getFileTransfer_ db userId fileId = (userId, fileId) where fileTransfer :: [(Maybe Int64, Maybe Int64)] -> IO (Either StoreError FileTransfer) - 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 + fileTransfer _ = runExceptT $ do + (ftm, fts) <- ExceptT $ getSndFileTransfer_ db userId fileId + pure $ FTSnd {fileTransferMeta = ftm, sndFileTransfers = fts} + +getSndFileTransfer :: StoreMonad m => SQLiteStore -> User -> Int64 -> m (FileTransferMeta, [SndFileTransfer]) +getSndFileTransfer st User {userId} fileId = + liftIOEither . withTransaction st $ \db -> getSndFileTransfer_ db userId fileId + +getSndFileTransfer_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError (FileTransferMeta, [SndFileTransfer])) +getSndFileTransfer_ db userId fileId = runExceptT $ do + fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId + sndFileTransfers <- ExceptT $ getSndFileTransfers_ db userId fileId + pure (fileTransferMeta, sndFileTransfers) getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer]) getSndFileTransfers_ db userId fileId = @@ -2243,7 +2226,7 @@ getSndFileTransfers_ db userId fileId = (userId, fileId) where sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, AgentConnId, Maybe ContactName, Maybe ContactName)] -> Either StoreError [SndFileTransfer] - sndFileTransfers [] = Left $ SESndFileNotFound fileId + sndFileTransfers [] = Right [] sndFileTransfers fts = mapM sndFileTransfer fts sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId, contactName_, memberName_) = case contactName_ <|> memberName_ of @@ -3564,12 +3547,12 @@ getChatItemIdByFileId_ db userId fileId = (userId, fileId) updateDirectCIFileStatus :: forall d m. (MsgDirectionI d, StoreMonad m) => SQLiteStore -> User -> Int64 -> CIFileStatus d -> m AChatItem -updateDirectCIFileStatus st user@User {userId} fileId fileStatus = +updateDirectCIFileStatus st user fileId fileStatus = liftIOEither . withTransaction st $ \db -> runExceptT $ do aci@(AChatItem cType d cInfo ci) <- ExceptT $ getChatItemByFileId_ db user fileId case (cType, testEquality d $ msgDirection @d) of (SCTDirect, Just Refl) -> do - liftIO $ updateCIFileStatus_ db userId fileId fileStatus + liftIO $ updateCIFileStatus_ db user fileId fileStatus pure $ AChatItem SCTDirect d cInfo $ updateFileStatus ci fileStatus _ -> pure aci diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 8c200b067e..5f4aafc789 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -549,7 +549,7 @@ data RcvFileStatus | RFSAccepted RcvFileInfo | RFSConnected RcvFileInfo | RFSComplete RcvFileInfo - | RFSCancelled RcvFileInfo + | RFSCancelled (Maybe RcvFileInfo) deriving (Eq, Show, Generic) instance ToJSON RcvFileStatus where diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 5b79a664a1..72d374a161 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -620,7 +620,8 @@ viewFileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileI RFSAccepted _ -> "just started" RFSConnected _ -> "progress " <> fileProgress chunksNum chunkSize fileSize RFSComplete RcvFileInfo {filePath} -> "complete, path: " <> plain filePath - RFSCancelled RcvFileInfo {filePath} -> "cancelled, received part path: " <> plain filePath + RFSCancelled (Just RcvFileInfo {filePath}) -> "cancelled, received part path: " <> plain filePath + RFSCancelled Nothing -> "cancelled" listRecipients :: [SndFileTransfer] -> StyledString listRecipients = mconcat . intersperse ", " . map (ttyContact . recipientDisplayName) @@ -652,6 +653,7 @@ viewChatError = \case CEGroupInternal s -> ["chat group bug: " <> plain s] CEFileNotFound f -> ["file not found: " <> plain f] CEFileAlreadyReceiving f -> ["file is already accepted: " <> plain f] + CEFileCancelled f -> ["file cancelled: " <> plain f] CEFileAlreadyExists f -> ["file already exists: " <> plain f] CEFileRead f e -> ["cannot read file " <> plain f, sShow e] CEFileWrite f e -> ["cannot write file " <> plain f, sShow e] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 77c5827a0e..9a6f0b7be8 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -58,9 +58,11 @@ chatTests = do describe "sending and receiving files" $ do it "send and receive file" testFileTransfer it "send and receive a small file" testSmallFileTransfer - it "sender cancelled file transfer" testFileSndCancel + it "sender cancelled file transfer before transfer" testFileSndCancelBeforeTransfer + it "sender cancelled file transfer during transfer" testFileSndCancelDuringTransfer it "recipient cancelled file transfer" testFileRcvCancel it "send and receive file to group" testGroupFileTransfer + it "sender cancelled group file transfer before transfer" testGroupFileSndCancelBeforeTransfer describe "messages with files" $ do it "send and receive message with file" testMessageWithFile it "send and receive image" testSendImage @@ -1028,8 +1030,30 @@ testSmallFileTransfer = dest <- B.readFile "./tests/tmp/test.txt" dest `shouldBe` src -testFileSndCancel :: IO () -testFileSndCancel = +testFileSndCancelBeforeTransfer :: IO () +testFileSndCancelBeforeTransfer = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + 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" + alice ##> "/fc 1" + concurrentlyN_ + [ alice <## "cancelled sending file 1 (test.txt) to bob", + bob <## "alice cancelled sending file 1 (test.txt)" + ] + alice ##> "/fs 1" + alice <## "sending file 1 (test.txt) cancelled: bob" + alice <## "file transfer cancelled" + bob ##> "/fs 1" + bob <## "receiving file 1 (test.txt) cancelled" + bob ##> "/fr 1 ./tests/tmp" + bob <## "file cancelled: test.txt" + +testFileSndCancelDuringTransfer :: IO () +testFileSndCancelDuringTransfer = testChat2 aliceProfile bobProfile $ \alice bob -> do connectUsers alice bob @@ -1112,6 +1136,34 @@ testGroupFileTransfer = cath <## "completed receiving file 1 (test.jpg) from alice" ] +testGroupFileSndCancelBeforeTransfer :: IO () +testGroupFileSndCancelBeforeTransfer = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + alice #> "/f #team ./tests/fixtures/test.txt" + alice <## "use /fc 1 to cancel sending" + concurrentlyN_ + [ do + bob <# "#team alice> sends file test.txt (11 bytes / 11 bytes)" + bob <## "use /fr 1 [/ | ] to receive it", + do + cath <# "#team alice> sends file test.txt (11 bytes / 11 bytes)" + cath <## "use /fr 1 [/ | ] to receive it" + ] + alice ##> "/fc 1" + concurrentlyN_ + [ alice <## "cancelled sending file 1 (test.txt)", + bob <## "alice cancelled sending file 1 (test.txt)", + cath <## "alice cancelled sending file 1 (test.txt)" + ] + alice ##> "/fs 1" + alice <## "sending file 1 (test.txt): no file transfers, file transfer cancelled" + bob ##> "/fs 1" + bob <## "receiving file 1 (test.txt) cancelled" + bob ##> "/fr 1 ./tests/tmp" + bob <## "file cancelled: test.txt" + testMessageWithFile :: IO () testMessageWithFile = testChat2 aliceProfile bobProfile $ @@ -1845,15 +1897,19 @@ testNegotiateCall = alice #$> ("/_get chat @2 count=100", chat, [(1, "outgoing call: accepted")]) -- alice confirms call by sending WebRTC answer alice ##> ("/_call answer @2 " <> serialize testWebRTCSession) - alice <## "ok" - alice <## "message updated" + alice + <### [ "ok", + "message updated" + ] alice #$> ("/_get chat @2 count=100", chat, [(1, "outgoing call: connecting...")]) bob <## "call answer from alice" bob #$> ("/_get chat @2 count=100", chat, [(0, "incoming call: connecting...")]) -- participants can update calls as connected alice ##> "/_call status @2 connected" - alice <## "ok" - alice <## "message updated" + alice + <### [ "ok", + "message updated" + ] alice #$> ("/_get chat @2 count=100", chat, [(1, "outgoing call: in progress (00:00)")]) bob ##> "/_call status @2 connected" bob <## "ok" diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 29d76d9914..3b615ddffd 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -169,6 +169,9 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do 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.file.cancel" $ + "{\"event\":\"x.file.cancel\",\"params\":{\"msgId\":\"AQIDBA==\"}}" + #==# XFileCancel (SharedMsgId "\1\2\3\4") it "x.info" $ "{\"event\":\"x.info\",\"params\":{\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}}" #==# XInfo testProfile