mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-24 19:35:33 +00:00
core: improve file cancel (#627)
Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
JRoberts
+112
-113
@@ -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
|
||||
|
||||
@@ -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}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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]
|
||||
|
||||
+69
-86
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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]
|
||||
|
||||
Reference in New Issue
Block a user