core: XFTP file transfer test (#2009)
This commit is contained in:
spaced4ndy
GitHub
parent
fda41817e9
commit
12200a74ff
@ -7,7 +7,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: db120b6d2eee04836a132f0bfbca9491cacf3dc8
|
||||
tag: a0eb53b891b1f4f765f440020654fbae45bf8b00
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."db120b6d2eee04836a132f0bfbca9491cacf3dc8" = "0md0i4vl84mdmkgwjrmlkipqm9k1rqbld0ld1xxss3z1xdb7fdrj";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."a0eb53b891b1f4f765f440020654fbae45bf8b00" = "0nbqj26yzdw3h5p4zdw4l65ybi60f571gpl3244fmmv7ll8v8ys8";
|
||||
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
|
||||
"https://github.com/kazu-yamamoto/http2.git"."78e18f52295a7f89e828539a03fbcb24931461a3" = "05q165anvv0qrcxqbvq1dlvw0l8gmsa9kl6sazk1mfhz2g0yimdk";
|
||||
"https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
|
||||
|
||||
@ -15,7 +15,7 @@
|
||||
module Simplex.Chat where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Concurrent.STM (retry, stateTVar)
|
||||
import Control.Concurrent.STM (retry)
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
@ -111,6 +111,7 @@ defaultChatConfig =
|
||||
xftpDescrPartSize = 14000,
|
||||
inlineFiles = defaultInlineFilesConfig,
|
||||
xftpFileConfig = Nothing,
|
||||
tempDir = Nothing,
|
||||
logLevel = CLLImportant,
|
||||
subscriptionEvents = False,
|
||||
hostEvents = False,
|
||||
@ -145,7 +146,7 @@ createChatDatabase filePrefix key yesToMigrations = do
|
||||
pure ChatDatabase {chatStore, agentStore}
|
||||
|
||||
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> IO ChatController
|
||||
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles} ChatOpts {coreOptions = CoreChatOpts {smpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, allowInstantFiles} sendToast = do
|
||||
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, allowInstantFiles} sendToast = do
|
||||
let inlineFiles' = if allowInstantFiles then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
|
||||
config = cfg {logLevel, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles'}
|
||||
sendNotification = fromMaybe (const $ pure ()) sendToast
|
||||
@ -171,7 +172,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
||||
timedItemThreads <- atomically TM.empty
|
||||
showLiveItems <- newTVarIO False
|
||||
userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg
|
||||
tempDirectory <- newTVarIO Nothing
|
||||
tempDirectory <- newTVarIO tempDir
|
||||
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, tempDirectory, logFilePath = logFile}
|
||||
where
|
||||
configServers :: DefaultAgentServers
|
||||
@ -535,6 +536,7 @@ processChatCommand = \case
|
||||
fInv = xftpFileInvitation fileName fileSize fileDescr
|
||||
tmp <- readTVarIO =<< asks tempDirectory
|
||||
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) file n tmp
|
||||
-- TODO CRSndFileStart event for XFTP
|
||||
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv $ AgentSndFileId aFileId
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
|
||||
case contactOrGroup of
|
||||
@ -1766,11 +1768,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, rcvFileDescription
|
||||
-- direct file protocol
|
||||
(Nothing, Just connReq) -> do
|
||||
connIds <- joinAgentConnectionAsync user True connReq . directMessage $ XFileAcpt fName
|
||||
filePath <- getRcvFilePath fileId filePath_ fName
|
||||
filePath <- getRcvFilePath fileId filePath_ fName True
|
||||
withStore $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath
|
||||
-- XFTP
|
||||
(Just rfd, _) -> do
|
||||
filePath <- getRcvFilePath fileId filePath_ fName
|
||||
filePath <- getRcvFilePath fileId filePath_ fName False
|
||||
ci <- withStore $ \db -> xftpAcceptRcvFT db user fileId filePath
|
||||
receiveViaCompleteFD user fileId filePath rfd
|
||||
pure ci
|
||||
@ -1791,7 +1793,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, rcvFileDescription
|
||||
where
|
||||
acceptFile :: CommandFunction -> (ChatMsgEvent 'Json -> m ()) -> m AChatItem
|
||||
acceptFile cmdFunction send = do
|
||||
filePath <- getRcvFilePath fileId filePath_ fName
|
||||
filePath <- getRcvFilePath fileId filePath_ fName True
|
||||
inline <- receiveInline
|
||||
if
|
||||
| inline -> do
|
||||
@ -1821,10 +1823,19 @@ receiveViaCompleteFD user fileId filePath RcvFileDescr {fileDescrText, fileDescr
|
||||
rd <- parseRcvFileDescription fileDescrText
|
||||
tmp <- readTVarIO =<< asks tempDirectory
|
||||
aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd tmp filePath
|
||||
startReceivingFile user fileId
|
||||
withStore' $ \db -> updateRcvFileAgentId db fileId (AgentRcvFileId aFileId)
|
||||
|
||||
getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> m FilePath
|
||||
getRcvFilePath fileId fPath_ fn = case fPath_ of
|
||||
startReceivingFile :: ChatMonad m => User -> FileTransferId -> m ()
|
||||
startReceivingFile user fileId = do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateRcvFileStatus db fileId FSConnected
|
||||
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
|
||||
getChatItemByFileId db user fileId
|
||||
toView $ CRRcvFileStart user ci
|
||||
|
||||
getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> Bool -> m FilePath
|
||||
getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of
|
||||
Nothing ->
|
||||
asks filesFolder >>= readTVarIO >>= \case
|
||||
Nothing -> do
|
||||
@ -1849,9 +1860,15 @@ getRcvFilePath fileId fPath_ fn = case fPath_ of
|
||||
createEmptyFile fPath = emptyFile fPath `E.catch` (throwChatError . CEFileWrite fPath . (show :: E.SomeException -> String))
|
||||
emptyFile :: FilePath -> m FilePath
|
||||
emptyFile fPath = do
|
||||
h <- getFileHandle fileId fPath rcvFiles AppendMode
|
||||
h <-
|
||||
if keepHandle
|
||||
then getFileHandle fileId fPath rcvFiles AppendMode
|
||||
else getTmpHandle fPath
|
||||
liftIO $ B.hPut h "" >> hFlush h
|
||||
pure fPath
|
||||
getTmpHandle :: FilePath -> m Handle
|
||||
getTmpHandle fPath =
|
||||
liftIO (openFile fPath AppendMode) `E.catch` (throwChatError . CEFileInternal . (show :: E.SomeException -> String))
|
||||
uniqueCombine :: FilePath -> String -> m FilePath
|
||||
uniqueCombine filePath fileName = tryCombine (0 :: Int)
|
||||
where
|
||||
@ -2238,7 +2255,7 @@ processAgentMsgRcvFile _corrId aFileId msg =
|
||||
RFDONE -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ do
|
||||
updateRcvFileStatus' db fileId FSComplete
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
updateCIFileStatus db user fileId CIFSRcvComplete
|
||||
getChatItemByFileId db user fileId
|
||||
-- ack to agent
|
||||
@ -2673,7 +2690,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
case chatMsgEvent of
|
||||
XOk -> allowAgentConnectionAsync user conn confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
_ -> pure ()
|
||||
CON -> startReceivingFile ft
|
||||
CON -> startReceivingFile user fileId
|
||||
MSG meta _ msgBody -> do
|
||||
parseFileChunk msgBody >>= receiveFileChunk ft (Just conn) meta
|
||||
OK ->
|
||||
@ -2688,14 +2705,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- TODO add debugging output
|
||||
_ -> pure ()
|
||||
|
||||
startReceivingFile :: RcvFileTransfer -> m ()
|
||||
startReceivingFile ft@RcvFileTransfer {fileId} = do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateRcvFileStatus db ft FSConnected
|
||||
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
|
||||
getChatItemByFileId db user fileId
|
||||
toView $ CRRcvFileStart user ci
|
||||
|
||||
receiveFileChunk :: RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> m ()
|
||||
receiveFileChunk ft@RcvFileTransfer {fileId, chunkSize, cancelled} conn_ meta@MsgMeta {recipient = (msgId, _), integrity} = \case
|
||||
FileChunkCancel ->
|
||||
@ -2720,7 +2729,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
appendFileChunk ft chunkNo chunk
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ do
|
||||
updateRcvFileStatus db ft FSComplete
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
updateCIFileStatus db user fileId CIFSRcvComplete
|
||||
deleteRcvFileChunks db ft
|
||||
getChatItemByFileId db user fileId
|
||||
@ -2945,7 +2954,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ft@RcvFileTransfer {fileId} <- withStore $ \db -> createRcvFT db fInv inline fileChunkSize
|
||||
(filePath, fileStatus) <- case inline of
|
||||
Just IFMSent -> do
|
||||
fPath <- getRcvFilePath fileId Nothing fileName
|
||||
fPath <- getRcvFilePath fileId Nothing fileName True
|
||||
withStore' $ \db -> startRcvInlineFT db user ft fPath inline
|
||||
pure (Just fPath, CIFSRcvAccepted)
|
||||
_ -> pure (Nothing, CIFSRcvInvitation)
|
||||
@ -3171,9 +3180,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
receiveInlineChunk RcvFileTransfer {fileId, fileStatus = RFSNew} FileChunk {chunkNo} _
|
||||
| chunkNo == 1 = throwChatError $ CEInlineFileProhibited fileId
|
||||
| otherwise = pure ()
|
||||
receiveInlineChunk ft chunk meta = do
|
||||
receiveInlineChunk ft@RcvFileTransfer {fileId} chunk meta = do
|
||||
case chunk of
|
||||
FileChunk {chunkNo} -> when (chunkNo == 1) $ startReceivingFile ft
|
||||
FileChunk {chunkNo} -> when (chunkNo == 1) $ startReceivingFile user fileId
|
||||
_ -> pure ()
|
||||
receiveFileChunk ft Nothing meta chunk
|
||||
|
||||
@ -3714,7 +3723,7 @@ cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, rcvFileInline} =
|
||||
closeFileHandle fileId rcvFiles
|
||||
withStore' $ \db -> do
|
||||
updateFileCancelled db user fileId CIFSRcvCancelled
|
||||
updateRcvFileStatus db ft FSCancelled
|
||||
updateRcvFileStatus db fileId FSCancelled
|
||||
deleteRcvFileChunks db ft
|
||||
pure fileConnId
|
||||
fileConnId = if isNothing rcvFileInline then liveRcvFileTransferConnId ft else Nothing
|
||||
|
||||
@ -108,6 +108,7 @@ data ChatConfig = ChatConfig
|
||||
xftpDescrPartSize :: Int,
|
||||
inlineFiles :: InlineFilesConfig,
|
||||
xftpFileConfig :: Maybe XFTPFileConfig, -- Nothing - XFTP is disabled
|
||||
tempDir :: Maybe FilePath,
|
||||
subscriptionEvents :: Bool,
|
||||
hostEvents :: Bool,
|
||||
logLevel :: ChatLogLevel,
|
||||
|
||||
@ -185,7 +185,6 @@ module Simplex.Chat.Store
|
||||
startRcvInlineFT,
|
||||
xftpAcceptRcvFT,
|
||||
updateRcvFileStatus,
|
||||
updateRcvFileStatus',
|
||||
createRcvFileChunk,
|
||||
updatedRcvFileChunkStored,
|
||||
deleteRcvFileChunks,
|
||||
@ -274,7 +273,6 @@ module Simplex.Chat.Store
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.STM (stateTVar)
|
||||
import Control.Exception (Exception)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad.Except
|
||||
@ -562,7 +560,7 @@ getUserByASndFileId db 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)
|
||||
DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id JOIN rcv_files r ON r.file_id = f.file_id WHERE r.agent_rcv_file_id = ?") (Only aRcvFileId)
|
||||
|
||||
getUserByContactId :: DB.Connection -> ContactId -> ExceptT StoreError IO User
|
||||
getUserByContactId db contactId =
|
||||
@ -2751,16 +2749,17 @@ createSndFileTransferXFTP db User {userId} contactOrGroup filePath FileInvitatio
|
||||
|
||||
createSndFTDescrXFTP :: DB.Connection -> User -> Maybe GroupMember -> Connection -> FileTransferMeta -> FileDescr -> IO ()
|
||||
createSndFTDescrXFTP db User {userId} m Connection {connId} FileTransferMeta {fileId} FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
|
||||
currentTs <- getCurrentTime
|
||||
let fileStatus = FSNew
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete) VALUES (?,?,?,?)"
|
||||
(userId, fileDescrText, fileDescrPartNo, fileDescrComplete)
|
||||
"INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
||||
(userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs)
|
||||
fileDescrId <- insertedRowId db
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO snd_files (file_id, file_status, file_descr_id, group_member_id, connection_id) VALUES (?,?,?,?,?)"
|
||||
(fileId, fileStatus, fileDescrId, groupMemberId' <$> m, connId)
|
||||
"INSERT INTO snd_files (file_id, file_status, file_descr_id, group_member_id, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
|
||||
(fileId, fileStatus, fileDescrId, groupMemberId' <$> m, connId, currentTs, currentTs)
|
||||
|
||||
updateSndFTDescrXFTP :: DB.Connection -> User -> SndFileTransfer -> Text -> IO ()
|
||||
updateSndFTDescrXFTP db user@User {userId} sft@SndFileTransfer {fileId, fileDescrId} rfdText = do
|
||||
@ -2937,7 +2936,7 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
|
||||
"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)
|
||||
insertedRowId db
|
||||
rfd <- mapM (createRcvFD_ db userId) fileDescr
|
||||
rfd <- mapM (createRcvFD_ db userId currentTs) fileDescr
|
||||
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd
|
||||
liftIO $
|
||||
DB.execute
|
||||
@ -2955,7 +2954,7 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD
|
||||
"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)
|
||||
insertedRowId db
|
||||
rfd <- mapM (createRcvFD_ db userId) fileDescr
|
||||
rfd <- mapM (createRcvFD_ db userId currentTs) fileDescr
|
||||
let rfdId = (fileDescrId :: RcvFileDescr -> Int64) <$> rfd
|
||||
liftIO $
|
||||
DB.execute
|
||||
@ -2964,14 +2963,14 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD
|
||||
(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 -> UserId -> FileDescr -> ExceptT StoreError IO RcvFileDescr
|
||||
createRcvFD_ db userId FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
|
||||
createRcvFD_ :: DB.Connection -> UserId -> UTCTime -> FileDescr -> ExceptT StoreError IO RcvFileDescr
|
||||
createRcvFD_ db userId currentTs FileDescr {fileDescrText, fileDescrPartNo, fileDescrComplete} = do
|
||||
when (fileDescrPartNo /= 0) $ throwError SERcvFileInvalidDescrPart
|
||||
fileDescrId <- liftIO $ do
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete) VALUES (?,?,?,?)"
|
||||
(userId, fileDescrText, fileDescrPartNo, fileDescrComplete)
|
||||
"INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
||||
(userId, fileDescrText, fileDescrPartNo, fileDescrComplete, currentTs, currentTs)
|
||||
insertedRowId db
|
||||
pure RcvFileDescr {fileDescrId, fileDescrPartNo, fileDescrText, fileDescrComplete}
|
||||
|
||||
@ -2980,7 +2979,7 @@ appendRcvFD db userId fileId fd@FileDescr {fileDescrText, fileDescrPartNo, fileD
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO (getRcvFileDescrByFileId_ db fileId) >>= \case
|
||||
Nothing -> do
|
||||
rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId fd
|
||||
rfd@RcvFileDescr {fileDescrId} <- createRcvFD_ db userId currentTs fd
|
||||
liftIO $
|
||||
DB.execute
|
||||
db
|
||||
@ -3127,11 +3126,8 @@ acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do
|
||||
"UPDATE rcv_files SET rcv_file_inline = ?, file_status = ?, updated_at = ? WHERE file_id = ?"
|
||||
(rcvFileInline, FSAccepted, currentTs, fileId)
|
||||
|
||||
updateRcvFileStatus :: DB.Connection -> RcvFileTransfer -> FileStatus -> IO ()
|
||||
updateRcvFileStatus db RcvFileTransfer {fileId} = updateRcvFileStatus' db fileId
|
||||
|
||||
updateRcvFileStatus' :: DB.Connection -> FileTransferId -> FileStatus -> IO ()
|
||||
updateRcvFileStatus' db fileId status = do
|
||||
updateRcvFileStatus :: DB.Connection -> FileTransferId -> FileStatus -> IO ()
|
||||
updateRcvFileStatus db fileId status = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?" (status, currentTs, fileId)
|
||||
|
||||
|
||||
@ -1500,7 +1500,7 @@ instance ToJSON FileDescr where
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
|
||||
instance FromJSON FileDescr where
|
||||
parseJSON = J.genericParseJSON . taggedObjectJSON $ dropPrefix "FD"
|
||||
parseJSON = J.genericParseJSON J.defaultOptions
|
||||
|
||||
xftpFileInvitation :: FilePath -> Integer -> FileDescr -> FileInvitation
|
||||
xftpFileInvitation fileName fileSize fileDescr =
|
||||
|
||||
@ -49,7 +49,7 @@ extra-deps:
|
||||
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
|
||||
# - ../simplexmq
|
||||
- github: simplex-chat/simplexmq
|
||||
commit: db120b6d2eee04836a132f0bfbca9491cacf3dc8
|
||||
commit: a0eb53b891b1f4f765f440020654fbae45bf8b00
|
||||
- github: kazu-yamamoto/http2
|
||||
commit: 78e18f52295a7f89e828539a03fbcb24931461a3
|
||||
# - ../direct-sqlcipher
|
||||
|
||||
@ -8,7 +8,7 @@ import ChatTests.Utils
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Simplex.Chat.Controller (ChatConfig (..), InlineFilesConfig (..), defaultInlineFilesConfig)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), InlineFilesConfig (..), XFTPFileConfig (..), defaultInlineFilesConfig)
|
||||
import Simplex.Chat.Options (ChatOpts (..))
|
||||
import Simplex.Messaging.Util (unlessM)
|
||||
import System.Directory (copyFile, doesFileExist)
|
||||
@ -48,6 +48,8 @@ chatFileTests = do
|
||||
it "v2" testAsyncFileTransfer
|
||||
it "v1" testAsyncFileTransferV1
|
||||
xit "send and receive file to group, fully asynchronous" testAsyncGroupFileTransfer
|
||||
describe "file transfer over XFTP" $ do
|
||||
it "send and receive file" testXFTPFileTransfer
|
||||
|
||||
runTestFileTransfer :: HasCallStack => TestCC -> TestCC -> IO ()
|
||||
runTestFileTransfer alice bob = do
|
||||
@ -915,6 +917,28 @@ testAsyncGroupFileTransfer tmp = do
|
||||
dest2 <- B.readFile "./tests/tmp/test_1.jpg"
|
||||
dest2 `shouldBe` src
|
||||
|
||||
testXFTPFileTransfer :: HasCallStack => FilePath -> IO ()
|
||||
testXFTPFileTransfer =
|
||||
testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
|
||||
connectUsers alice bob
|
||||
|
||||
alice #> "/f @bob ./tests/fixtures/test.pdf"
|
||||
alice <## "use /fc 1 to cancel sending"
|
||||
bob <# "alice> sends file test.pdf (266.0 KiB / 272376 bytes)"
|
||||
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
bob ##> "/fr 1 ./tests/tmp"
|
||||
bob <## "saving file 1 from alice to ./tests/tmp/test.pdf"
|
||||
-- alice <## "started sending file 1 (test.pdf) to bob" -- TODO "started uploading" ?
|
||||
alice <## "completed sending file 1 (test.pdf) to bob"
|
||||
bob <## "started receiving file 1 (test.pdf) from alice"
|
||||
bob <## "completed receiving file 1 (test.pdf) from alice"
|
||||
|
||||
src <- B.readFile "./tests/fixtures/test.pdf"
|
||||
dest <- B.readFile "./tests/tmp/test.pdf"
|
||||
dest `shouldBe` src
|
||||
where
|
||||
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
|
||||
|
||||
startFileTransfer :: HasCallStack => TestCC -> TestCC -> IO ()
|
||||
startFileTransfer alice bob =
|
||||
startFileTransfer' alice bob "test.jpg" "136.5 KiB / 139737 bytes"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user