core: add direct xftp upload/download commands (#3781)
* chat: add direct xftp upload/download commands * adapt to FileDescriptionURI record * bump simplexmq * add description uploading * filter URIs by size * cleanup * add file meta to events * remove focus * auto-redirect when no URI fits * send "upload complete" event with the original file id * remove description upload command * add index * refactor * update simplexmq * Apply suggestions from code review Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> * fix /fc command for non-chat uploads * fix * rename (tests fail) * num recipients * update messages * split "file complete" events for chats and standalone * restore xftpSndFileRedirect * remove unused store error * add send/cancel test * untangle standalone views * fix confused id * fix /fc and /fs * resolve comments * misc fixes * bump simplexmq * fix build * handle redirect errors independently * fix missing file status in tests --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
This commit is contained in:
Alexander Bondarenko
GitHub
parent
e361bcf140
commit
daf67c0456
@ -133,6 +133,7 @@ library
|
||||
Simplex.Chat.Migrations.M20240104_members_profile_update
|
||||
Simplex.Chat.Migrations.M20240115_block_member_for_all
|
||||
Simplex.Chat.Migrations.M20240122_indexes
|
||||
Simplex.Chat.Migrations.M20240214_redirect_file_id
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Mobile.File
|
||||
Simplex.Chat.Mobile.Shared
|
||||
|
||||
@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
@ -81,7 +82,8 @@ import Simplex.Chat.Types.Util
|
||||
import Simplex.Chat.Util (encryptFile, shuffle)
|
||||
import Simplex.FileTransfer.Client.Main (maxFileSize)
|
||||
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
|
||||
import Simplex.FileTransfer.Description (ValidFileDescription, gb, kb, mb)
|
||||
import Simplex.FileTransfer.Description (FileDescriptionURI (..), ValidFileDescription, gb, kb, mb)
|
||||
import qualified Simplex.FileTransfer.Description as FD
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI)
|
||||
import Simplex.Messaging.Agent as Agent
|
||||
import Simplex.Messaging.Agent.Client (AgentStatsKey (..), SubInfo (..), agentClientStore, getAgentWorkersDetails, getAgentWorkersSummary, temporaryAgentError)
|
||||
@ -770,28 +772,18 @@ processChatCommand' vr = \case
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
where
|
||||
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do
|
||||
let fileName = takeFileName filePath
|
||||
fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
|
||||
fInv = xftpFileInvitation fileName fileSize fileDescr
|
||||
fsFilePath <- toFSFilePath filePath
|
||||
let srcFile = CryptoFile fsFilePath cfArgs
|
||||
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n)
|
||||
-- TODO CRSndFileStart event for XFTP
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv (AgentSndFileId aFileId) chSize
|
||||
let fileSource = Just $ CryptoFile filePath cfArgs
|
||||
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
|
||||
xftpSndFileTransfer user file fileSize n contactOrGroup = do
|
||||
(fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup
|
||||
case contactOrGroup of
|
||||
CGContact Contact {activeConn} -> forM_ activeConn $ \conn ->
|
||||
withStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft fileDescr
|
||||
withStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr
|
||||
CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user))
|
||||
where
|
||||
-- we are not sending files to pending members, same as with inline files
|
||||
saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} =
|
||||
when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $
|
||||
withStore' $
|
||||
\db -> createSndFTDescrXFTP db user (Just m) conn ft fileDescr
|
||||
\db -> createSndFTDescrXFTP db user (Just m) conn ft dummyFileDescr
|
||||
saveMemberFD _ = pure ()
|
||||
pure (fInv, ciFile, ft)
|
||||
unzipMaybe3 :: Maybe (a, b, c) -> (Maybe a, Maybe b, Maybe c)
|
||||
@ -1959,16 +1951,16 @@ processChatCommand' vr = \case
|
||||
| otherwise -> do
|
||||
fileAgentConnIds <- cancelSndFile user ftm fts True
|
||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
|
||||
withStore (\db -> getChatRefByFileId db user fileId) >>= \case
|
||||
ChatRef CTDirect contactId -> do
|
||||
contact <- withStore $ \db -> getContact db user contactId
|
||||
withStore (\db -> liftIO $ lookupChatRefByFileId db user fileId) >>= \case
|
||||
Nothing -> pure ()
|
||||
Just (ChatRef CTDirect contactId) -> do
|
||||
(contact, sharedMsgId) <- withStore $ \db -> (,) <$> getContact db user contactId <*> getSharedMsgIdByFileId db userId fileId
|
||||
void . sendDirectContactMessage contact $ XFileCancel sharedMsgId
|
||||
ChatRef CTGroup groupId -> do
|
||||
Group gInfo ms <- withStore $ \db -> getGroup db vr user groupId
|
||||
Just (ChatRef CTGroup groupId) -> do
|
||||
(Group gInfo ms, sharedMsgId) <- withStore $ \db -> (,) <$> getGroup db vr user groupId <*> getSharedMsgIdByFileId db userId fileId
|
||||
void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId
|
||||
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
|
||||
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
Just _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
|
||||
ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId
|
||||
pure $ CRSndFileCancelled user ci ftm fts
|
||||
where
|
||||
fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} =
|
||||
@ -1979,7 +1971,7 @@ processChatCommand' vr = \case
|
||||
| otherwise -> case xftpRcvFile of
|
||||
Nothing -> do
|
||||
cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user)
|
||||
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId
|
||||
pure $ CRRcvFileCancelled user ci ftr
|
||||
Just XFTPRcvFile {agentRcvFileId} -> do
|
||||
forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do
|
||||
@ -1992,11 +1984,14 @@ processChatCommand' vr = \case
|
||||
updateCIFileStatus db user fileId CIFSRcvInvitation
|
||||
updateRcvFileStatus db fileId FSNew
|
||||
updateRcvFileAgentId db fileId Nothing
|
||||
getChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
pure $ CRRcvFileCancelled user ci ftr
|
||||
FileStatus fileId -> withUser $ \user -> do
|
||||
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
case file of
|
||||
withStore (\db -> lookupChatItemByFileId db vr user fileId) >>= \case
|
||||
Nothing -> do
|
||||
fileStatus <- withStore $ \db -> getFileTransferProgress db user fileId
|
||||
pure $ CRFileTransferStatus user fileStatus
|
||||
Just ci@(AChatItem _ _ _ ChatItem {file}) -> case file of
|
||||
Just CIFile {fileProtocol = FPLocal} ->
|
||||
throwChatError $ CECommandError "not supported for local files"
|
||||
Just CIFile {fileProtocol = FPXFTP} ->
|
||||
@ -2058,6 +2053,13 @@ processChatCommand' vr = \case
|
||||
StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_
|
||||
ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls
|
||||
DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_
|
||||
APIUploadStandaloneFile userId file -> withUserId userId $ \user -> do
|
||||
fileSize <- liftIO $ CF.getFileContentsSize file
|
||||
(_, _, fileTransferMeta) <- xftpSndFileTransfer_ user file fileSize 1 Nothing
|
||||
pure CRSndStandaloneFileCreated {user, fileTransferMeta}
|
||||
APIDownloadStandaloneFile userId uri file -> withUserId userId $ \user -> do
|
||||
ft <- receiveViaURI user uri file
|
||||
pure $ CRRcvStandaloneFileCreated user ft
|
||||
QuitChat -> liftIO exitSuccess
|
||||
ShowVersion -> do
|
||||
-- simplexmqCommitQ makes iOS builds crash m(
|
||||
@ -2811,6 +2813,19 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
|
||||
startReceivingFile user fileId
|
||||
withStoreCtx' (Just "receiveViaCompleteFD, updateRcvFileAgentId") $ \db -> updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId)
|
||||
|
||||
receiveViaURI :: ChatMonad m => User -> FileDescriptionURI -> CryptoFile -> m RcvFileTransfer
|
||||
receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile {cryptoArgs} = do
|
||||
fileId <- withStore $ \db -> createRcvStandaloneFileTransfer db userId cf fileSize chunkSize
|
||||
aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) description cryptoArgs
|
||||
withStore $ \db -> do
|
||||
liftIO $ do
|
||||
updateRcvFileStatus db fileId FSConnected
|
||||
updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
|
||||
updateRcvFileAgentId db fileId (Just $ AgentRcvFileId aFileId)
|
||||
getRcvFileTransfer db user fileId
|
||||
where
|
||||
FD.ValidFileDescription FD.FileDescription {size = FD.FileSize fileSize, chunkSize = FD.FileSize chunkSize} = description
|
||||
|
||||
startReceivingFile :: ChatMonad m => User -> FileTransferId -> m ()
|
||||
startReceivingFile user fileId = do
|
||||
vr <- chatVersionRange
|
||||
@ -3276,7 +3291,7 @@ processAgentMsgSndFile _corrId aFileId msg =
|
||||
where
|
||||
process :: User -> m ()
|
||||
process user = do
|
||||
(ft@FileTransferMeta {fileId, cancelled}, sfts) <- withStore $ \db -> do
|
||||
(ft@FileTransferMeta {fileId, xftpRedirectFor, cancelled}, sfts) <- withStore $ \db -> do
|
||||
fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId
|
||||
getSndFileTransfer db user fileId
|
||||
vr <- chatVersionRange
|
||||
@ -3285,12 +3300,23 @@ processAgentMsgSndFile _corrId aFileId msg =
|
||||
let status = CIFSSndTransfer {sndProgress, sndTotal}
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId status
|
||||
getChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal
|
||||
SFDONE sndDescr rfds -> do
|
||||
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
|
||||
ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <-
|
||||
withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId
|
||||
case ci of
|
||||
Nothing -> do
|
||||
withAgent (`xftpDeleteSndFileInternal` aFileId)
|
||||
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText rfds)
|
||||
case mapMaybe fileDescrURI rfds of
|
||||
[] -> case rfds of
|
||||
[] -> logError "File sent without receiver descriptions" -- should not happen
|
||||
(rfd : _) -> xftpSndFileRedirect user fileId rfd >>= toView . CRSndFileRedirectStartXFTP user ft
|
||||
uris -> do
|
||||
ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor
|
||||
toView $ CRSndStandaloneFileComplete user ft' uris
|
||||
Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) ->
|
||||
case (msgId_, itemDeleted) of
|
||||
(Just sharedMsgId, Nothing) -> do
|
||||
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
|
||||
@ -3334,12 +3360,16 @@ processAgentMsgSndFile _corrId aFileId msg =
|
||||
| otherwise -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateFileCancelled db user fileId CIFSSndError
|
||||
getChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
withAgent (`xftpDeleteSndFileInternal` aFileId)
|
||||
toView $ CRSndFileError user ci
|
||||
toView $ CRSndFileError user ci ft
|
||||
where
|
||||
fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
|
||||
fileDescrText = safeDecodeUtf8 . strEncode
|
||||
fileDescrURI :: ValidFileDescription 'FRecipient -> Maybe T.Text
|
||||
fileDescrURI vfd = if T.length uri < FD.qrSizeLimit then Just uri else Nothing
|
||||
where
|
||||
uri = decodeLatin1 . strEncode $ FD.fileDescriptionURI vfd
|
||||
sendFileDescription :: SndFileTransfer -> ValidFileDescription 'FRecipient -> SharedMsgId -> (ChatMsgEvent 'Json -> m (SndMessage, Int64)) -> m Int64
|
||||
sendFileDescription sft rfd msgId sendMsg = do
|
||||
let rfdText = fileDescrText rfd
|
||||
@ -3387,30 +3417,30 @@ processAgentMsgRcvFile _corrId aFileId msg =
|
||||
let status = CIFSRcvTransfer {rcvProgress, rcvTotal}
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId status
|
||||
getChatItemByFileId db vr user fileId
|
||||
toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal ft
|
||||
RFDONE xftpPath ->
|
||||
case liveRcvFileTransferPath ft of
|
||||
Nothing -> throwChatError $ CEInternalError "no target path for received XFTP file"
|
||||
Just targetPath -> do
|
||||
fsTargetPath <- toFSFilePath targetPath
|
||||
renameFile xftpPath fsTargetPath
|
||||
ci <- withStore $ \db -> do
|
||||
ci_ <- withStore $ \db -> do
|
||||
liftIO $ do
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
updateCIFileStatus db user fileId CIFSRcvComplete
|
||||
getChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
agentXFTPDeleteRcvFile aFileId fileId
|
||||
toView $ CRRcvFileComplete user ci
|
||||
toView $ maybe (CRRcvStandaloneFileComplete user fsTargetPath ft) (CRRcvFileComplete user) ci_
|
||||
RFERR e
|
||||
| temporaryAgentError e ->
|
||||
throwChatError $ CEXFTPRcvFile fileId (AgentRcvFileId aFileId) e
|
||||
| otherwise -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateFileCancelled db user fileId CIFSRcvError
|
||||
getChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
agentXFTPDeleteRcvFile aFileId fileId
|
||||
toView $ CRRcvFileError user ci e
|
||||
toView $ CRRcvFileError user ci e ft
|
||||
|
||||
processAgentMessageConn :: forall m. ChatMonad m => VersionRange -> User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
|
||||
processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do
|
||||
@ -4089,10 +4119,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
case err of
|
||||
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ do
|
||||
ci <- withStore $ \db -> do
|
||||
getChatRefByFileId db user fileId >>= \case
|
||||
ChatRef CTDirect _ -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
|
||||
liftIO (lookupChatRefByFileId db user fileId) >>= \case
|
||||
Just (ChatRef CTDirect _) -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
|
||||
_ -> pure ()
|
||||
getChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
toView $ CRSndFileRcvCancelled user ci ft
|
||||
_ -> throwChatError $ CEFileSend fileId err
|
||||
MSG meta _ _ -> withAckMessage' agentConnId conn meta $ pure ()
|
||||
@ -6274,12 +6304,19 @@ agentXFTPDeleteRcvFile aFileId fileId = do
|
||||
withStore' $ \db -> setRcvFTAgentDeleted db fileId
|
||||
|
||||
agentXFTPDeleteSndFileRemote :: ChatMonad m => User -> XFTPSndFile -> FileTransferId -> m ()
|
||||
agentXFTPDeleteSndFileRemote user XFTPSndFile {agentSndFileId = AgentSndFileId aFileId, privateSndFileDescr, agentSndFileDeleted} fileId =
|
||||
unless agentSndFileDeleted $
|
||||
agentXFTPDeleteSndFileRemote user sndFile fileId = do
|
||||
-- the agent doesn't know about redirect, delete explicitly
|
||||
redirect_ <- withStore' $ \db -> lookupFileTransferRedirectMeta db user fileId
|
||||
forM_ redirect_ $ \FileTransferMeta {fileId = fileIdRedirect, xftpSndFile = sndFileRedirect_} ->
|
||||
mapM_ (handleError (const $ pure ()) . remove fileIdRedirect) sndFileRedirect_
|
||||
remove fileId sndFile
|
||||
where
|
||||
remove fId XFTPSndFile {agentSndFileId = AgentSndFileId aFileId, privateSndFileDescr, agentSndFileDeleted} =
|
||||
unless agentSndFileDeleted $ do
|
||||
forM_ privateSndFileDescr $ \sfdText -> do
|
||||
sd <- parseFileDescription sfdText
|
||||
withAgent $ \a -> xftpDeleteSndFileRemote a (aUserId user) aFileId sd
|
||||
withStore' $ \db -> setSndFTAgentDeleted db user fileId
|
||||
withStore' $ \db -> setSndFTAgentDeleted db user fId
|
||||
|
||||
userProfileToSend :: User -> Maybe Profile -> Maybe Contact -> Bool -> Profile
|
||||
userProfileToSend user@User {profile = p} incognitoProfile ct inGroup = do
|
||||
@ -6750,6 +6787,8 @@ chatCommandP =
|
||||
"/list remote ctrls" $> ListRemoteCtrls,
|
||||
"/stop remote ctrl" $> StopRemoteCtrl,
|
||||
"/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal),
|
||||
"/_upload " *> (APIUploadStandaloneFile <$> A.decimal <* A.space <*> cryptoFileP),
|
||||
"/_download " *> (APIDownloadStandaloneFile <$> A.decimal <* A.space <*> strP_ <*> cryptoFileP),
|
||||
("/quit" <|> "/q" <|> "/exit") $> QuitChat,
|
||||
("/version" <|> "/v") $> ShowVersion,
|
||||
"/debug locks" $> DebugLocks,
|
||||
@ -6937,3 +6976,29 @@ mkValidName = reverse . dropWhile isSpace . fst3 . foldl' addChar ("", '\NUL', 0
|
||||
| isPunctuation prev = validFirstChar || isSpace c || (punct < 3 && isPunctuation c)
|
||||
| otherwise = validFirstChar || isSpace c || isMark c || isPunctuation c
|
||||
validFirstChar = isLetter c || isNumber c || isSymbol c
|
||||
|
||||
xftpSndFileTransfer_ :: ChatMonad m => User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ = do
|
||||
let fileName = takeFileName filePath
|
||||
fInv = xftpFileInvitation fileName fileSize dummyFileDescr
|
||||
fsFilePath <- toFSFilePath filePath
|
||||
let srcFile = CryptoFile fsFilePath cfArgs
|
||||
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n)
|
||||
-- TODO CRSndFileStart event for XFTP
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup_ file fInv (AgentSndFileId aFileId) Nothing chSize
|
||||
let fileSource = Just $ CryptoFile filePath cfArgs
|
||||
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
|
||||
pure (fInv, ciFile, ft)
|
||||
|
||||
xftpSndFileRedirect :: ChatMonad m => User -> FileTransferId -> ValidFileDescription 'FRecipient -> m FileTransferMeta
|
||||
xftpSndFileRedirect user ftId vfd = do
|
||||
let fileName = "redirect.yaml"
|
||||
file = CryptoFile fileName Nothing
|
||||
fInv = xftpFileInvitation fileName (fromIntegral $ B.length $ strEncode vfd) dummyFileDescr
|
||||
aFileId <- withAgent $ \a -> xftpSendDescription a (aUserId user) vfd (roundedFDCount 1)
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
withStore' $ \db -> createSndFileTransferXFTP db user Nothing file fInv (AgentSndFileId aFileId) (Just ftId) chSize
|
||||
|
||||
dummyFileDescr :: FileDescr
|
||||
dummyFileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
|
||||
|
||||
@ -59,6 +59,7 @@ import Simplex.Chat.Remote.Types
|
||||
import Simplex.Chat.Store (AutoAccept, StoreError (..), UserContactLink, UserMsgReceiptSettings)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.FileTransfer.Description (FileDescriptionURI)
|
||||
import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo)
|
||||
import Simplex.Messaging.Agent.Client (AgentLocks, AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig)
|
||||
@ -453,6 +454,8 @@ data ChatCommand
|
||||
| ListRemoteCtrls
|
||||
| StopRemoteCtrl -- Stop listening for announcements or terminate an active session
|
||||
| DeleteRemoteCtrl RemoteCtrlId -- Remove all local data associated with a remote controller session
|
||||
| APIUploadStandaloneFile UserId CryptoFile
|
||||
| APIDownloadStandaloneFile UserId FileDescriptionURI CryptoFile
|
||||
| QuitChat
|
||||
| ShowVersion
|
||||
| DebugLocks
|
||||
@ -593,21 +596,26 @@ data ChatResponse
|
||||
| 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, receivedSize :: Int64, totalSize :: Int64}
|
||||
| CRRcvStandaloneFileCreated {user :: User, rcvFileTransfer :: RcvFileTransfer} -- returned by _download
|
||||
| CRRcvFileStart {user :: User, chatItem :: AChatItem} -- sent by chats
|
||||
| CRRcvFileProgressXFTP {user :: User, chatItem_ :: Maybe AChatItem, receivedSize :: Int64, totalSize :: Int64, rcvFileTransfer :: RcvFileTransfer}
|
||||
| CRRcvFileComplete {user :: User, chatItem :: AChatItem}
|
||||
| CRRcvFileCancelled {user :: User, chatItem :: AChatItem, rcvFileTransfer :: RcvFileTransfer}
|
||||
| CRRcvStandaloneFileComplete {user :: User, targetPath :: FilePath, rcvFileTransfer :: RcvFileTransfer}
|
||||
| CRRcvFileCancelled {user :: User, chatItem_ :: Maybe AChatItem, rcvFileTransfer :: RcvFileTransfer}
|
||||
| CRRcvFileSndCancelled {user :: User, chatItem :: AChatItem, rcvFileTransfer :: RcvFileTransfer}
|
||||
| CRRcvFileError {user :: User, chatItem :: AChatItem, agentError :: AgentErrorType}
|
||||
| CRRcvFileError {user :: User, chatItem_ :: Maybe AChatItem, agentError :: AgentErrorType, rcvFileTransfer :: RcvFileTransfer}
|
||||
| CRSndFileStart {user :: User, chatItem :: AChatItem, sndFileTransfer :: SndFileTransfer}
|
||||
| CRSndFileComplete {user :: User, chatItem :: AChatItem, sndFileTransfer :: SndFileTransfer}
|
||||
| CRSndFileRcvCancelled {user :: User, chatItem :: AChatItem, sndFileTransfer :: SndFileTransfer}
|
||||
| CRSndFileCancelled {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta, sndFileTransfers :: [SndFileTransfer]}
|
||||
| CRSndFileStartXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta}
|
||||
| CRSndFileProgressXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta, sentSize :: Int64, totalSize :: Int64}
|
||||
| CRSndFileRcvCancelled {user :: User, chatItem_ :: Maybe AChatItem, sndFileTransfer :: SndFileTransfer}
|
||||
| CRSndFileCancelled {user :: User, chatItem_ :: Maybe AChatItem, fileTransferMeta :: FileTransferMeta, sndFileTransfers :: [SndFileTransfer]}
|
||||
| CRSndStandaloneFileCreated {user :: User, fileTransferMeta :: FileTransferMeta} -- returned by _upload
|
||||
| CRSndFileStartXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta} -- not used
|
||||
| CRSndFileProgressXFTP {user :: User, chatItem_ :: Maybe AChatItem, fileTransferMeta :: FileTransferMeta, sentSize :: Int64, totalSize :: Int64}
|
||||
| CRSndFileRedirectStartXFTP {user :: User, fileTransferMeta :: FileTransferMeta, redirectMeta :: FileTransferMeta}
|
||||
| CRSndFileCompleteXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta}
|
||||
| CRSndFileCancelledXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta}
|
||||
| CRSndFileError {user :: User, chatItem :: AChatItem}
|
||||
| CRSndStandaloneFileComplete {user :: User, fileTransferMeta :: FileTransferMeta, rcvURIs :: [Text]}
|
||||
| CRSndFileCancelledXFTP {user :: User, chatItem_ :: Maybe AChatItem, fileTransferMeta :: FileTransferMeta}
|
||||
| CRSndFileError {user :: User, chatItem_ :: Maybe AChatItem, fileTransferMeta :: FileTransferMeta}
|
||||
| CRUserProfileUpdated {user :: User, fromProfile :: Profile, toProfile :: Profile, updateSummary :: UserProfileUpdateSummary}
|
||||
| CRUserProfileImage {user :: User, profile :: Profile}
|
||||
| CRContactAliasUpdated {user :: User, toContact :: Contact}
|
||||
|
||||
22
src/Simplex/Chat/Migrations/M20240214_redirect_file_id.hs
Normal file
22
src/Simplex/Chat/Migrations/M20240214_redirect_file_id.hs
Normal file
@ -0,0 +1,22 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20240214_redirect_file_id where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20240214_redirect_file_id :: Query
|
||||
m20240214_redirect_file_id =
|
||||
[sql|
|
||||
ALTER TABLE files ADD COLUMN redirect_file_id INTEGER REFERENCES files ON DELETE CASCADE;
|
||||
|
||||
CREATE INDEX idx_files_redirect_file_id on files(redirect_file_id);
|
||||
|]
|
||||
|
||||
down_m20240214_redirect_file_id :: Query
|
||||
down_m20240214_redirect_file_id =
|
||||
[sql|
|
||||
DROP INDEX idx_files_redirect_file_id;
|
||||
|
||||
ALTER TABLE files DROP COLUMN redirect_file_id;
|
||||
|]
|
||||
@ -193,7 +193,8 @@ CREATE TABLE files(
|
||||
protocol TEXT NOT NULL DEFAULT 'smp',
|
||||
file_crypto_key BLOB,
|
||||
file_crypto_nonce BLOB,
|
||||
note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE
|
||||
note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE,
|
||||
redirect_file_id INTEGER REFERENCES files ON DELETE CASCADE
|
||||
);
|
||||
CREATE TABLE snd_files(
|
||||
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
|
||||
@ -854,3 +855,4 @@ CREATE INDEX idx_chat_items_notes_item_status on chat_items(
|
||||
note_folder_id,
|
||||
item_status
|
||||
);
|
||||
CREATE INDEX idx_files_redirect_file_id on files(redirect_file_id);
|
||||
|
||||
@ -39,6 +39,7 @@ module Simplex.Chat.Store.Files
|
||||
getGroupFileIdBySharedMsgId,
|
||||
getDirectFileIdBySharedMsgId,
|
||||
getChatRefByFileId,
|
||||
lookupChatRefByFileId,
|
||||
updateSndFileStatus,
|
||||
createSndFileChunk,
|
||||
updateSndFileChunkMsg,
|
||||
@ -46,6 +47,7 @@ module Simplex.Chat.Store.Files
|
||||
deleteSndFileChunks,
|
||||
createRcvFileTransfer,
|
||||
createRcvGroupFileTransfer,
|
||||
createRcvStandaloneFileTransfer,
|
||||
appendRcvFD,
|
||||
getRcvFileDescrByRcvFileId,
|
||||
getRcvFileDescrBySndFileId,
|
||||
@ -70,6 +72,7 @@ module Simplex.Chat.Store.Files
|
||||
getFileTransfer,
|
||||
getFileTransferProgress,
|
||||
getFileTransferMeta,
|
||||
lookupFileTransferRedirectMeta,
|
||||
getSndFileTransfer,
|
||||
getSndFileTransfers,
|
||||
getContactFileInfo,
|
||||
@ -86,12 +89,14 @@ import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Either (rights)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (fromMaybe, isJust, listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Time (addUTCTime)
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime, nominalDay)
|
||||
import Data.Type.Equality
|
||||
import Data.Word (Word32)
|
||||
import Database.SQLite.Simple (Only (..), (:.) (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Database.SQLite.Simple.ToField (ToField)
|
||||
@ -184,7 +189,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, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
|
||||
pure FileTransferMeta {fileId, xftpSndFile = Nothing, xftpRedirectFor = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
|
||||
|
||||
createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> SubscriptionMode -> IO ()
|
||||
createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) subMode = do
|
||||
@ -204,7 +209,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, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?)"
|
||||
((userId, groupId, fileName, filePath, fileSize, chunkSize) :. (fileInline, CIFSSndStored, FPSMP, currentTs, currentTs))
|
||||
fileId <- insertedRowId db
|
||||
pure FileTransferMeta {fileId, xftpSndFile = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
|
||||
pure FileTransferMeta {fileId, xftpSndFile = Nothing, xftpRedirectFor = Nothing, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
|
||||
|
||||
createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> SubscriptionMode -> IO ()
|
||||
createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} subMode = do
|
||||
@ -277,16 +282,16 @@ getSndFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMs
|
||||
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileDescrId, fileInline, groupMemberId, recipientDisplayName = n, connId, agentConnId})
|
||||
<$> (contactName_ <|> memberName_)
|
||||
|
||||
createSndFileTransferXFTP :: DB.Connection -> User -> ContactOrGroup -> CryptoFile -> FileInvitation -> AgentSndFileId -> Integer -> IO FileTransferMeta
|
||||
createSndFileTransferXFTP db User {userId} contactOrGroup (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize} agentSndFileId chunkSize = do
|
||||
createSndFileTransferXFTP :: DB.Connection -> User -> Maybe ContactOrGroup -> CryptoFile -> FileInvitation -> AgentSndFileId -> Maybe FileTransferId -> Integer -> IO FileTransferMeta
|
||||
createSndFileTransferXFTP db User {userId} contactOrGroup_ (CryptoFile filePath cryptoArgs) FileInvitation {fileName, fileSize} agentSndFileId xftpRedirectFor chunkSize = do
|
||||
currentTs <- getCurrentTime
|
||||
let xftpSndFile = Just XFTPSndFile {agentSndFileId, privateSndFileDescr = Nothing, agentSndFileDeleted = False, cryptoArgs}
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
(contactAndGroupIds contactOrGroup :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
|
||||
"INSERT INTO files (contact_id, group_id, user_id, file_name, file_path, file_crypto_key, file_crypto_nonce, file_size, chunk_size, redirect_file_id, agent_snd_file_id, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
(maybe (Nothing, Nothing) contactAndGroupIds contactOrGroup_ :. (userId, fileName, filePath, CF.fileKey <$> cryptoArgs, CF.fileNonce <$> cryptoArgs, fileSize, chunkSize) :. (xftpRedirectFor, agentSndFileId, CIFSSndStored, FPXFTP, currentTs, currentTs))
|
||||
fileId <- insertedRowId db
|
||||
pure FileTransferMeta {fileId, xftpSndFile, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
|
||||
pure FileTransferMeta {fileId, xftpSndFile, xftpRedirectFor, fileName, filePath, fileSize, fileInline = Nothing, chunkSize, cancelled = False}
|
||||
|
||||
createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO ()
|
||||
createSndFTDescrXFTP db User {userId} m Connection {connId} FileTransferMeta {fileId} FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
|
||||
@ -421,11 +426,14 @@ getDirectFileIdBySharedMsgId db User {userId} Contact {contactId} sharedMsgId =
|
||||
(userId, contactId, sharedMsgId)
|
||||
|
||||
getChatRefByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO ChatRef
|
||||
getChatRefByFileId db User {userId} fileId =
|
||||
liftIO getChatRef >>= \case
|
||||
[(Just contactId, Nothing)] -> pure $ ChatRef CTDirect contactId
|
||||
[(Nothing, Just groupId)] -> pure $ ChatRef CTGroup groupId
|
||||
_ -> throwError $ SEInternalError "could not retrieve chat ref by file id"
|
||||
getChatRefByFileId db user fileId = liftIO (lookupChatRefByFileId db user fileId) >>= maybe (throwError $ SEInternalError "could not retrieve chat ref by file id") pure
|
||||
|
||||
lookupChatRefByFileId :: DB.Connection -> User -> Int64 -> IO (Maybe ChatRef)
|
||||
lookupChatRefByFileId db User {userId} fileId =
|
||||
getChatRef <&> \case
|
||||
[(Just contactId, Nothing)] -> Just $ ChatRef CTDirect contactId
|
||||
[(Nothing, Just groupId)] -> Just $ ChatRef CTGroup groupId
|
||||
_ -> Nothing
|
||||
where
|
||||
getChatRef =
|
||||
DB.query
|
||||
@ -536,6 +544,23 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD
|
||||
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs)
|
||||
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId, cryptoArgs = Nothing}
|
||||
|
||||
createRcvStandaloneFileTransfer :: DB.Connection -> UserId -> CryptoFile -> Int64 -> Word32 -> ExceptT StoreError IO Int64
|
||||
createRcvStandaloneFileTransfer db userId (CryptoFile filePath cfArgs_) fileSize chunkSize = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
fileId <- liftIO $ do
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO files (user_id, file_name, file_path, file_size, chunk_size, ci_file_status, protocol, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
|
||||
(userId, takeFileName filePath, filePath, fileSize, chunkSize, CIFSRcvInvitation, FPXFTP, currentTs, currentTs)
|
||||
insertedRowId db
|
||||
liftIO . forM_ cfArgs_ $ \cfArgs -> setFileCryptoArgs_ db fileId cfArgs currentTs
|
||||
liftIO $
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO rcv_files (file_id, file_status, created_at, updated_at) VALUES (?,?,?,?)"
|
||||
(fileId, FSNew, currentTs, currentTs)
|
||||
pure fileId
|
||||
|
||||
createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr
|
||||
createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
|
||||
when (fileDescrPartNo /= 0) $ throwError SERcvFileInvalidDescrPart
|
||||
@ -662,9 +687,9 @@ getRcvFileTransfer_ db userId fileId = do
|
||||
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, Bool) :. (Maybe Int64, Maybe AgentConnId) ->
|
||||
ExceptT StoreError IO RcvFileTransfer
|
||||
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, agentRcvFileDeleted) :. (connId_, agentConnId_)) =
|
||||
case contactName_ <|> memberName_ of
|
||||
case contactName_ <|> memberName_ <|> standaloneName_ of
|
||||
Nothing -> throwError $ SERcvFileInvalid fileId
|
||||
Just name -> do
|
||||
Just name ->
|
||||
case fileStatus' of
|
||||
FSNew -> pure $ ft name RFSNew
|
||||
FSAccepted -> ft name . RFSAccepted <$> rfi
|
||||
@ -672,6 +697,9 @@ getRcvFileTransfer_ db userId fileId = do
|
||||
FSComplete -> ft name . RFSComplete <$> rfi
|
||||
FSCancelled -> ft name . RFSCancelled <$> rfi_
|
||||
where
|
||||
standaloneName_ = case (connId_, agentRcvFileId, filePath_) of
|
||||
(Nothing, Just _, Just _) -> Just "" -- filePath marks files that are accepted from contact or, in this case, set by createRcvDirectFileTransfer
|
||||
_ -> Nothing
|
||||
ft senderDisplayName fileStatus =
|
||||
let fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
|
||||
cryptoArgs = CFArgs <$> fileKey <*> fileNonce
|
||||
@ -906,17 +934,22 @@ getFileTransferMeta_ db userId fileId =
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT file_name, file_size, chunk_size, file_path, file_crypto_key, file_crypto_nonce, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled
|
||||
SELECT file_name, file_size, chunk_size, file_path, file_crypto_key, file_crypto_nonce, file_inline, agent_snd_file_id, agent_snd_file_deleted, private_snd_file_descr, cancelled, redirect_file_id
|
||||
FROM files
|
||||
WHERE user_id = ? AND file_id = ?
|
||||
|]
|
||||
(userId, fileId)
|
||||
where
|
||||
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool) -> FileTransferMeta
|
||||
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileKey, fileNonce, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_) =
|
||||
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe AgentSndFileId, Bool, Maybe Text, Maybe Bool, Maybe FileTransferId) -> FileTransferMeta
|
||||
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileKey, fileNonce, fileInline, aSndFileId_, agentSndFileDeleted, privateSndFileDescr, cancelled_, xftpRedirectFor) =
|
||||
let cryptoArgs = CFArgs <$> fileKey <*> fileNonce
|
||||
xftpSndFile = (\fId -> XFTPSndFile {agentSndFileId = fId, privateSndFileDescr, agentSndFileDeleted, cryptoArgs}) <$> aSndFileId_
|
||||
in FileTransferMeta {fileId, xftpSndFile, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
|
||||
in FileTransferMeta {fileId, xftpSndFile, xftpRedirectFor, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
|
||||
|
||||
lookupFileTransferRedirectMeta :: DB.Connection -> User -> Int64 -> IO [FileTransferMeta]
|
||||
lookupFileTransferRedirectMeta db User {userId} fileId = do
|
||||
redirects <- DB.query db "SELECT file_id FROM files WHERE user_id = ? AND redirect_file_id = ?" (userId, fileId)
|
||||
rights <$> mapM (runExceptT . getFileTransferMeta_ db userId . fromOnly) redirects
|
||||
|
||||
createLocalFile :: ToField (CIFileStatus d) => CIFileStatus d -> DB.Connection -> User -> NoteFolder -> ChatItemId -> UTCTime -> CryptoFile -> Integer -> Integer -> IO Int64
|
||||
createLocalFile fileStatus db User {userId} NoteFolder {noteFolderId} chatItemId itemTs CryptoFile {filePath, cryptoArgs} fileSize fileChunkSize = do
|
||||
|
||||
@ -92,6 +92,7 @@ module Simplex.Chat.Store.Messages
|
||||
getLocalChatItemIdByText,
|
||||
getLocalChatItemIdByText',
|
||||
getChatItemByFileId,
|
||||
lookupChatItemByFileId,
|
||||
getChatItemByGroupId,
|
||||
updateDirectChatItemStatus,
|
||||
getTimedItems,
|
||||
@ -2085,6 +2086,12 @@ getChatItemByFileId db vr user@User {userId} fileId = do
|
||||
(userId, fileId)
|
||||
getAChatItem db vr user chatRef itemId
|
||||
|
||||
lookupChatItemByFileId :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO (Maybe AChatItem)
|
||||
lookupChatItemByFileId db vr user fileId = do
|
||||
fmap Just (getChatItemByFileId db vr user fileId) `catchError` \case
|
||||
SEChatItemNotFoundByFileId {} -> pure Nothing
|
||||
e -> throwError e
|
||||
|
||||
getChatItemByGroupId :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByGroupId db vr user@User {userId} groupId = do
|
||||
(chatRef, itemId) <-
|
||||
|
||||
@ -98,6 +98,7 @@ import Simplex.Chat.Migrations.M20240102_note_folders
|
||||
import Simplex.Chat.Migrations.M20240104_members_profile_update
|
||||
import Simplex.Chat.Migrations.M20240115_block_member_for_all
|
||||
import Simplex.Chat.Migrations.M20240122_indexes
|
||||
import Simplex.Chat.Migrations.M20240214_redirect_file_id
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@ -195,7 +196,8 @@ schemaMigrations =
|
||||
("20240102_note_folders", m20240102_note_folders, Just down_m20240102_note_folders),
|
||||
("20240104_members_profile_update", m20240104_members_profile_update, Just down_m20240104_members_profile_update),
|
||||
("20240115_block_member_for_all", m20240115_block_member_for_all, Just down_m20240115_block_member_for_all),
|
||||
("20240122_indexes", m20240122_indexes, Just down_m20240122_indexes)
|
||||
("20240122_indexes", m20240122_indexes, Just down_m20240122_indexes),
|
||||
("20240214_redirect_file_id", m20240214_redirect_file_id, Just down_m20240214_redirect_file_id)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@ -1210,6 +1210,7 @@ data FileTransfer
|
||||
data FileTransferMeta = FileTransferMeta
|
||||
{ fileId :: FileTransferId,
|
||||
xftpSndFile :: Maybe XFTPSndFile,
|
||||
xftpRedirectFor :: Maybe FileTransferId,
|
||||
fileName :: String,
|
||||
filePath :: String,
|
||||
fileSize :: Integer,
|
||||
|
||||
@ -198,17 +198,24 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
CRGroupMemberUpdated {} -> []
|
||||
CRContactsMerged u intoCt mergedCt ct' -> ttyUser u $ viewContactsMerged intoCt mergedCt ct'
|
||||
CRReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} -> ttyUser u $ viewReceivedContactRequest c profile
|
||||
CRRcvStandaloneFileCreated u ft -> ttyUser u $ receivingFileStandalone "started" ft
|
||||
CRRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci
|
||||
CRRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci
|
||||
CRRcvStandaloneFileComplete u _ ft -> ttyUser u $ receivingFileStandalone "completed" ft
|
||||
CRRcvFileSndCancelled u _ ft -> ttyUser u $ viewRcvFileSndCancelled ft
|
||||
CRRcvFileError u ci e -> ttyUser u $ receivingFile_' hu testView "error" ci <> [sShow e]
|
||||
CRRcvFileError u (Just ci) e _ -> ttyUser u $ receivingFile_' hu testView "error" ci <> [sShow e]
|
||||
CRRcvFileError u Nothing e ft -> ttyUser u $ receivingFileStandalone "error" ft <> [sShow e]
|
||||
CRSndFileStart u _ ft -> ttyUser u $ sendingFile_ "started" ft
|
||||
CRSndFileComplete u _ ft -> ttyUser u $ sendingFile_ "completed" ft
|
||||
CRSndStandaloneFileCreated u ft -> ttyUser u $ uploadingFileStandalone "started" ft
|
||||
CRSndFileStartXFTP {} -> []
|
||||
CRSndFileProgressXFTP {} -> []
|
||||
CRSndFileRedirectStartXFTP u ft ftRedirect -> ttyUser u $ standaloneUploadRedirect ft ftRedirect
|
||||
CRSndStandaloneFileComplete u ft uris -> ttyUser u $ standaloneUploadComplete ft uris
|
||||
CRSndFileCompleteXFTP u ci _ -> ttyUser u $ uploadingFile "completed" ci
|
||||
CRSndFileCancelledXFTP {} -> []
|
||||
CRSndFileError u ci -> ttyUser u $ uploadingFile "error" ci
|
||||
CRSndFileError u Nothing ft -> ttyUser u $ uploadingFileStandalone "error" ft
|
||||
CRSndFileError u (Just ci) _ -> ttyUser u $ uploadingFile "error" ci
|
||||
CRSndFileRcvCancelled u _ ft@SndFileTransfer {recipientDisplayName = c} ->
|
||||
ttyUser u [ttyContact c <> " cancelled receiving " <> sndFile ft]
|
||||
CRContactConnecting u _ -> ttyUser u []
|
||||
@ -1558,11 +1565,26 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
[status <> " sending " <> sndFile ft <> " to " <> ttyContact c]
|
||||
|
||||
uploadingFile :: StyledString -> AChatItem -> [StyledString]
|
||||
uploadingFile status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectSnd}) =
|
||||
uploadingFile status = \case
|
||||
AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectSnd} ->
|
||||
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyContact c]
|
||||
uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd}) =
|
||||
AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd} ->
|
||||
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g]
|
||||
uploadingFile status _ = [status <> " uploading file"] -- shouldn't happen
|
||||
_ -> [status <> " uploading file"]
|
||||
|
||||
uploadingFileStandalone :: StyledString -> FileTransferMeta -> [StyledString]
|
||||
uploadingFileStandalone status FileTransferMeta {fileId, fileName} = [status <> " standalone uploading " <> fileTransferStr fileId fileName]
|
||||
|
||||
standaloneUploadRedirect :: FileTransferMeta -> FileTransferMeta -> [StyledString]
|
||||
standaloneUploadRedirect FileTransferMeta {fileId, fileName} FileTransferMeta {fileId = redirectId} =
|
||||
[fileTransferStr fileId fileName <> " uploaded, preparing redirect file " <> sShow redirectId]
|
||||
|
||||
standaloneUploadComplete :: FileTransferMeta -> [Text] -> [StyledString]
|
||||
standaloneUploadComplete FileTransferMeta {fileId, fileName} = \case
|
||||
[] -> [fileTransferStr fileId fileName <> " upload complete."]
|
||||
uris ->
|
||||
fileTransferStr fileId fileName <> " upload complete. download with:"
|
||||
: map plain uris
|
||||
|
||||
sndFile :: SndFileTransfer -> StyledString
|
||||
sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName
|
||||
@ -1608,7 +1630,11 @@ receivingFile_' hu testView status (AChatItem _ _ chat ChatItem {file = Just CIF
|
||||
highlight ("/get remote file " <> show rhId <> " " <> LB.unpack (J.encode RemoteFile {userId, fileId, sent = False, fileSource = f}))
|
||||
]
|
||||
_ -> []
|
||||
receivingFile_' _ _ status _ = [plain status <> " receiving file"] -- shouldn't happen
|
||||
receivingFile_' _ _ status _ = [plain status <> " receiving file"]
|
||||
|
||||
receivingFileStandalone :: String -> RcvFileTransfer -> [StyledString]
|
||||
receivingFileStandalone status RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} =
|
||||
[plain status <> " standalone receiving " <> fileTransferStr fileId fileName]
|
||||
|
||||
viewLocalFile :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
|
||||
viewLocalFile to CIFile {fileId, fileSource} ts tz = case fileSource of
|
||||
@ -1627,7 +1653,7 @@ fileFrom _ _ = ""
|
||||
|
||||
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
|
||||
receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c]
|
||||
[status <> " receiving " <> rcvFile ft <> if c == "" then "" else " from " <> ttyContact c]
|
||||
|
||||
rcvFile :: RcvFileTransfer -> StyledString
|
||||
rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = fileTransferStr fileId fileName
|
||||
|
||||
@ -9,6 +9,7 @@ import ChatClient
|
||||
import ChatTests.Utils
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Logger.Simple
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
@ -77,6 +78,11 @@ chatFileTests = do
|
||||
it "cancel receiving file, repeat receive" testXFTPCancelRcvRepeat
|
||||
it "should accept file automatically with CLI option" testAutoAcceptFile
|
||||
it "should prohibit file transfers in groups based on preference" testProhibitFiles
|
||||
describe "file transfer over XFTP without chat items" $ do
|
||||
it "send and receive small standalone file" testXFTPStandaloneSmall
|
||||
it "send and receive large standalone file" testXFTPStandaloneLarge
|
||||
xit "removes sent file from server" testXFTPStandaloneCancelSnd -- no error shown in tests
|
||||
it "removes received temporary files" testXFTPStandaloneCancelRcv
|
||||
|
||||
runTestFileTransfer :: HasCallStack => TestCC -> TestCC -> IO ()
|
||||
runTestFileTransfer alice bob = do
|
||||
@ -1545,6 +1551,116 @@ testProhibitFiles =
|
||||
where
|
||||
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
|
||||
|
||||
testXFTPStandaloneSmall :: HasCallStack => FilePath -> IO ()
|
||||
testXFTPStandaloneSmall = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do
|
||||
withXFTPServer $ do
|
||||
logNote "sending"
|
||||
src ##> "/_upload 1 ./tests/fixtures/test.jpg"
|
||||
src <## "started standalone uploading file 1 (test.jpg)"
|
||||
-- silent progress events
|
||||
threadDelay 250000
|
||||
src <## "file 1 (test.jpg) upload complete. download with:"
|
||||
-- file description fits, enjoy the direct URIs
|
||||
_uri1 <- getTermLine src
|
||||
_uri2 <- getTermLine src
|
||||
uri3 <- getTermLine src
|
||||
_uri4 <- getTermLine src
|
||||
|
||||
logNote "receiving"
|
||||
let dstFile = "./tests/tmp/test.jpg"
|
||||
dst ##> ("/_download 1 " <> uri3 <> " " <> dstFile)
|
||||
dst <## "started standalone receiving file 1 (test.jpg)"
|
||||
-- silent progress events
|
||||
threadDelay 250000
|
||||
dst <## "completed standalone receiving file 1 (test.jpg)"
|
||||
srcBody <- B.readFile "./tests/fixtures/test.jpg"
|
||||
B.readFile dstFile `shouldReturn` srcBody
|
||||
|
||||
testXFTPStandaloneLarge :: HasCallStack => FilePath -> IO ()
|
||||
testXFTPStandaloneLarge = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do
|
||||
withXFTPServer $ do
|
||||
xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"]
|
||||
|
||||
logNote "sending"
|
||||
src ##> "/_upload 1 ./tests/tmp/testfile.in"
|
||||
src <## "started standalone uploading file 1 (testfile.in)"
|
||||
-- silent progress events
|
||||
threadDelay 250000
|
||||
src <## "file 1 (testfile.in) uploaded, preparing redirect file 2"
|
||||
src <## "file 1 (testfile.in) upload complete. download with:"
|
||||
uri <- getTermLine src
|
||||
_uri2 <- getTermLine src
|
||||
_uri3 <- getTermLine src
|
||||
_uri4 <- getTermLine src
|
||||
|
||||
logNote "receiving"
|
||||
let dstFile = "./tests/tmp/testfile.out"
|
||||
dst ##> ("/_download 1 " <> uri <> " " <> dstFile)
|
||||
dst <## "started standalone receiving file 1 (testfile.out)"
|
||||
-- silent progress events
|
||||
threadDelay 250000
|
||||
dst <## "completed standalone receiving file 1 (testfile.out)"
|
||||
srcBody <- B.readFile "./tests/tmp/testfile.in"
|
||||
B.readFile dstFile `shouldReturn` srcBody
|
||||
|
||||
testXFTPStandaloneCancelSnd :: HasCallStack => FilePath -> IO ()
|
||||
testXFTPStandaloneCancelSnd = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do
|
||||
withXFTPServer $ do
|
||||
xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"]
|
||||
|
||||
logNote "sending"
|
||||
src ##> "/_upload 1 ./tests/tmp/testfile.in"
|
||||
src <## "started standalone uploading file 1 (testfile.in)"
|
||||
-- silent progress events
|
||||
threadDelay 250000
|
||||
src <## "file 1 (testfile.in) uploaded, preparing redirect file 2"
|
||||
src <## "file 1 (testfile.in) upload complete. download with:"
|
||||
uri <- getTermLine src
|
||||
_uri2 <- getTermLine src
|
||||
_uri3 <- getTermLine src
|
||||
_uri4 <- getTermLine src
|
||||
|
||||
logNote "cancelling"
|
||||
src ##> "/fc 1"
|
||||
src <## "cancelled sending file 1 (testfile.in)"
|
||||
threadDelay 1000000
|
||||
|
||||
logNote "trying to receive cancelled"
|
||||
dst ##> ("/_download 1 " <> uri <> " " <> "./tests/tmp/should.not.extist")
|
||||
dst <## "started standalone receiving file 1 (should.not.extist)"
|
||||
threadDelay 100000
|
||||
logWarn "no error?"
|
||||
dst <## "error receiving file 1 (should.not.extist)"
|
||||
dst <## "INTERNAL {internalErr = \"XFTP {xftpErr = AUTH}\"}"
|
||||
|
||||
testXFTPStandaloneCancelRcv :: HasCallStack => FilePath -> IO ()
|
||||
testXFTPStandaloneCancelRcv = testChat2 aliceProfile aliceDesktopProfile $ \src dst -> do
|
||||
withXFTPServer $ do
|
||||
xftpCLI ["rand", "./tests/tmp/testfile.in", "17mb"] `shouldReturn` ["File created: " <> "./tests/tmp/testfile.in"]
|
||||
|
||||
logNote "sending"
|
||||
src ##> "/_upload 1 ./tests/tmp/testfile.in"
|
||||
src <## "started standalone uploading file 1 (testfile.in)"
|
||||
-- silent progress events
|
||||
threadDelay 250000
|
||||
src <## "file 1 (testfile.in) uploaded, preparing redirect file 2"
|
||||
src <## "file 1 (testfile.in) upload complete. download with:"
|
||||
uri <- getTermLine src
|
||||
_uri2 <- getTermLine src
|
||||
_uri3 <- getTermLine src
|
||||
_uri4 <- getTermLine src
|
||||
|
||||
logNote "receiving"
|
||||
let dstFile = "./tests/tmp/testfile.out"
|
||||
dst ##> ("/_download 1 " <> uri <> " " <> dstFile)
|
||||
dst <## "started standalone receiving file 1 (testfile.out)"
|
||||
threadDelay 25000 -- give workers some time to avoid internal errors from starting tasks
|
||||
logNote "cancelling"
|
||||
dst ##> "/fc 1"
|
||||
dst <## "cancelled receiving file 1 (testfile.out)"
|
||||
threadDelay 25000
|
||||
doesFileExist dstFile `shouldReturn` False
|
||||
|
||||
startFileTransfer :: HasCallStack => TestCC -> TestCC -> IO ()
|
||||
startFileTransfer alice bob =
|
||||
startFileTransfer' alice bob "test.jpg" "136.5 KiB / 139737 bytes"
|
||||
|
||||
@ -152,7 +152,7 @@ testFiles tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
|
||||
alice ##> "/clear *"
|
||||
alice ##> "/fs 1"
|
||||
alice <## "chat db error: SEChatItemNotFoundByFileId {fileId = 1}"
|
||||
alice <## "file 1 not found"
|
||||
alice ##> "/tail"
|
||||
doesFileExist stored `shouldReturn` False
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user