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

xftp: sending file completion status (#2016)

Browse Source 
* xftp: sending file completion status

* fix type

* fix type 2

* fix
This commit is contained in:
Evgeny Poberezkin
2023-03-16 13:58:01 +00:00
committed by GitHub
parent 34a3387830
commit f379fd0f8c
1 changed files with 9 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
src/Simplex/Chat.hs
View File

@@ -2198,13 +2198,17 @@ processAgentMsgSndFile _corrId aFileId msg =
(Just sharedMsgId, Nothing) -> do
(ft, sfts) <- withStore $ \db -> getSndFileTransfer db user fileId
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
-- TODO either update database status or move to SFPROG
toView $ CRSndFileProgressXFTP user ci ft 1 1
case (rfds, sfts, d, cInfo) of
(rfd : _, sft : _, SMDSnd, DirectChat ct) ->
sendFileDescription sft rfd sharedMsgId $ sendDirectContactMessage ct
(rfd : _, sft : _, SMDSnd, DirectChat ct) -> do
msgDeliveryId <- sendFileDescription sft rfd sharedMsgId $ sendDirectContactMessage ct
withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId
(_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do
ms <- withStore' $ \db -> getGroupMembers db user g
forM_ (zip rfds $ memberFTs ms) $ \mt -> sendToMember mt `catchError` (toView . CRChatError (Just user))
-- TODO update database status and send event to view CRSndFileCompleteXFTP
pure ()
where
memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)]
memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts')
@@ -2217,18 +2221,16 @@ processAgentMsgSndFile _corrId aFileId msg =
useMember _ = Nothing
sendToMember :: (ValidFileDescription 'FRecipient, (Connection, SndFileTransfer)) -> m ()
sendToMember (rfd, (conn, sft)) =
sendFileDescription sft rfd sharedMsgId $ \msg' -> sendDirectMessage conn msg' $ GroupId groupId
void $ sendFileDescription sft rfd sharedMsgId $ \msg' -> sendDirectMessage conn msg' $ GroupId groupId
_ -> pure ()
_ -> pure () -- TODO error?
where
sendFileDescription :: SndFileTransfer -> ValidFileDescription 'FRecipient -> SharedMsgId -> (ChatMsgEvent 'Json -> m (SndMessage, Int64)) -> m ()
sendFileDescription :: SndFileTransfer -> ValidFileDescription 'FRecipient -> SharedMsgId -> (ChatMsgEvent 'Json -> m (SndMessage, Int64)) -> m Int64
sendFileDescription sft rfd msgId sendMsg = do
let rfdText = safeDecodeUtf8 $ strEncode rfd
withStore' $ \db -> updateSndFTDescrXFTP db user sft rfdText
partSize <- asks $ xftpDescrPartSize . config
msgDeliveryId <- sendParts 1 partSize rfdText
-- msgDeliveryId <- sendFileDescription_ rfd sharedMsgId sendMsg
withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId
sendParts 1 partSize rfdText
where
sendParts partNo partSize rfdText = do
let (part, rest) = T.splitAt partSize rfdText