mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-07-17 18:41:56 +00:00
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
This commit is contained in:
spaced4ndy
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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"
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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
|
||||
|
||||
+18
@@ -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;
|
||||
|]
|
||||
@@ -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(
|
||||
|
||||
@@ -84,6 +84,7 @@ module Simplex.Messaging.Client
|
||||
ServerTransmissionBatch,
|
||||
ServerTransmission (..),
|
||||
ClientCommand,
|
||||
HostMode (..),
|
||||
|
||||
-- * For testing
|
||||
PCTransmission,
|
||||
|
||||
@@ -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
|
||||
|
||||
+14
-15
@@ -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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user