dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-04-26 15:18:01 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: use XFTP to send and receive files (#1993)

Browse Source 
* 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
2023-03-13 10:30:32 +00:00
committed by GitHub
parent 13706c4f64
commit d7f9e17bcb
13 changed files with 580 additions and 153 deletions
Download Patch File Download Diff File Expand all files Collapse all files

301
src/Simplex/Chat.hs
View File

@@ -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

2
src/Simplex/Chat/Archive.hs
View File

@@ -65,7 +65,7 @@ importArchive cfg@ArchiveConfig {archivePath} =
backup f = whenM (doesFileExist f) $ copyFile f $ f <> ".bak"
withTempDir :: ChatMonad m => ArchiveConfig -> (String -> (FilePath -> m ()) -> m ())
withTempDir cfg = case parentTempDirectory cfg of
withTempDir cfg = case parentTempDirectory (cfg :: ArchiveConfig) of
Just tmpDir -> withTempDirectory tmpDir
_ -> withSystemTempDirectory

30
src/Simplex/Chat/Controller.hs
View File

@@ -105,7 +105,9 @@ data ChatConfig = ChatConfig
defaultServers :: DefaultAgentServers,
tbqSize :: Natural,
fileChunkSize :: Integer,
xftpDescrPartSize :: Int,
inlineFiles :: InlineFilesConfig,
xftpFileConfig :: Maybe XFTPFileConfig, -- Nothing - XFTP is disabled
subscriptionEvents :: Bool,
hostEvents :: Bool,
logLevel :: ChatLogLevel,
@@ -168,6 +170,7 @@ data ChatController = ChatController
cleanupManagerAsync :: TVar (Maybe (Async ())),
timedItemThreads :: TMap (ChatRef, ChatItemId) (TVar (Maybe (Weak ThreadId))),
showLiveItems :: TVar Bool,
userXFTPFileConfig :: TVar (Maybe XFTPFileConfig),
logFilePath :: Maybe FilePath
}
@@ -421,9 +424,12 @@ data ChatResponse
| CRContactRequestAlreadyAccepted {user :: User, contact :: Contact}
| CRLeftMemberUser {user :: User, groupInfo :: GroupInfo}
| CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo}
| CRRcvFileDescrReady {user :: User, chatItem :: AChatItem}
| CRRcvFileAccepted {user :: User, chatItem :: AChatItem}
| CRRcvFileAcceptedSndCancelled {user :: User, rcvFileTransfer :: RcvFileTransfer}
| CRRcvFileDescrNotReady {user :: User, chatItem :: AChatItem}
| CRRcvFileStart {user :: User, chatItem :: AChatItem}
| CRRcvFileProgressXFTP {user :: User, chatItem :: AChatItem, receivedChunks :: Int, totalChunks :: Int}
| CRRcvFileComplete {user :: User, chatItem :: AChatItem}
| CRRcvFileCancelled {user :: User, rcvFileTransfer :: RcvFileTransfer}
| CRRcvFileSndCancelled {user :: User, rcvFileTransfer :: RcvFileTransfer}
@@ -432,6 +438,10 @@ data ChatResponse
| CRSndFileCancelled {chatItem :: AChatItem, sndFileTransfer :: SndFileTransfer}
| CRSndFileRcvCancelled {user :: User, chatItem :: AChatItem, sndFileTransfer :: SndFileTransfer}
| CRSndGroupFileCancelled {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta, sndFileTransfers :: [SndFileTransfer]}
| CRSndFileStartXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta}
| CRSndFileProgressXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta, sentChunks :: Int, totalChunks :: Int}
| CRSndFileCompleteXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta}
| CRSndFileCancelledXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta}
| CRUserProfileUpdated {user :: User, fromProfile :: Profile, toProfile :: Profile}
| CRContactAliasUpdated {user :: User, toContact :: Contact}
| CRConnectionAliasUpdated {user :: User, toConnection :: PendingContactConnection}
@@ -608,6 +618,19 @@ instance ToJSON ComposedMessage where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data XFTPFileConfig = XFTPFileConfig
{ minFileSize :: Integer,
tempDirectory :: Maybe FilePath
}
deriving (Show, Generic, FromJSON)
defaultXFTPFileConfig :: XFTPFileConfig
defaultXFTPFileConfig = XFTPFileConfig {minFileSize = 0, tempDirectory = Nothing}
instance ToJSON XFTPFileConfig where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data NtfMsgInfo = NtfMsgInfo {msgTs :: UTCTime, msgFlags :: MsgFlags}
deriving (Show, Generic)
@@ -668,6 +691,11 @@ data CoreVersionInfo = CoreVersionInfo
instance ToJSON CoreVersionInfo where toEncoding = J.genericToEncoding J.defaultOptions
data SendFileMode
= SendFileSMP (Maybe InlineFileMode)
| SendFileXFTP XFTPFileConfig
deriving (Show, Generic)
data ChatError
= ChatError {errorType :: ChatErrorType}
| ChatErrorAgent {agentError :: AgentErrorType, connectionEntity_ :: Maybe ConnectionEntity}
@@ -682,6 +710,8 @@ instance ToJSON ChatError where
data ChatErrorType
= CENoActiveUser
| CENoConnectionUser {agentConnId :: AgentConnId}
| CENoSndFileUser {agentSndFileId :: AgentSndFileId}
| CENoRcvFileUser {agentRcvFileId :: AgentRcvFileId}
| CEActiveUserExists -- TODO delete
| CEUserExists {contactName :: ContactName}
| CEDifferentActiveUser {commandUserId :: UserId, activeUserId :: UserId}

67
src/Simplex/Chat/Messages.hs
View File

@@ -13,6 +13,7 @@
module Simplex.Chat.Messages where
import Control.Applicative ((<|>))
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J
import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -418,12 +419,12 @@ instance MsgDirectionI d => ToJSON (CIFile d) where
data CIFileStatus (d :: MsgDirection) where
CIFSSndStored :: CIFileStatus 'MDSnd
CIFSSndTransfer :: CIFileStatus 'MDSnd
CIFSSndTransfer :: {sndProgress :: Int, sndTotal :: Int} -> CIFileStatus 'MDSnd
CIFSSndCancelled :: CIFileStatus 'MDSnd
CIFSSndComplete :: CIFileStatus 'MDSnd
CIFSRcvInvitation :: CIFileStatus 'MDRcv
CIFSRcvAccepted :: CIFileStatus 'MDRcv
CIFSRcvTransfer :: CIFileStatus 'MDRcv
CIFSRcvTransfer :: {rcvProgress :: Int, rcvTotal :: Int} -> CIFileStatus 'MDRcv
CIFSRcvComplete :: CIFileStatus 'MDRcv
CIFSRcvCancelled :: CIFileStatus 'MDRcv
@@ -434,18 +435,18 @@ deriving instance Show (CIFileStatus d)
ciFileEnded :: CIFileStatus d -> Bool
ciFileEnded = \case
CIFSSndStored -> False
CIFSSndTransfer -> False
CIFSSndTransfer {} -> False
CIFSSndCancelled -> True
CIFSSndComplete -> True
CIFSRcvInvitation -> False
CIFSRcvAccepted -> False
CIFSRcvTransfer -> False
CIFSRcvTransfer {} -> False
CIFSRcvCancelled -> True
CIFSRcvComplete -> True
instance MsgDirectionI d => ToJSON (CIFileStatus d) where
toJSON = strToJSON
toEncoding = strToJEncoding
instance ToJSON (CIFileStatus d) where
toJSON = J.toJSON . jsonCIFileStatus
toEncoding = J.toEncoding . jsonCIFileStatus
instance MsgDirectionI d => ToField (CIFileStatus d) where toField = toField . decodeLatin1 . strEncode
@@ -458,12 +459,12 @@ deriving instance Show ACIFileStatus
instance MsgDirectionI d => StrEncoding (CIFileStatus d) where
strEncode = \case
CIFSSndStored -> "snd_stored"
CIFSSndTransfer -> "snd_transfer"
CIFSSndTransfer sent total -> strEncode (Str "snd_transfer", sent, total)
CIFSSndCancelled -> "snd_cancelled"
CIFSSndComplete -> "snd_complete"
CIFSRcvInvitation -> "rcv_invitation"
CIFSRcvAccepted -> "rcv_accepted"
CIFSRcvTransfer -> "rcv_transfer"
CIFSRcvTransfer rcvd total -> strEncode (Str "rcv_transfer", rcvd, total)
CIFSRcvComplete -> "rcv_complete"
CIFSRcvCancelled -> "rcv_cancelled"
strP = (\(AFS _ st) -> checkDirection st) <$?> strP
@@ -473,15 +474,59 @@ instance StrEncoding ACIFileStatus where
strP =
A.takeTill (== ' ') >>= \case
"snd_stored" -> pure $ AFS SMDSnd CIFSSndStored
"snd_transfer" -> pure $ AFS SMDSnd CIFSSndTransfer
"snd_transfer" -> AFS SMDSnd <$> progress CIFSSndTransfer
"snd_cancelled" -> pure $ AFS SMDSnd CIFSSndCancelled
"snd_complete" -> pure $ AFS SMDSnd CIFSSndComplete
"rcv_invitation" -> pure $ AFS SMDRcv CIFSRcvInvitation
"rcv_accepted" -> pure $ AFS SMDRcv CIFSRcvAccepted
"rcv_transfer" -> pure $ AFS SMDRcv CIFSRcvTransfer
"rcv_transfer" -> AFS SMDRcv <$> progress CIFSRcvTransfer
"rcv_complete" -> pure $ AFS SMDRcv CIFSRcvComplete
"rcv_cancelled" -> pure $ AFS SMDRcv CIFSRcvCancelled
_ -> fail "bad file status"
where
progress :: (Int -> Int -> a) -> A.Parser a
progress f = f <$> num <*> num <|> pure (f 0 1)
num = A.space *> A.decimal
data JSONCIFileStatus
= JCIFSSndStored
| JCIFSSndTransfer {sndProgress :: Int, sndTotal :: Int}
| JCIFSSndCancelled
| JCIFSSndComplete
| JCIFSRcvInvitation
| JCIFSRcvAccepted
| JCIFSRcvTransfer {rcvProgress :: Int, rcvTotal :: Int}
| JCIFSRcvComplete
| JCIFSRcvCancelled
deriving (Generic)
instance ToJSON JSONCIFileStatus where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIFS"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIFS"
jsonCIFileStatus :: CIFileStatus d -> JSONCIFileStatus
jsonCIFileStatus = \case
CIFSSndStored -> JCIFSSndStored
CIFSSndTransfer sent total -> JCIFSSndTransfer sent total
CIFSSndCancelled -> JCIFSSndCancelled
CIFSSndComplete -> JCIFSSndComplete
CIFSRcvInvitation -> JCIFSRcvInvitation
CIFSRcvAccepted -> JCIFSRcvAccepted
CIFSRcvTransfer rcvd total -> JCIFSRcvTransfer rcvd total
CIFSRcvComplete -> JCIFSRcvComplete
CIFSRcvCancelled -> JCIFSRcvCancelled
aciFileStatusJSON :: JSONCIFileStatus -> ACIFileStatus
aciFileStatusJSON = \case
JCIFSSndStored -> AFS SMDSnd CIFSSndStored
JCIFSSndTransfer sent total -> AFS SMDSnd $ CIFSSndTransfer sent total
JCIFSSndCancelled -> AFS SMDSnd CIFSSndCancelled
JCIFSSndComplete -> AFS SMDSnd CIFSSndComplete
JCIFSRcvInvitation -> AFS SMDRcv CIFSRcvInvitation
JCIFSRcvAccepted -> AFS SMDRcv CIFSRcvAccepted
JCIFSRcvTransfer rcvd total -> AFS SMDRcv $ CIFSRcvTransfer rcvd total
JCIFSRcvComplete -> AFS SMDRcv CIFSRcvComplete
JCIFSRcvCancelled -> AFS SMDRcv CIFSRcvCancelled
-- to conveniently read file data from db
data CIFileInfo = CIFileInfo

24
src/Simplex/Chat/Migrations/M20230304_file_description.hs
View File

@@ -11,19 +11,25 @@ import Database.SQLite.Simple.QQ (sql)
m20230304_file_description :: Query
m20230304_file_description =
[sql|
CREATE TABLE recipient_file_descriptions (
CREATE TABLE xftp_file_descriptions (
file_descr_id INTEGER PRIMARY KEY AUTOINCREMENT,
file_descr_size INTEGER NOT NULL,
file_descr_status TEXT NOT NULL,
file_descr_text TEXT NOT NULL
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
file_descr_text TEXT NOT NULL,
file_descr_part_no INTEGER NOT NULL DEFAULT(0),
file_descr_complete INTEGER NOT NULL DEFAULT(0),
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);
ALTER TABLE rcv_files ADD COLUMN file_descr_id INTEGER NULL
REFERENCES recipient_file_descriptions(file_descr_id) ON DELETE RESTRICT;
ALTER TABLE files ADD COLUMN agent_snd_file_id BLOB NULL;
ALTER TABLE files ADD COLUMN private_snd_file_descr TEXT NULL;
ALTER TABLE snd_files ADD COLUMN file_descr_id INTEGER NULL
REFERENCES recipient_file_descriptions(file_descr_id) ON DELETE RESTRICT;
REFERENCES xftp_file_descriptions ON DELETE SET NULL;
-- this is a private file description allowing to delete the file from the server
ALTER TABLE files ADD COLUMN snd_file_descr_text TEXT NULL;
ALTER TABLE rcv_files ADD COLUMN file_descr_id INTEGER NULL
REFERENCES xftp_file_descriptions ON DELETE SET NULL;
ALTER TABLE rcv_files ADD COLUMN agent_rcv_file_id BLOB NULL;
|]

20
src/Simplex/Chat/Migrations/chat_schema.sql
View File

@@ -193,7 +193,9 @@ CREATE TABLE files(
updated_at TEXT CHECK(updated_at NOT NULL),
cancelled INTEGER,
ci_file_status TEXT,
file_inline TEXT
file_inline TEXT,
agent_snd_file_id BLOB NULL,
private_snd_file_descr TEXT NULL
);
CREATE TABLE snd_files(
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
@@ -204,6 +206,8 @@ CREATE TABLE snd_files(
updated_at TEXT CHECK(updated_at NOT NULL),
file_inline TEXT,
last_inline_msg_delivery_id INTEGER,
file_descr_id INTEGER NULL
REFERENCES xftp_file_descriptions ON DELETE SET NULL,
PRIMARY KEY(file_id, connection_id)
) WITHOUT ROWID;
CREATE TABLE rcv_files(
@@ -215,7 +219,10 @@ CREATE TABLE rcv_files(
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
rcv_file_inline TEXT,
file_inline TEXT
file_inline TEXT,
file_descr_id INTEGER NULL
REFERENCES xftp_file_descriptions ON DELETE SET NULL,
agent_rcv_file_id BLOB NULL
);
CREATE TABLE snd_file_chunks(
file_id INTEGER NOT NULL,
@@ -551,3 +558,12 @@ CREATE INDEX idx_smp_servers_user_id ON smp_servers(user_id);
CREATE INDEX idx_chat_items_item_deleted_by_group_member_id ON chat_items(
item_deleted_by_group_member_id
);
CREATE TABLE xftp_file_descriptions(
file_descr_id INTEGER PRIMARY KEY AUTOINCREMENT,
user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE,
file_descr_text TEXT NOT NULL,
file_descr_part_no INTEGER NOT NULL DEFAULT(0),
file_descr_complete INTEGER NOT NULL DEFAULT(0),
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
);

146
src/Simplex/Chat/Store.hs
View File

@@ -33,6 +33,8 @@ module Simplex.Chat.Store
getUser,
getUserIdByName,
getUserByAConnId,
getUserByASndFileId,
getUserByARcvFileId,
getUserByContactId,
getUserByGroupId,
getUserByFileId,
@@ -152,7 +154,11 @@ module Simplex.Chat.Store
createSndGroupInlineFT,
updateSndDirectFTDelivery,
updateSndGroupFTDelivery,
getSndInlineFTViaMsgDelivery,
getSndFTViaMsgDelivery,
createSndFileTransferXFTP,
createSndDirectFTDescrXFTP,
getAgentSndFileXFTP,
getAgentRcvFileXFTP,
updateFileCancelled,
updateCIFileStatus,
getSharedMsgIdByFileId,
@@ -345,11 +351,11 @@ import Simplex.Chat.Migrations.M20230118_recreate_smp_servers
import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx
import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id
import Simplex.Chat.Migrations.M20230303_group_link_role
-- import Simplex.Chat.Migrations.M20230304_file_description
import Simplex.Chat.Migrations.M20230304_file_description
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Util (week)
import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..))
import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..), UserId)
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, firstRow, firstRow', maybeFirstRow, withTransaction)
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
import qualified Simplex.Messaging.Crypto as C
@@ -412,8 +418,8 @@ schemaMigrations =
("20230118_recreate_smp_servers", m20230118_recreate_smp_servers),
("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx),
("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id),
("20230303_group_link_role", m20230303_group_link_role)
-- ("20230304_file_description", m20230304_file_description)
("20230303_group_link_role", m20230303_group_link_role),
("20230304_file_description", m20230304_file_description)
]
-- | The list of migrations in ascending order by date
@@ -541,6 +547,16 @@ getUserByAConnId db agentConnId =
maybeFirstRow toUser $
DB.query db (userQuery <> " JOIN connections c ON c.user_id = u.user_id WHERE c.agent_conn_id = ?") (Only agentConnId)
getUserByASndFileId :: DB.Connection -> AgentSndFileId -> IO (Maybe User)
getUserByASndFileId db aSndFileId =
maybeFirstRow toUser $
DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.agent_snd_file_id = ?") (Only aSndFileId)
getUserByARcvFileId :: DB.Connection -> AgentRcvFileId -> IO (Maybe User)
getUserByARcvFileId db aRcvFileId =
maybeFirstRow toUser $
DB.query db (userQuery <> " JOIN rcv_files r USING (file_id) JOIN files f ON f.user_id = u.user_id WHERE r.agent_rcv_file_id = ?") (Only aRcvFileId)
getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User
getUserByContactId db contactId =
ExceptT . firstRow toUser (SEUserNotFoundByContactId contactId) $
@@ -1394,7 +1410,10 @@ getLiveSndFileTransfers db User {userId} = do
SELECT DISTINCT f.file_id
FROM files f
JOIN snd_files s USING (file_id)
WHERE f.user_id = ? AND s.file_status IN (?, ?, ?) AND s.file_inline IS NULL
WHERE f.user_id = ?
AND s.file_status IN (?, ?, ?)
AND s.file_descr_id IS NULL
AND s.file_inline IS NULL
AND s.created_at > ?
|]
(userId, FSNew, FSAccepted, FSConnected, cutoffTs)
@@ -1721,7 +1740,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
DB.query
db
[sql|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_inline, cs.local_display_name, m.local_display_name
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, cs.local_display_name, m.local_display_name
FROM snd_files s
JOIN files f USING (file_id)
LEFT JOIN contacts cs USING (contact_id)
@@ -1729,10 +1748,10 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ?
|]
(userId, fileId, connId)
sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, contactName_, memberName_) =
sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, contactName_, memberName_) =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, recipientDisplayName, connId, agentConnId}
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact
getUserContact_ userContactLinkId = ExceptT $ do
@@ -2619,7 +2638,7 @@ createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitatio
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, fileStatus, fileInline, connId, currentTs, currentTs)
pure FileTransferMeta {fileId, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO ()
createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do
@@ -2639,7 +2658,7 @@ createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, filePath, fileSize, chunkSize, fileInline, CIFSSndStored, currentTs, currentTs)
fileId <- insertedRowId db
pure FileTransferMeta {fileId, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> IO ()
createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} = do
@@ -2660,7 +2679,7 @@ createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connectio
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, fileStatus, fileInline', connId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, fileStatus, fileInline = fileInline'}
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, fileStatus, fileDescrId = Nothing, fileInline = fileInline'}
createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> IO SndFileTransfer
createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Connection {connId, agentConnId} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
@@ -2671,7 +2690,7 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, fileStatus, fileInline = fileInline'}
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, fileStatus, fileDescrId = Nothing, fileInline = fileInline'}
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO ()
updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
@@ -2687,27 +2706,60 @@ updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} File
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE group_member_id = ? AND connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, groupMemberId, connId, fileId)
getSndInlineFTViaMsgDelivery :: DB.Connection -> User -> Connection -> AgentMsgId -> IO (Maybe SndFileTransfer)
getSndInlineFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMsgId = do
getSndFTViaMsgDelivery :: DB.Connection -> User -> Connection -> AgentMsgId -> IO (Maybe SndFileTransfer)
getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMsgId = do
(sndFileTransfer_ <=< listToMaybe)
<$> DB.query
db
[sql|
SELECT s.file_id, s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_inline, c.local_display_name, m.local_display_name
SELECT s.file_id, s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, c.local_display_name, m.local_display_name
FROM msg_deliveries d
JOIN snd_files s ON s.connection_id = d.connection_id AND s.last_inline_msg_delivery_id = d.msg_delivery_id
JOIN files f ON f.file_id = s.file_id
LEFT JOIN contacts c USING (contact_id)
LEFT JOIN group_members m USING (group_member_id)
WHERE d.connection_id = ? AND d.agent_msg_id = ? AND f.user_id = ? AND s.file_inline IS NOT NULL
WHERE d.connection_id = ? AND d.agent_msg_id = ? AND f.user_id = ?
AND (s.file_descr_id IS NOT NULL OR s.file_inline IS NOT NULL)
|]
(connId, agentMsgId, userId)
where
sndFileTransfer_ :: (Int64, FileStatus, String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe ContactName, Maybe ContactName) -> Maybe SndFileTransfer
sndFileTransfer_ (fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, contactName_, memberName_) =
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, recipientDisplayName = n, connId, agentConnId})
sndFileTransfer_ :: (Int64, FileStatus, String, Integer, Integer, FilePath, Maybe Int64, Maybe InlineFileMode, Maybe ContactName, Maybe ContactName) -> Maybe SndFileTransfer
sndFileTransfer_ (fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, contactName_, memberName_) =
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName = n, connId, agentConnId})
<$> (contactName_ <|> memberName_)
createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> FilePath -> FileInvitation -> AgentSndFileId -> IO FileTransferMeta
createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitation {fileName, fileSize} agentSndFileId = do
currentTs <- getCurrentTime
let chunkSize = 0
xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing}
DB.execute
db
"INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_size, chunk_size, agent_snd_file_id, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)"
(contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, fileSize, chunkSize, agentSndFileId, CIFSSndStored, currentTs, currentTs))
fileId <- insertedRowId db
pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
createSndDirectFTDescrXFTP :: DB.Connection -> User -> Contact -> FileTransferMeta -> Text -> IO ()
createSndDirectFTDescrXFTP db User {userId} Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} rfdText = do
let fileStatus = FSConnected
DB.execute db "INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_complete) VALUES (?,?,?)" (userId, rfdText, True)
fileDescrId <- insertedRowId db
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_descr_id, connection_id) VALUES (?,?,?,?)"
(fileId, fileStatus, fileDescrId, connId)
getAgentSndFileXFTP :: DB.Connection -> User -> AgentSndFileId -> ExceptT StoreError IO FileTransferMeta
getAgentSndFileXFTP db user aSndFileId = do
fileId <-
ExceptT . firstRow fromOnly (SESndFileNotFoundXFTP aSndFileId) $
DB.query db "SELECT file_id FROM files WHERE agent_snd_file_id = ?" (Only aSndFileId)
getFileTransferMeta db user fileId
getAgentRcvFileXFTP :: DB.Connection -> User -> AgentRcvFileId -> ExceptT StoreError IO FileTransferMeta
getAgentRcvFileXFTP _db _user _aFileId = undefined
updateFileCancelled :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO ()
updateFileCancelled db User {userId} fileId ciFileStatus = do
currentTs <- getCurrentTime
@@ -2845,32 +2897,46 @@ deleteSndFileChunks db SndFileTransfer {fileId, connId} =
DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId)
createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline} rcvFileInline chunkSize = do
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, currentTs, currentTs)
fileId <- insertedRowId db
rfd <- mapM (createRcvFD_ db) fileDescr
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, rcvFileDescription = Nothing, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, rcvFileDescription = rfd, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline} rcvFileInline chunkSize = do
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, currentTs, currentTs)
fileId <- insertedRowId db
rfd <- mapM (createRcvFD_ db) fileDescr
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, rcvFileDescription = Nothing, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, rcvFileDescription = rfd, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
createRcvFD_ :: DB.Connection -> FileDescr -> IO RcvFileDescr
createRcvFD_ db FileDescr {fileDescrText, fileDescrComplete} = do
-- TODO validate that fileDescrPartNo = 0, probably when message is received
DB.execute
db
"INSERT INTO file_descriptions (file_descr_text, file_descr_complete) VALUES (?,?)"
(fileDescrText, fileDescrComplete)
fileDescrId <- insertedRowId db
pure RcvFileDescr {fileDescrId, fileDescrPartNo = 0, fileDescrText, fileDescrComplete}
getRcvFileTransferById :: DB.Connection -> FileTransferId -> ExceptT StoreError IO (User, RcvFileTransfer)
getRcvFileTransferById db fileId = do
@@ -3062,7 +3128,7 @@ getSndFileTransfers_ db userId fileId =
<$> DB.query
db
[sql|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_inline, s.connection_id, c.agent_conn_id,
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_descr_id, s.file_inline, s.connection_id, c.agent_conn_id,
cs.local_display_name, m.local_display_name
FROM snd_files s
JOIN files f USING (file_id)
@@ -3073,10 +3139,10 @@ getSndFileTransfers_ db userId fileId =
|]
(userId, fileId)
where
sndFileTransfer :: (FileStatus, String, Integer, Integer, FilePath, Maybe InlineFileMode, Int64, AgentConnId, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, connId, agentConnId, contactName_, memberName_) =
sndFileTransfer :: (FileStatus, String, Integer, Integer, FilePath) :. (Maybe Int64, Maybe InlineFileMode, Int64, AgentConnId, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer ((fileStatus, fileName, fileSize, chunkSize, filePath) :. (fileDescrId, fileInline, connId, agentConnId, contactName_, memberName_)) =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, recipientDisplayName, connId, agentConnId}
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, recipientDisplayName, connId, agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta
@@ -3085,15 +3151,16 @@ getFileTransferMeta db User {userId} fileId =
DB.query
db
[sql|
SELECT f.file_name, f.file_size, f.chunk_size, f.file_path, f.file_inline, f.cancelled
FROM files f
WHERE f.user_id = ? AND f.file_id = ?
SELECT file_name, file_size, chunk_size, file_path, file_inline, agent_snd_file_id, private_snd_file_descr, cancelled
FROM files
WHERE user_id = ? AND file_id = ?
|]
(userId, fileId)
where
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe Bool) -> FileTransferMeta
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, cancelled_) =
FileTransferMeta {fileId, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe AgentSndFileId, Maybe Text, Maybe Bool) -> FileTransferMeta
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, aSndFileId_, privateSndFileDescr, cancelled_) =
let xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr}) <$> aSndFileId_
in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
getContactFileInfo db User {userId} Contact {contactId} =
@@ -4979,6 +5046,7 @@ data StoreError
| SERcvFileInvalid {fileId :: FileTransferId}
| SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId}
| SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId}
| SESndFileNotFoundXFTP {agentFileId :: AgentSndFileId}
| SEConnectionNotFound {agentConnId :: AgentConnId}
| SEConnectionNotFoundById {connId :: Int64}
| SEPendingConnectionNotFound {connId :: Int64}

78
src/Simplex/Chat/Types.hs
View File

@@ -49,7 +49,7 @@ import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import GHC.Records.Compat
import Simplex.FileTransfer.Description (FileDigest)
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..))
import Simplex.Messaging.Agent.Protocol (ACommandTag (..), ACorrId, AParty (..), APartyCmdTag (..), ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, SAEntity (..), UserId)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Protocol (AProtoServerWithAuth, ProtoServerWithAuth, ProtocolTypeI)
@@ -126,8 +126,6 @@ instance ToJSON UserInfo where
toJSON = J.genericToJSON J.defaultOptions
toEncoding = J.genericToEncoding J.defaultOptions
type UserId = Int64
type ContactId = Int64
type ProfileId = Int64
@@ -289,6 +287,13 @@ instance ToJSON GroupInfo where toEncoding = J.genericToEncoding J.defaultOption
groupName' :: GroupInfo -> GroupName
groupName' GroupInfo {localDisplayName = g} = g
data ContactOrGroup = CGContact Contact | CGGroup GroupInfo
contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId)
contactAndGroupIds = \case
CGContact Contact {contactId} -> (Just contactId, Nothing)
CGGroup GroupInfo {groupId} -> (Nothing, Just groupId)
-- TODO when more settings are added we should create another type to allow partial setting updates (with all Maybe properties)
data ChatSettings = ChatSettings
{ enableNtfs :: Bool
@@ -1457,6 +1462,7 @@ data SndFileTransfer = SndFileTransfer
connId :: Int64,
agentConnId :: AgentConnId,
fileStatus :: FileStatus,
fileDescrId :: Maybe Int64,
fileInline :: Maybe InlineFileMode
}
deriving (Eq, Show, Generic)
@@ -1485,19 +1491,27 @@ instance ToJSON FileInvitation where
instance FromJSON FileInvitation where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
data FileDescr
= FDText {fileDescrText :: Text}
| FDInline {fileDescrSize :: Integer, fileDescrInline :: InlineFileMode}
| FDPending
data FileDescr = FileDescr {fileDescrText :: Text, fileDescrPartNo :: Int, fileDescrComplete :: Bool}
deriving (Eq, Show, Generic)
instance ToJSON FileDescr where
toEncoding = J.genericToEncoding . taggedObjectJSON $ dropPrefix "FD"
toJSON = J.genericToJSON . taggedObjectJSON $ dropPrefix "FD"
toEncoding = J.genericToEncoding J.defaultOptions
toJSON = J.genericToJSON J.defaultOptions
instance FromJSON FileDescr where
parseJSON = J.genericParseJSON . taggedObjectJSON $ dropPrefix "FD"
xftpFileInvitation :: FilePath -> Integer -> FileInvitation
xftpFileInvitation fileName fileSize =
FileInvitation
{ fileName,
fileSize,
fileDigest = Nothing,
fileConnReq = Nothing,
fileInline = Nothing,
fileDescr = Just FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
}
data InlineFileMode
= IFMOffer -- file will be sent inline once accepted
| IFMSent -- file is sent inline without acceptance
@@ -1540,9 +1554,9 @@ instance ToJSON RcvFileTransfer where toEncoding = J.genericToEncoding J.default
data RcvFileDescr = RcvFileDescr
{ fileDescrId :: Int64,
fileDescrStatus :: RcvFileStatus,
fileDescrText :: Text,
chunkSize :: Integer
fileDescrPartNo :: Int,
fileDescrComplete :: Bool
}
deriving (Eq, Show, Generic)
@@ -1594,6 +1608,38 @@ instance FromField AgentConnId where fromField f = AgentConnId <$> fromField f
instance ToField AgentConnId where toField (AgentConnId m) = toField m
newtype AgentSndFileId = AgentSndFileId ConnId
deriving (Eq, Show)
instance StrEncoding AgentSndFileId where
strEncode (AgentSndFileId connId) = strEncode connId
strDecode s = AgentSndFileId <$> strDecode s
strP = AgentSndFileId <$> strP
instance ToJSON AgentSndFileId where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromField AgentSndFileId where fromField f = AgentSndFileId <$> fromField f
instance ToField AgentSndFileId where toField (AgentSndFileId m) = toField m
newtype AgentRcvFileId = AgentRcvFileId ConnId
deriving (Eq, Show)
instance StrEncoding AgentRcvFileId where
strEncode (AgentRcvFileId connId) = strEncode connId
strDecode s = AgentRcvFileId <$> strDecode s
strP = AgentRcvFileId <$> strP
instance ToJSON AgentRcvFileId where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromField AgentRcvFileId where fromField f = AgentRcvFileId <$> fromField f
instance ToField AgentRcvFileId where toField (AgentRcvFileId m) = toField m
newtype AgentInvId = AgentInvId InvitationId
deriving (Eq, Show)
@@ -1624,6 +1670,7 @@ instance ToJSON FileTransfer where
data FileTransferMeta = FileTransferMeta
{ fileId :: FileTransferId,
xftpSndFile :: Maybe XFTPSndFile,
fileName :: String,
filePath :: String,
fileSize :: Integer,
@@ -1635,10 +1682,19 @@ data FileTransferMeta = FileTransferMeta
instance ToJSON FileTransferMeta where toEncoding = J.genericToEncoding J.defaultOptions
data XFTPSndFile = XFTPSndFile
{ agentSndFileId :: AgentSndFileId,
privateSndFileDescr :: Maybe Text
}
deriving (Eq, Show, Generic)
instance ToJSON XFTPSndFile where toEncoding = J.genericToEncoding J.defaultOptions
fileTransferCancelled :: FileTransfer -> Bool
fileTransferCancelled (FTSnd FileTransferMeta {cancelled} _) = cancelled
fileTransferCancelled (FTRcv RcvFileTransfer {cancelled}) = cancelled
-- For XFTP file transfers FSConnected means "uploaded to XFTP relays"
data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Ord, Show)
instance FromField FileStatus where fromField = fromTextField_ textDecode

11
src/Simplex/Chat/View.hs
View File

@@ -130,6 +130,9 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
CRUserDeletedMember u g m -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group"]
CRLeftMemberUser u g -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g
CRGroupDeletedUser u g -> ttyUser u [ttyGroup' g <> ": you deleted the group"]
CRRcvFileDescrReady _ _ -> []
CRRcvFileDescrNotReady _ _ -> []
CRRcvFileProgressXFTP _ _ _ _ -> []
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
CRSndGroupFileCancelled u _ ftm fts -> ttyUser u $ viewSndGroupFileCancelled ftm fts
@@ -147,6 +150,10 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
CRSndFileStart u _ ft -> ttyUser u $ sendingFile_ "started" ft
CRSndFileComplete u _ ft -> ttyUser u $ sendingFile_ "completed" ft
CRSndFileCancelled _ ft -> sendingFile_ "cancelled" ft
CRSndFileStartXFTP _ _ _ -> []
CRSndFileProgressXFTP _ _ _ _ _ -> []
CRSndFileCompleteXFTP _ _ _ -> []
CRSndFileCancelledXFTP _ _ _ -> []
CRSndFileRcvCancelled u _ ft@SndFileTransfer {recipientDisplayName = c} ->
ttyUser u [ttyContact c <> " cancelled receiving " <> sndFile ft]
CRContactConnecting u _ -> ttyUser u []
@@ -1007,7 +1014,7 @@ viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts = case filePa
where
ttySentFile fPath = ["/f " <> to <> ttyFilePath fPath] <> cancelSending
cancelSending = case fileStatus of
CIFSSndTransfer -> []
CIFSSndTransfer _ _ -> []
_ -> ["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
sentWithTime_ :: CurrentTime -> [StyledString] -> CIMeta c d -> [StyledString]
@@ -1207,6 +1214,8 @@ viewChatError logLevel = \case
ChatError err -> case err of
CENoActiveUser -> ["error: active user is required"]
CENoConnectionUser agentConnId -> ["error: message user not found, conn id: " <> sShow agentConnId | logLevel <= CLLError]
CENoSndFileUser aFileId -> ["error: snd file user not found, file id: " <> sShow aFileId | logLevel <= CLLError]
CENoRcvFileUser aFileId -> ["error: rcv file user not found, file id: " <> sShow aFileId | logLevel <= CLLError]
CEActiveUserExists -> ["error: active user already exists"]
CEUserExists name -> ["user with the name " <> ttyContact name <> " already exists"]
CEDifferentActiveUser commandUserId activeUserId -> ["error: different active user, command user id: " <> sShow commandUserId <> ", active user id: " <> sShow activeUserId]