mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-04-27 04:15:45 +00:00
core: use XFTP to send and receive files (#1993)
* core: use XFTP to send and receive files * xftp files progress * xftp reception stubs, migration * update simplexmq * xftp sequence diagram * additional chat events * send file via XFTP * send XFTP file description inline when file is uploaded
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
13706c4f64
commit
d7f9e17bcb
+227
-74
@@ -69,7 +69,7 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (base64P)
|
||||
import Simplex.Messaging.Protocol (ErrorType (..), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI)
|
||||
import Simplex.Messaging.Protocol (EntityId, ErrorType (..), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolType (..), ProtocolTypeI)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport.Client (defaultSocksProxy)
|
||||
@@ -105,7 +105,9 @@ defaultChatConfig =
|
||||
},
|
||||
tbqSize = 1024,
|
||||
fileChunkSize = 15780, -- do not change
|
||||
xftpDescrPartSize = 14000,
|
||||
inlineFiles = defaultInlineFilesConfig,
|
||||
xftpFileConfig = Nothing,
|
||||
logLevel = CLLImportant,
|
||||
subscriptionEvents = False,
|
||||
hostEvents = False,
|
||||
@@ -165,7 +167,8 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
||||
cleanupManagerAsync <- newTVarIO Nothing
|
||||
timedItemThreads <- atomically TM.empty
|
||||
showLiveItems <- newTVarIO False
|
||||
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, logFilePath = logFile}
|
||||
userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg
|
||||
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, logFilePath = logFile}
|
||||
where
|
||||
configServers :: DefaultAgentServers
|
||||
configServers =
|
||||
@@ -380,9 +383,9 @@ processChatCommand = \case
|
||||
if isVoice mc && not (featureAllowed SCFVoice forUser ct)
|
||||
then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFVoice))
|
||||
else do
|
||||
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct
|
||||
(fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct
|
||||
timed_ <- sndContactCITimed live ct
|
||||
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_ timed_
|
||||
(msgContainer, quotedItem_) <- prepareMsg fInv_ timed_
|
||||
(msg@SndMessage {sharedMsgId}, _) <- sendDirectContactMessage ct (XMsgNew msgContainer)
|
||||
case ft_ of
|
||||
Just ft@FileTransferMeta {fileInline = Just IFMSent} ->
|
||||
@@ -396,23 +399,30 @@ processChatCommand = \case
|
||||
where
|
||||
setupSndFileTransfer :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
|
||||
setupSndFileTransfer ct = forM file_ $ \file -> do
|
||||
(fileSize, chSize, fileInline) <- checkSndFile mc file 1
|
||||
(agentConnId_, fileConnReq) <-
|
||||
if isJust fileInline
|
||||
then pure (Nothing, Nothing)
|
||||
else bimap Just Just <$> withAgent (\a -> createConnection a (aUserId user) True SCMInvitation Nothing)
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
|
||||
withStore' $ \db -> do
|
||||
ft@FileTransferMeta {fileId} <- createSndDirectFileTransfer db userId ct file fileInvitation agentConnId_ chSize
|
||||
fileStatus <- case fileInline of
|
||||
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer
|
||||
_ -> pure CIFSSndStored
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus}
|
||||
pure (fileInvitation, ciFile, ft)
|
||||
(fileSize, fileMode) <- checkSndFile mc file 1
|
||||
case fileMode of
|
||||
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
||||
SendFileXFTP xftpCfg -> xftpSndFileTransfer user file fileSize xftpCfg 1 $ CGContact ct
|
||||
where
|
||||
smpSndFileTransfer :: FilePath -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
smpSndFileTransfer file fileSize fileInline = do
|
||||
(agentConnId_, fileConnReq) <-
|
||||
if isJust fileInline
|
||||
then pure (Nothing, Nothing)
|
||||
else bimap Just Just <$> withAgent (\a -> createConnection a (aUserId user) True SCMInvitation Nothing)
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
withStore' $ \db -> do
|
||||
ft@FileTransferMeta {fileId} <- createSndDirectFileTransfer db userId ct file fileInvitation agentConnId_ chSize
|
||||
fileStatus <- case fileInline of
|
||||
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1
|
||||
_ -> pure CIFSSndStored
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus}
|
||||
pure (fileInvitation, ciFile, ft)
|
||||
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
|
||||
prepareMsg fileInvitation_ timed_ = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
prepareMsg fInv_ timed_ = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
Just quotedItemId -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
withStore $ \db -> getDirectChatItem db user chatId quotedItemId
|
||||
@@ -420,7 +430,7 @@ processChatCommand = \case
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing}
|
||||
qmc = quoteContent origQmc file
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
where
|
||||
quoteData :: ChatItem c d -> m (MsgContent, CIQDirection 'CTDirect, Bool)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote
|
||||
@@ -433,9 +443,9 @@ processChatCommand = \case
|
||||
if isVoice mc && not (groupFeatureAllowed SGFVoice gInfo)
|
||||
then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText GFVoice))
|
||||
else do
|
||||
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo (length $ filter memberCurrent ms)
|
||||
(fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo (length $ filter memberCurrent ms)
|
||||
timed_ <- sndGroupCITimed live gInfo
|
||||
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_ timed_ membership
|
||||
(msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership
|
||||
msg@SndMessage {sharedMsgId} <- sendGroupMessage user gInfo ms (XMsgNew msgContainer)
|
||||
mapM_ (sendGroupFileInline ms sharedMsgId) ft_
|
||||
ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
|
||||
@@ -446,14 +456,21 @@ processChatCommand = \case
|
||||
where
|
||||
setupSndFileTransfer :: GroupInfo -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
|
||||
setupSndFileTransfer gInfo n = forM file_ $ \file -> do
|
||||
(fileSize, chSize, fileInline) <- checkSndFile mc file $ fromIntegral n
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline, fileDescr = Nothing}
|
||||
fileStatus = if fileInline == Just IFMSent then CIFSSndTransfer else CIFSSndStored
|
||||
withStore' $ \db -> do
|
||||
ft@FileTransferMeta {fileId} <- createSndGroupFileTransfer db userId gInfo file fileInvitation chSize
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus}
|
||||
pure (fileInvitation, ciFile, ft)
|
||||
(fileSize, fileMode) <- checkSndFile mc file $ fromIntegral n
|
||||
case fileMode of
|
||||
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
||||
SendFileXFTP xftpCfg -> xftpSndFileTransfer user file fileSize xftpCfg n $ CGGroup gInfo
|
||||
where
|
||||
smpSndFileTransfer :: FilePath -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
smpSndFileTransfer file fileSize fileInline = do
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline, fileDescr = Nothing}
|
||||
fileStatus = if fileInline == Just IFMSent then CIFSSndTransfer 0 1 else CIFSSndStored
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
withStore' $ \db -> do
|
||||
ft@FileTransferMeta {fileId} <- createSndGroupFileTransfer db userId gInfo file fileInvitation chSize
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus}
|
||||
pure (fileInvitation, ciFile, ft)
|
||||
sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m ()
|
||||
sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} =
|
||||
when (fileInline == Just IFMSent) . forM_ ms $ \m ->
|
||||
@@ -465,8 +482,8 @@ processChatCommand = \case
|
||||
sendMemberFileInline m conn ft sharedMsgId
|
||||
processMember _ = pure ()
|
||||
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup))
|
||||
prepareMsg fileInvitation_ timed_ membership = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
prepareMsg fInv_ timed_ membership = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
Just quotedItemId -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
withStore $ \db -> getGroupChatItem db user chatId quotedItemId
|
||||
@@ -474,7 +491,7 @@ processChatCommand = \case
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId}
|
||||
qmc = quoteContent origQmc file
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
where
|
||||
quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote
|
||||
@@ -507,6 +524,14 @@ processChatCommand = \case
|
||||
qText = msgContentText qmc
|
||||
qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_
|
||||
qTextOrFile = if T.null qText then qFileName else qText
|
||||
xftpSndFileTransfer :: User -> FilePath -> Integer -> XFTPFileConfig -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
xftpSndFileTransfer user file fileSize XFTPFileConfig {tempDirectory} n contactOrGroup = do
|
||||
let fileName = takeFileName file
|
||||
fInv = xftpFileInvitation fileName fileSize
|
||||
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) file n tempDirectory
|
||||
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv $ AgentSndFileId aFileId
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
|
||||
pure (fInv, ciFile, ft)
|
||||
unzipMaybe3 :: Maybe (a, b, c) -> (Maybe a, Maybe b, Maybe c)
|
||||
unzipMaybe3 (Just (a, b, c)) = (Just a, Just b, Just c)
|
||||
unzipMaybe3 _ = (Nothing, Nothing, Nothing)
|
||||
@@ -1350,7 +1375,7 @@ processChatCommand = \case
|
||||
updateGroupProfileByName gName $ \p ->
|
||||
p {groupPreferences = Just . setGroupPreference' SGFTimedMessages pref $ groupPreferences p}
|
||||
QuitChat -> liftIO exitSuccess
|
||||
ShowVersion -> pure $ CRVersionInfo $ coreVersionInfo $(buildTimestampQ) "" -- $(simplexmqCommitQ)
|
||||
ShowVersion -> pure $ CRVersionInfo $ coreVersionInfo $(buildTimestampQ) $(simplexmqCommitQ)
|
||||
DebugLocks -> do
|
||||
chatLockName <- atomically . tryReadTMVar =<< asks chatLock
|
||||
agentLocks <- withAgent debugAgentLocks
|
||||
@@ -1441,14 +1466,21 @@ processChatCommand = \case
|
||||
contactMember Contact {contactId} =
|
||||
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
|
||||
cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft
|
||||
checkSndFile :: MsgContent -> FilePath -> Integer -> m (Integer, Integer, Maybe InlineFileMode)
|
||||
checkSndFile :: MsgContent -> FilePath -> Integer -> m (Integer, SendFileMode)
|
||||
checkSndFile mc f n = do
|
||||
fsFilePath <- toFSFilePath f
|
||||
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
|
||||
ChatConfig {fileChunkSize, inlineFiles} <- asks config
|
||||
xftpCfg <- readTVarIO =<< asks userXFTPFileConfig
|
||||
fileSize <- getFileSize fsFilePath
|
||||
let chunks = - ((- fileSize) `div` fileChunkSize)
|
||||
pure (fileSize, fileChunkSize, inlineFileMode mc inlineFiles chunks n)
|
||||
fileInline = inlineFileMode mc inlineFiles chunks n
|
||||
fileMode = case xftpCfg of
|
||||
Just cfg
|
||||
| fileInline == Just IFMSent || fileSize < minFileSize cfg -> SendFileSMP fileInline
|
||||
| otherwise -> SendFileXFTP cfg
|
||||
_ -> SendFileSMP fileInline
|
||||
pure (fileSize, fileMode)
|
||||
inlineFileMode mc InlineFilesConfig {offerChunks, sendChunks, totalSendChunks} chunks n
|
||||
| chunks > offerChunks = Nothing
|
||||
| chunks <= sendChunks && chunks * n <= totalSendChunks && isVoice mc = Just IFMSent
|
||||
@@ -1711,18 +1743,22 @@ toFSFilePath f =
|
||||
maybe f (<> "/" <> f) <$> (readTVarIO =<< asks filesFolder)
|
||||
|
||||
acceptFileReceive :: forall m. ChatMonad m => User -> RcvFileTransfer -> Maybe Bool -> Maybe FilePath -> m AChatItem
|
||||
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId} rcvInline_ filePath_ = do
|
||||
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, rcvFileDescription, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId} rcvInline_ filePath_ = do
|
||||
unless (fileStatus == RFSNew) $ case fileStatus of
|
||||
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
|
||||
_ -> throwChatError $ CEFileAlreadyReceiving fName
|
||||
case fileConnReq of
|
||||
case (rcvFileDescription, fileConnReq) of
|
||||
-- direct file protocol
|
||||
Just connReq -> do
|
||||
(Nothing, Just connReq) -> do
|
||||
connIds <- joinAgentConnectionAsync user True connReq . directMessage $ XFileAcpt fName
|
||||
filePath <- getRcvFilePath fileId filePath_ fName
|
||||
withStore $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath
|
||||
-- group & direct file protocol
|
||||
Nothing -> do
|
||||
(Just _fd, _) -> do
|
||||
-- check if file description is fully received, error otherwise
|
||||
-- pass file description to the agent and save AgentRcvFileId
|
||||
throwChatError $ CEFileInternal "XFTP file receiption not implemented"
|
||||
_ -> do
|
||||
chatRef <- withStore $ \db -> getChatRefByFileId db user fileId
|
||||
case (chatRef, grpMemberId) of
|
||||
(ChatRef CTDirect contactId, Nothing) -> do
|
||||
@@ -1837,18 +1873,24 @@ deleteGroupLink_ user gInfo conn = do
|
||||
deleteAgentConnectionAsync user $ aConnId conn
|
||||
withStore' $ \db -> deleteGroupLink db user gInfo
|
||||
|
||||
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
agentSubscriber :: forall m. (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
agentSubscriber = do
|
||||
q <- asks $ subQ . smpAgent
|
||||
l <- asks chatLock
|
||||
forever $ do
|
||||
(corrId, connId, APC _ msg) <- atomically $ readTBQueue q
|
||||
let name = "agentSubscriber connId=" <> str connId <> " corrId=" <> str corrId <> " msg=" <> str (aCommandTag msg)
|
||||
withLock l name . void . runExceptT $
|
||||
processAgentMessage corrId connId msg `catchError` (toView . CRChatError Nothing)
|
||||
forever $ atomically (readTBQueue q) >>= void . process l
|
||||
where
|
||||
str :: StrEncoding a => a -> String
|
||||
str = B.unpack . strEncode
|
||||
process :: Lock -> (ACorrId, EntityId, APartyCmd 'Agent) -> m (Either ChatError ())
|
||||
process l (corrId, entId, APC e msg) = run $ case e of
|
||||
SAENone -> processAgentMessageNoConn msg
|
||||
SAEConn -> processAgentMessage corrId entId msg
|
||||
SAERcvFile -> processAgentMsgRcvFile corrId entId msg
|
||||
SAESndFile -> processAgentMsgSndFile corrId entId msg
|
||||
where
|
||||
run action = do
|
||||
let name = "agentSubscriber entity=" <> show e <> " entId=" <> str entId <> " msg=" <> str (aCommandTag msg)
|
||||
withLock l name $ runExceptT $ action `catchError` (toView . CRChatError Nothing)
|
||||
str :: StrEncoding a => a -> String
|
||||
str = B.unpack . strEncode
|
||||
|
||||
type AgentBatchSubscribe m = AgentClient -> [ConnId] -> ExceptT AgentErrorType m (Map ConnId (Either AgentErrorType ()))
|
||||
|
||||
@@ -2066,9 +2108,7 @@ expireChatItems user@User {userId} ttl sync = do
|
||||
membersToDelete <- withStore' $ \db -> getGroupMembersForExpiration db user gInfo
|
||||
forM_ membersToDelete $ \m -> withStore' $ \db -> deleteGroupMember db user m
|
||||
|
||||
processAgentMessage :: forall e m. (AEntityI e, ChatMonad m) => ACorrId -> ConnId -> ACommand 'Agent e -> m ()
|
||||
processAgentMessage _ "" msg =
|
||||
processAgentMessageNoConn msg `catchError` (toView . CRChatError Nothing)
|
||||
processAgentMessage :: forall m. ChatMonad m => ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
|
||||
processAgentMessage _ connId (DEL_RCVQ srv qId err_) =
|
||||
toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_
|
||||
processAgentMessage _ connId DEL_CONN =
|
||||
@@ -2078,7 +2118,7 @@ processAgentMessage corrId connId msg =
|
||||
Just user -> processAgentMessageConn user corrId connId msg `catchError` (toView . CRChatError (Just user))
|
||||
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
|
||||
|
||||
processAgentMessageNoConn :: forall e m. ChatMonad m => ACommand 'Agent e -> m ()
|
||||
processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone -> m ()
|
||||
processAgentMessageNoConn = \case
|
||||
CONNECT p h -> hostEvent $ CRHostConnected p h
|
||||
DISCONNECT p h -> hostEvent $ CRHostDisconnected p h
|
||||
@@ -2086,7 +2126,6 @@ processAgentMessageNoConn = \case
|
||||
UP srv conns -> serverEvent srv conns CRContactsSubscribed "connected"
|
||||
SUSPENDED -> toView CRChatSuspended
|
||||
DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId
|
||||
_ -> pure ()
|
||||
where
|
||||
hostEvent :: ChatResponse -> m ()
|
||||
hostEvent = whenM (asks $ hostEvents . config) . toView
|
||||
@@ -2095,7 +2134,92 @@ processAgentMessageNoConn = \case
|
||||
toView $ event srv cs
|
||||
showToast ("server " <> str) (safeDecodeUtf8 $ strEncode host)
|
||||
|
||||
processAgentMessageConn :: forall e m. (AEntityI e, ChatMonad m) => User -> ACorrId -> ConnId -> ACommand 'Agent e -> m ()
|
||||
processAgentMsgSndFile :: forall m. ChatMonad m => ACorrId -> SndFileId -> ACommand 'Agent 'AESndFile -> m ()
|
||||
processAgentMsgSndFile _corrId aFileId msg =
|
||||
withStore' (`getUserByASndFileId` AgentSndFileId aFileId) >>= \case
|
||||
Just user -> process user `catchError` (toView . CRChatError (Just user))
|
||||
_ -> throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId
|
||||
where
|
||||
process :: User -> m ()
|
||||
process user = do
|
||||
ft@FileTransferMeta {fileId} <- withStore $ \db -> getAgentSndFileXFTP db user $ AgentSndFileId aFileId
|
||||
case msg of
|
||||
SFPROG _sent _total -> do
|
||||
-- update chat item status
|
||||
-- send status to view
|
||||
pure ()
|
||||
SFDONE _sndDescr rfds -> do
|
||||
AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}} <-
|
||||
withStore $ \db -> getChatItemByFileId db user fileId
|
||||
case (msgId_, itemDeleted) of
|
||||
(Just sharedMsgId, Nothing) -> case (rfds, d, cInfo) of
|
||||
(rfd : _, SMDSnd, DirectChat ct) -> do
|
||||
let rfdText = safeDecodeUtf8 $ strEncode rfd
|
||||
withStore' $ \db -> createSndDirectFTDescrXFTP db user ct ft rfdText
|
||||
-- TODO update chat item status to show 100% progress
|
||||
sendDirectFileDescription ct rfdText ft sharedMsgId
|
||||
(_, SMDSnd, GroupChat _g) -> do
|
||||
-- store file descriptions and files to snd_files
|
||||
-- send messages with descriptions to the recipients
|
||||
-- update chat item file status (CIFileStatus)
|
||||
-- update sent file status
|
||||
-- ??? possibly another event as we need one event per group, not per member
|
||||
-- toView $ CRSndFileComplete user ci ft
|
||||
pure ()
|
||||
_ -> pure () -- TODO error
|
||||
_ -> pure () -- TODO error
|
||||
pure ()
|
||||
where
|
||||
sendDirectFileDescription :: Contact -> Text -> FileTransferMeta -> SharedMsgId -> m ()
|
||||
sendDirectFileDescription ct rfd ft sharedMsgId = do
|
||||
msgDeliveryId <- sendFileDescription_ rfd sharedMsgId $ sendDirectContactMessage ct
|
||||
withStore' $ \db -> updateSndDirectFTDelivery db ct ft msgDeliveryId
|
||||
|
||||
_sendMemberFileDescription :: GroupMember -> Connection -> Text -> FileTransferMeta -> SharedMsgId -> m ()
|
||||
_sendMemberFileDescription m@GroupMember {groupId} conn rfd ft sharedMsgId = do
|
||||
msgDeliveryId <- sendFileDescription_ rfd sharedMsgId $ \msg' -> sendDirectMessage conn msg' $ GroupId groupId
|
||||
withStore' $ \db -> updateSndGroupFTDelivery db m conn ft msgDeliveryId
|
||||
|
||||
sendFileDescription_ :: Text -> SharedMsgId -> (ChatMsgEvent 'Json -> m (SndMessage, Int64)) -> m Int64
|
||||
sendFileDescription_ rfdText msgId sendMsg = do
|
||||
partSize <- asks $ xftpDescrPartSize . config
|
||||
sendParts 1 partSize rfdText
|
||||
where
|
||||
sendParts partNo partSize rfd = do
|
||||
let (part, rest) = T.splitAt partSize rfd
|
||||
complete = T.null rest
|
||||
fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete}
|
||||
(_, msgDeliveryId) <- sendMsg $ XMsgFileDescr {msgId, fileDescr}
|
||||
if complete
|
||||
then pure msgDeliveryId
|
||||
else sendParts (partNo + 1) partSize rest
|
||||
|
||||
processAgentMsgRcvFile :: forall m. ChatMonad m => ACorrId -> RcvFileId -> ACommand 'Agent 'AERcvFile -> m ()
|
||||
processAgentMsgRcvFile _corrId aFileId msg =
|
||||
withStore' (`getUserByARcvFileId` AgentRcvFileId aFileId) >>= \case
|
||||
Just user -> process user `catchError` (toView . CRChatError (Just user))
|
||||
_ -> throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId
|
||||
where
|
||||
process :: User -> m ()
|
||||
process user = do
|
||||
_rcvFile <- withStore (\db -> getAgentRcvFileXFTP db user $ AgentRcvFileId aFileId)
|
||||
-- >>= updateConnStatus
|
||||
-- load file transfer meta (add chat item status to type and also contact/group)
|
||||
case msg of
|
||||
RFPROG _sent _total -> do
|
||||
-- update chat item status
|
||||
-- send status to view
|
||||
pure ()
|
||||
RFDONE _filePath -> do
|
||||
-- update chat item status
|
||||
-- send status to view
|
||||
pure ()
|
||||
RFERR _e -> do
|
||||
-- update chat item status
|
||||
-- send status to view
|
||||
pure ()
|
||||
|
||||
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
|
||||
processAgentMessageConn user _ agentConnId END =
|
||||
withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= \case
|
||||
RcvDirectMsgConnection _ (Just ct@Contact {localDisplayName = c}) -> do
|
||||
@@ -2186,6 +2310,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
updateChatLock "directMessage" event
|
||||
case event of
|
||||
XMsgNew mc -> newContentMessage ct mc msg msgMeta
|
||||
XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct sharedMsgId fileDescr msgMeta
|
||||
XMsgFileCancel sharedMsgId -> cancelMessageFile ct sharedMsgId msgMeta
|
||||
XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct sharedMsgId mContent msg msgMeta ttl live
|
||||
XMsgDel sharedMsgId _ -> messageDelete ct sharedMsgId msg msgMeta
|
||||
-- TODO discontinue XFile
|
||||
@@ -2398,6 +2524,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
updateChatLock "groupMessage" event
|
||||
case event of
|
||||
XMsgNew mc -> canSend $ newGroupContentMessage gInfo m mc msg msgMeta
|
||||
XMsgFileDescr sharedMsgId fileDescr -> canSend $ groupMessageFileDescription gInfo m sharedMsgId fileDescr msgMeta
|
||||
XMsgFileCancel sharedMsgId -> cancelGroupMessageFile gInfo m sharedMsgId msgMeta
|
||||
XMsgUpdate sharedMsgId mContent ttl live -> canSend $ groupMessageUpdate gInfo m sharedMsgId mContent msg msgMeta ttl live
|
||||
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m sharedMsgId memberId msg
|
||||
-- TODO discontinue XFile
|
||||
@@ -2459,7 +2587,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
CON -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateSndFileStatus db ft FSConnected
|
||||
updateDirectCIFileStatus db user fileId CIFSSndTransfer
|
||||
updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
|
||||
toView $ CRSndFileStart user ci ft
|
||||
sendFileChunk user ft
|
||||
SENT msgId -> do
|
||||
@@ -2535,7 +2663,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
startReceivingFile ft@RcvFileTransfer {fileId} = do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateRcvFileStatus db ft FSConnected
|
||||
liftIO $ updateCIFileStatus db user fileId CIFSRcvTransfer
|
||||
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
|
||||
getChatItemByFileId db user fileId
|
||||
toView $ CRRcvFileStart user ci
|
||||
|
||||
@@ -2637,7 +2765,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
where
|
||||
s = " " <> name <> "=" <> B.unpack (strEncode $ toCMEventTag event)
|
||||
|
||||
withCompletedCommand :: Connection -> ACommand 'Agent e -> (CommandData -> m ()) -> m ()
|
||||
withCompletedCommand :: forall e. AEntityI e => Connection -> ACommand 'Agent e -> (CommandData -> m ()) -> m ()
|
||||
withCompletedCommand Connection {connId} agentMsg action = do
|
||||
let agentMsgTag = APCT (sAEntity @e) $ aCommandTag agentMsg
|
||||
cmdData_ <- withStore' $ \db -> getCommandDataByCorrId db user corrId
|
||||
@@ -2729,7 +2857,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
newContentMessage ct@Contact {localDisplayName = c, contactUsed, chatSettings} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
let ExtMsgContent content fileInvitation_ _ _ = mcExtMsgContent mc
|
||||
let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc
|
||||
if isVoice content && not (featureAllowed SCFVoice forContact ct)
|
||||
then do
|
||||
void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
|
||||
@@ -2738,7 +2866,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc
|
||||
timed_ = rcvContactCITimed ct itemTTL
|
||||
live = fromMaybe False live_
|
||||
ciFile_ <- processFileInvitation fileInvitation_ content $ \db -> createRcvFileTransfer db userId ct
|
||||
ciFile_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
|
||||
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) ciFile_ timed_ live
|
||||
when (enableNtfs chatSettings) $ do
|
||||
showMsgToast (c <> "> ") content formattedText
|
||||
@@ -2749,11 +2877,36 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
||||
pure ci
|
||||
|
||||
messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> MsgMeta -> m ()
|
||||
messageFileDescription ct _sharedMsgId _fileDescr msgMeta = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
-- find the original chat item and file
|
||||
-- re-create file item if it does not exist
|
||||
-- check file description part number
|
||||
-- append file description part to the record
|
||||
-- if file description is complete send it to the agent to receive
|
||||
pure ()
|
||||
|
||||
groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> MsgMeta -> m ()
|
||||
groupMessageFileDescription _gInfo _m _sharedMsgId _fileDescr _msgMeta = do
|
||||
pure ()
|
||||
|
||||
cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m ()
|
||||
cancelMessageFile ct _sharedMsgId msgMeta = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
-- find the original chat item and file
|
||||
-- mark file as cancelled, remove description if excists
|
||||
pure ()
|
||||
|
||||
cancelGroupMessageFile :: GroupInfo -> GroupMember -> SharedMsgId -> MsgMeta -> m ()
|
||||
cancelGroupMessageFile _gInfo _m _sharedMsgId _msgMeta = do
|
||||
pure ()
|
||||
|
||||
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv))
|
||||
processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv@FileInvitation {fileName, fileSize} -> do
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
inline <- receiveInlineMode fInv (Just mc) chSize
|
||||
ft@RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFT db fInv inline chSize
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
inline <- receiveInlineMode fInv (Just mc) fileChunkSize
|
||||
ft@RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFT db fInv inline fileChunkSize
|
||||
(filePath, fileStatus) <- case inline of
|
||||
Just IFMSent -> do
|
||||
fPath <- getRcvFilePath fileId Nothing fileName
|
||||
@@ -2886,9 +3039,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
processFileInvitation' ct@Contact {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
inline <- receiveInlineMode fInv Nothing chSize
|
||||
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFileTransfer db userId ct fInv inline chSize
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
||||
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize
|
||||
let ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation}
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
||||
@@ -2898,9 +3051,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- TODO remove once XFile is discontinued
|
||||
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
processGroupFileInvitation' gInfo m@GroupMember {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
inline <- receiveInlineMode fInv Nothing chSize
|
||||
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvGroupFileTransfer db userId m fInv inline chSize
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
||||
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
|
||||
let ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation}
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
@@ -2909,8 +3062,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
setActive $ ActiveG g
|
||||
|
||||
receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> m (Maybe InlineFileMode)
|
||||
receiveInlineMode FileInvitation {fileSize, fileInline} mc_ chSize = case fileInline of
|
||||
Just mode -> do
|
||||
receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of
|
||||
(Just mode, Nothing) -> do
|
||||
InlineFilesConfig {receiveChunks, receiveInstant} <- asks $ inlineFiles . config
|
||||
pure $ if fileSize <= receiveChunks * chSize then inline' receiveInstant else Nothing
|
||||
where
|
||||
@@ -2941,7 +3094,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- receiving inline
|
||||
_ -> do
|
||||
event <- withStore $ \db -> do
|
||||
ci <- updateDirectCIFileStatus db user fileId CIFSSndTransfer
|
||||
ci <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
|
||||
sft <- liftIO $ createSndDirectInlineFT db ct ft
|
||||
pure $ CRSndFileStart user ci sft
|
||||
toView event
|
||||
@@ -2953,7 +3106,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
|
||||
checkSndInlineFTComplete :: Connection -> AgentMsgId -> m ()
|
||||
checkSndInlineFTComplete conn agentMsgId = do
|
||||
ft_ <- withStore' $ \db -> getSndInlineFTViaMsgDelivery db user conn agentMsgId
|
||||
ft_ <- withStore' $ \db -> getSndFTViaMsgDelivery db user conn agentMsgId
|
||||
forM_ ft_ $ \ft@SndFileTransfer {fileId} -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateSndFileStatus db ft FSComplete
|
||||
@@ -3020,7 +3173,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
(_, Just conn) -> do
|
||||
-- receiving inline
|
||||
event <- withStore $ \db -> do
|
||||
ci <- updateDirectCIFileStatus db user fileId CIFSSndTransfer
|
||||
ci <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
|
||||
sft <- liftIO $ createSndGroupInlineFT db m conn ft
|
||||
pure $ CRSndFileStart user ci sft
|
||||
toView event
|
||||
|
||||
Reference in New Issue
Block a user