From 2e5433676eaa5de93ed1ea9726706b9633308477 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 20 May 2024 17:14:04 +0400 Subject: [PATCH] xftp: check proxy before downloading from unknown server (#1102) * xftp: check proxy before downloading from unknown server * corrections * remove import * tests * comment * tests * don't wrap into internal error * fix tests --- simplexmq.cabal | 1 + src/Simplex/FileTransfer/Agent.hs | 35 ++++++----- src/Simplex/FileTransfer/Transport.hs | 4 ++ src/Simplex/Messaging/Agent.hs | 7 ++- src/Simplex/Messaging/Agent/Client.hs | 7 +++ src/Simplex/Messaging/Agent/Store/SQLite.hs | 61 ++++++++++--------- .../Agent/Store/SQLite/Migrations.hs | 4 +- .../M20240417_rcv_files_approved_relays.hs | 18 ++++++ .../Store/SQLite/Migrations/agent_schema.sql | 1 + src/Simplex/Messaging/Client.hs | 1 + tests/AgentTests/SQLiteTests.hs | 10 +-- tests/XFTPAgent.hs | 29 +++++---- 12 files changed, 110 insertions(+), 68 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240417_rcv_files_approved_relays.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index d077deaae..7d2759b46 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -105,6 +105,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client Simplex.Messaging.Client.Agent diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index a5ba40f4a..c8030b206 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -112,8 +112,8 @@ closeXFTPAgent a = do where stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker) -xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> AM RcvFileId -xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs = do +xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AM RcvFileId +xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs approvedRelays = do g <- asks random prefixPath <- lift $ getPrefixPath "rcv.xftp" createDirectory prefixPath @@ -124,7 +124,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi lift $ createEmptyFile =<< toFSFilePath relSavePath let saveFile = CryptoFile relSavePath cfArgs fId <- case redirect of - Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile + Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile approvedRelays Just _ -> do -- prepare description paths let relTmpPathRedirect = relPrefixPath "xftp.redirect-encrypted" @@ -134,7 +134,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi cfArgsRedirect <- atomically $ CF.randomArgs g let saveFileRedirect = CryptoFile relSavePathRedirect $ Just cfArgsRedirect -- create download tasks - withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile + withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile approvedRelays forM_ chunks (downloadChunk c) pure fId @@ -176,12 +176,12 @@ runXFTPRcvWorker c srv Worker {doWork} = do runXFTPOperation :: AgentConfig -> AM () runXFTPOperation AgentConfig {rcvFilesTTL, reconnectInterval = ri, xftpNotifyErrsOnRetry = notifyOnRetry, xftpConsecutiveRetries} = withWork c doWork (\db -> getNextRcvChunkToDownload db srv rcvFilesTTL) $ \case - RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas" - fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _} -> do + (RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []}, _) -> rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (INTERNAL "chunk has no replicas") + (fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, digest, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, server, delay} : _}, approvedRelays) -> do let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do liftIO $ waitForUserNetwork c - downloadFileChunk fc replica + downloadFileChunk fc replica approvedRelays `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e where retryLoop loop e replicaDelay = do @@ -191,9 +191,10 @@ runXFTPRcvWorker c srv Worker {doWork} = do withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay atomically $ assertAgentForeground c loop - retryDone e = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) (show e) - downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> AM () - downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica = do + retryDone = rcvWorkerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) + downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> Bool -> AM () + downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvFileEntityId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica approvedRelays = do + unlessM ((approvedRelays ||) <$> ipAddressProtected') $ throwError $ XFTP "" XFTP.NOT_APPROVED fsFileTmpPath <- lift $ toFSFilePath fileTmpPath chunkPath <- uniqueCombine fsFileTmpPath $ show chunkNo let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest) @@ -214,6 +215,10 @@ runXFTPRcvWorker c srv Worker {doWork} = do when complete . lift . void $ getXFTPRcvWorker True c Nothing where + ipAddressProtected' :: AM Bool + ipAddressProtected' = do + cfg <- liftIO $ getNetworkConfig' c + pure $ ipAddressProtected cfg srv receivedSize :: [RcvFileChunk] -> Int64 receivedSize = foldl' (\sz ch -> sz + receivedChunkSize ch) 0 receivedChunkSize ch@RcvFileChunk {chunkSize = s} @@ -234,11 +239,11 @@ retryOnError name loop done e = do then loop else done -rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> AM () -rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do +rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> AgentErrorType -> AM () +rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath err = do lift $ forM_ tmpPath (removePath <=< toFSFilePath) - withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr - notify c rcvFileEntityId $ RFERR $ INTERNAL internalErrStr + withStore' c $ \db -> updateRcvFileError db rcvFileId (show err) + notify c rcvFileEntityId $ RFERR err runXFTPRcvLocalWorker :: AgentClient -> Worker -> AM () runXFTPRcvLocalWorker c Worker {doWork} = do @@ -252,7 +257,7 @@ runXFTPRcvLocalWorker c Worker {doWork} = do runXFTPOperation AgentConfig {rcvFilesTTL} = withWork c doWork (`getNextRcvFileToDecrypt` rcvFilesTTL) $ \f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} -> - decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show) + decryptFile f `catchAgentError` rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath decryptFile :: RcvFile -> AM () decryptFile RcvFile {rcvFileId, rcvFileEntityId, size, digest, key, nonce, tmpPath, saveFile, status, chunks, redirect} = do let CryptoFile savePath cfArgs = saveFile diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 244e00972..2f0a5de4f 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -217,6 +217,8 @@ data XFTPErrorType TIMEOUT | -- | bad redirect data REDIRECT {redirectError :: String} + | -- | cannot proceed with download from not approved relays without proxy + NOT_APPROVED | -- | internal server error INTERNAL | -- | used internally, never returned by the server (to be removed) @@ -249,6 +251,7 @@ instance Encoding XFTPErrorType where FILE_IO -> "FILE_IO" TIMEOUT -> "TIMEOUT" REDIRECT err -> "REDIRECT " <> smpEncode err + NOT_APPROVED -> "NOT_APPROVED" INTERNAL -> "INTERNAL" DUPLICATE_ -> "DUPLICATE_" @@ -268,6 +271,7 @@ instance Encoding XFTPErrorType where "FILE_IO" -> pure FILE_IO "TIMEOUT" -> pure TIMEOUT "REDIRECT" -> REDIRECT <$> _smpP + "NOT_APPROVED" -> pure NOT_APPROVED "INTERNAL" -> pure INTERNAL "DUPLICATE_" -> pure DUPLICATE_ _ -> fail "bad error type" diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 3096291de..52d9b0086 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -83,6 +83,7 @@ module Simplex.Messaging.Agent setNtfServers, setNetworkConfig, getNetworkConfig, + getNetworkConfig', setUserNetworkInfo, reconnectAllServers, registerNtfToken, @@ -426,7 +427,7 @@ setNetworkConfig c@AgentClient {useNetworkConfig} cfg' = do -- returns fast network config getNetworkConfig :: AgentClient -> IO NetworkConfig -getNetworkConfig = fmap snd . readTVarIO . useNetworkConfig +getNetworkConfig = getNetworkConfig' {-# INLINE getNetworkConfig #-} setUserNetworkInfo :: AgentClient -> UserNetworkInfo -> IO () @@ -483,8 +484,8 @@ xftpStartWorkers c = withAgentEnv c . startXFTPWorkers c {-# INLINE xftpStartWorkers #-} -- | Receive XFTP file -xftpReceiveFile :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> AE RcvFileId -xftpReceiveFile c = withAgentEnv c .:. xftpReceiveFile' c +xftpReceiveFile :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AE RcvFileId +xftpReceiveFile c = withAgentEnv c .:: xftpReceiveFile' c {-# INLINE xftpReceiveFile #-} -- | Delete XFTP rcv file (deletes work files from file system and db records) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 64f8c172f..addd889a8 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -28,6 +28,7 @@ module Simplex.Messaging.Agent.Client withConnLocks, withInvLock, withLockMap, + ipAddressProtected, closeAgentClient, closeProtocolServerClients, reconnectServerClients, @@ -109,6 +110,7 @@ module Simplex.Messaging.Agent.Client waitUntilActive, UserNetworkInfo (..), UserNetworkType (..), + getNetworkConfig', waitForUserNetwork, isNetworkOnline, isOnline, @@ -854,6 +856,11 @@ getNetworkConfig c = do UNNone -> slowCfg _ -> fastCfg +-- returns fast network config +getNetworkConfig' :: AgentClient -> IO NetworkConfig +getNetworkConfig' = fmap snd . readTVarIO . useNetworkConfig +{-# INLINE getNetworkConfig' #-} + waitForUserNetwork :: AgentClient -> IO () waitForUserNetwork c = unlessM (atomically $ isNetworkOnline c) $ do diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index e47d2a15c..04dd826a6 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -2275,20 +2275,20 @@ getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do firstRow fromOnly SEXFTPServerNotFound $ DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash) -createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId) -createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file = runExceptT $ do - (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing +createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) +createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath file approvedRelays = runExceptT $ do + (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile db gVar userId fd prefixPath tmpPath file Nothing Nothing approvedRelays liftIO $ forM_ chunks $ \fc@FileChunk {replicas} -> do chunkId <- insertRcvFileChunk db fc rcvFileId forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertRcvFileChunkReplica db rno replica chunkId pure rcvFileEntityId -createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId) -createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect" -createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile = runExceptT $ do - (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing - (_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId) +createRcvFileRedirect :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription FRecipient -> FilePath -> FilePath -> CryptoFile -> FilePath -> CryptoFile -> Bool -> IO (Either StoreError RcvFileId) +createRcvFileRedirect _ _ _ FileDescription {redirect = Nothing} _ _ _ _ _ _ = pure $ Left $ SEInternal "createRcvFileRedirect called without redirect" +createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redirectChunks, redirect = Just RedirectFileInfo {size, digest}} prefixPath redirectPath redirectFile dstPath dstFile approvedRelays = runExceptT $ do + (dstEntityId, dstId) <- ExceptT $ insertRcvFile db gVar userId dummyDst prefixPath dstPath dstFile Nothing Nothing approvedRelays + (_, redirectId) <- ExceptT $ insertRcvFile db gVar userId redirectFd prefixPath redirectPath redirectFile (Just dstId) (Just dstEntityId) approvedRelays liftIO $ forM_ redirectChunks $ \fc@FileChunk {replicas} -> do chunkId <- insertRcvFileChunk db fc redirectId @@ -2308,8 +2308,8 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire chunks = [] } -insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> IO (Either StoreError (RcvFileId, DBRcvFileId)) -insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ = runExceptT $ do +insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> Bool -> IO (Either StoreError (RcvFileId, DBRcvFileId)) +insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ approvedRelays = runExceptT $ do let (redirectDigest_, redirectSize_) = case redirect of Just RedirectFileInfo {digest = d, size = s} -> (Just d, Just s) Nothing -> (Nothing, Nothing) @@ -2317,8 +2317,8 @@ insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSiz createWithRandomId gVar $ \rcvFileEntityId -> DB.execute db - "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" - ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_)) + "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size, approved_relays) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, redirectEntityId_, redirectDigest_, redirectSize_, approvedRelays)) rcvFileId <- liftIO $ insertedRowId db pure (rcvFileEntityId, rcvFileId) @@ -2468,7 +2468,7 @@ deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO () deleteRcvFile' db rcvFileId = DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId) -getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFileChunk)) +getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> NominalDiffTime -> IO (Either StoreError (Maybe (RcvFileChunk, Bool))) getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = do getWorkItem "rcv_file_download" getReplicaId getChunkData (markRcvFileFailed db . snd) where @@ -2492,7 +2492,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d LIMIT 1 |] (host, port, keyHash, RFSReceiving, cutoffTs) - getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError RcvFileChunk) + getChunkData :: (Int64, DBRcvFileId) -> IO (Either StoreError (RcvFileChunk, Bool)) getChunkData (rcvFileChunkReplicaId, _fileId) = firstRow toChunk SEFileNotFound $ DB.query @@ -2500,7 +2500,8 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d [sql| SELECT f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, - r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries + r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries, + f.approved_relays FROM rcv_file_chunk_replicas r JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id @@ -2509,20 +2510,22 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d |] (Only rcvFileChunkReplicaId) where - toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int)) -> RcvFileChunk - toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) = - RcvFileChunk - { rcvFileId, - rcvFileEntityId, - userId, - rcvChunkId, - chunkNo, - chunkSize, - digest, - fileTmpPath, - chunkTmpPath, - replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}] - } + toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int) :. Only Bool) -> (RcvFileChunk, Bool) + toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries) :. (Only approvedRelays)) = + ( RcvFileChunk + { rcvFileId, + rcvFileEntityId, + userId, + rcvChunkId, + chunkNo, + chunkSize, + digest, + fileTmpPath, + chunkTmpPath, + replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}] + }, + approvedRelays + ) getNextRcvFileToDecrypt :: DB.Connection -> NominalDiffTime -> IO (Either StoreError (Maybe RcvFile)) getNextRcvFileToDecrypt db ttl = diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index 344a3f9ce..5a5ed5b5b 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -71,6 +71,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240121_message_deliver import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240124_file_redirect import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240223_connections_wait_delivery import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240225_ratchet_kem +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON) import Simplex.Messaging.Transport.Client (TransportHost) @@ -110,7 +111,8 @@ schemaMigrations = ("m20240121_message_delivery_indexes", m20240121_message_delivery_indexes, Just down_m20240121_message_delivery_indexes), ("m20240124_file_redirect", m20240124_file_redirect, Just down_m20240124_file_redirect), ("m20240223_connections_wait_delivery", m20240223_connections_wait_delivery, Just down_m20240223_connections_wait_delivery), - ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem) + ("m20240225_ratchet_kem", m20240225_ratchet_kem, Just down_m20240225_ratchet_kem), + ("m20240417_rcv_files_approved_relays", m20240417_rcv_files_approved_relays, Just down_m20240417_rcv_files_approved_relays) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240417_rcv_files_approved_relays.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240417_rcv_files_approved_relays.hs new file mode 100644 index 000000000..9eb10c27a --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20240417_rcv_files_approved_relays.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20240417_rcv_files_approved_relays where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20240417_rcv_files_approved_relays :: Query +m20240417_rcv_files_approved_relays = + [sql| +ALTER TABLE rcv_files ADD COLUMN approved_relays INTEGER NOT NULL DEFAULT 0; +|] + +down_m20240417_rcv_files_approved_relays :: Query +down_m20240417_rcv_files_approved_relays = + [sql| +ALTER TABLE rcv_files DROP COLUMN approved_relays; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 0818be904..caf94418a 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -287,6 +287,7 @@ CREATE TABLE rcv_files( redirect_entity_id BLOB, redirect_size INTEGER, redirect_digest BLOB, + approved_relays INTEGER NOT NULL DEFAULT 0, UNIQUE(rcv_file_entity_id) ); CREATE TABLE rcv_file_chunks( diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 2e05812cb..34aa42462 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -84,6 +84,7 @@ module Simplex.Messaging.Client ServerTransmissionBatch, ServerTransmission (..), ClientCommand, + HostMode (..), -- * For testing PCTransmission, diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 436dd0eca..63466b9d7 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -709,15 +709,15 @@ testGetNextRcvChunkToDownload st = do withTransaction st $ \db -> do Right Nothing <- getNextRcvChunkToDownload db xftpServer1 86400 - Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) + Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1" - Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) + Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True Left e <- getNextRcvChunkToDownload db xftpServer1 86400 show e `shouldContain` "ConversionFailed" DB.query_ db "SELECT rcv_file_id FROM rcv_files WHERE failed = 1" `shouldReturn` [Only (1 :: Int)] - Right (Just RcvFileChunk {rcvFileEntityId}) <- getNextRcvChunkToDownload db xftpServer1 86400 + Right (Just (RcvFileChunk {rcvFileEntityId}, _)) <- getNextRcvChunkToDownload db xftpServer1 86400 rcvFileEntityId `shouldBe` fId2 testGetNextRcvFileToDecrypt :: SQLiteStore -> Expectation @@ -726,10 +726,10 @@ testGetNextRcvFileToDecrypt st = do withTransaction st $ \db -> do Right Nothing <- getNextRcvFileToDecrypt db 86400 - Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) + Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 1" DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1" - Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) + Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True DB.execute_ db "UPDATE rcv_files SET status = 'received' WHERE rcv_file_id = 2" Left e <- getNextRcvFileToDecrypt db 86400 diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 0610bf48d..8f42ec16a 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -179,7 +179,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> do FileDescriptionURI {description} <- either fail pure $ strDecode uri - rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing + rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 65536 totalSize) -- extra RFPROG before switching to real file rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 8388608 totalSize) @@ -223,7 +223,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do FileDescriptionURI {description} <- either fail pure $ strDecode uri let ValidFileDescription FileDescription {redirect} = description redirect `shouldBe` Nothing - rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing + rcvFileId <- runRight $ xftpReceiveFile rcp 1 description Nothing True -- NO extra "RFPROG 65k 65k" before switching to real file rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 4194304 totalSize) rfGet rcp `shouldReturn` ("", rcvFileId, RFPROG 5242880 totalSize) @@ -311,7 +311,7 @@ testReceive' rcp rfd originalFilePath = testReceiveCF' rcp rfd Nothing originalF testReceiveCF' :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> Int64 -> ExceptT AgentErrorType IO RcvFileId testReceiveCF' rcp rfd cfArgs originalFilePath size = do - rfId <- xftpReceiveFile rcp 1 rfd cfArgs + rfId <- xftpReceiveFile rcp 1 rfd cfArgs True rfProgress rcp size ("", rfId', RFDONE path) <- rfGet rcp liftIO $ do @@ -336,7 +336,7 @@ testXFTPAgentReceiveRestore = do -- receive file - should not succeed with server down rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do xftpStartWorkers rcp (Just recipientFiles) - rfId <- xftpReceiveFile rcp 1 rfd Nothing + rfId <- xftpReceiveFile rcp 1 rfd Nothing True liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId @@ -380,7 +380,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do -- receive file - should not succeed with server down rfId <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do xftpStartWorkers rcp (Just recipientFiles) - rfId <- xftpReceiveFile rcp 1 rfd Nothing + rfId <- xftpReceiveFile rcp 1 rfd Nothing True liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt pure rfId @@ -392,8 +392,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do -- receive file - should fail with AUTH error withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - ("", rfId', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <- - rfGet rcp' + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- rfGet rcp' rfId' `shouldBe` rfId -- tmp path should be removed after permanent error @@ -507,8 +506,8 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $ -- receive file - should fail with AUTH error withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <- + rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId @@ -545,8 +544,8 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do -- receive file - should fail with AUTH error withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) - rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <- + rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId @@ -580,8 +579,8 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs $ runRight_ . void $ do -- receive file 1 again - rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing - ("", rfId1', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <- + rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True + ("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- rfGet rcp liftIO $ rfId1 `shouldBe` rfId1' @@ -613,8 +612,8 @@ testXFTPAgentExpiredOnServer = withGlobalLogging logCfgNoLogs $ do -- receive file 1 again - should fail with AUTH error runRight $ do - rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing - ("", rfId', RFERR (INTERNAL "XFTP {serverAddress = \"xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000\", xftpErr = AUTH}")) <- + rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True + ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" AUTH)) <- rfGet rcp liftIO $ rfId' `shouldBe` rfId