agent: support encrypted local files (#837)

* agent: support encrypted local files

* migration, update store, api

* tests, fix

* use CF.plain
This commit is contained in:
Evgeny Poberezkin
2023-08-31 22:43:58 +01:00
committed by GitHub
parent 4c0b8a31d2
commit 5dc3d739b2
16 changed files with 402 additions and 99 deletions

View File

@@ -89,11 +89,13 @@ library
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
Simplex.Messaging.Agent.TAsyncs
Simplex.Messaging.Agent.TRcvQueues
Simplex.Messaging.Client
Simplex.Messaging.Client.Agent
Simplex.Messaging.Crypto
Simplex.Messaging.Crypto.File
Simplex.Messaging.Crypto.Lazy
Simplex.Messaging.Crypto.Ratchet
Simplex.Messaging.Encoding
@@ -536,6 +538,7 @@ test-suite simplexmq-test
AgentTests.SQLiteTests
CLITests
CoreTests.BatchingTests
CoreTests.CryptoFileTests
CoreTests.CryptoTests
CoreTests.EncodingTests
CoreTests.ProtocolErrorTests

View File

@@ -53,6 +53,8 @@ import Simplex.Messaging.Agent.Protocol
import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store.SQLite
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
import qualified Simplex.Messaging.Crypto.File as CF
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding
import Simplex.Messaging.Protocol (EntityId, XFTPServer)
@@ -99,8 +101,8 @@ closeXFTPAgent XFTPAgent {xftpRcvWorkers, xftpSndWorkers} = do
ws <- atomically $ stateTVar wsSel (,M.empty)
mapM_ (uninterruptibleCancel . snd) ws
xftpReceiveFile' :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> m RcvFileId
xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) = do
xftpReceiveFile' :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> m RcvFileId
xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) cfArgs = do
g <- asks idsDrg
prefixPath <- getPrefixPath "rcv.xftp"
createDirectory prefixPath
@@ -109,7 +111,8 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks}) = d
relSavePath = relPrefixPath </> "xftp.decrypted"
createDirectory =<< toFSFilePath relTmpPath
createEmptyFile =<< toFSFilePath relSavePath
fId <- withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath relSavePath
let saveFile = CryptoFile relSavePath cfArgs
fId <- withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile
forM_ chunks downloadChunk
pure fId
where
@@ -243,14 +246,16 @@ runXFTPRcvLocalWorker c doWork = do
decryptFile f `catchAgentError` (rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath . show)
noWorkToDo = void . atomically $ tryTakeTMVar doWork
decryptFile :: RcvFile -> m ()
decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, status, chunks} = do
decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, saveFile, status, chunks} = do
let CryptoFile savePath cfArgs = saveFile
fsSavePath <- toFSFilePath savePath
when (status == RFSDecrypting) $
whenM (doesFileExist fsSavePath) (removeFile fsSavePath >> createEmptyFile fsSavePath)
withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting
chunkPaths <- getChunkPaths chunks
encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure fsSavePath
let destFile = CryptoFile fsSavePath cfArgs
void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure destFile
notify c rcvFileEntityId $ RFDONE fsSavePath
forM_ tmpPath (removePath <=< toFSFilePath)
atomically $ waitUntilForeground c
@@ -277,8 +282,8 @@ xftpDeleteRcvFile' c rcvFileEntityId = do
notify :: forall m e. (MonadUnliftIO m, AEntityI e) => AgentClient -> EntityId -> ACommand 'Agent e -> m ()
notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, APC (sAEntity @e) cmd)
xftpSendFile' :: AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> m SndFileId
xftpSendFile' c userId filePath numRecipients = do
xftpSendFile' :: AgentMonad m => AgentClient -> UserId -> CryptoFile -> Int -> m SndFileId
xftpSendFile' c userId file numRecipients = do
g <- asks idsDrg
prefixPath <- getPrefixPath "snd.xftp"
createDirectory prefixPath
@@ -286,7 +291,7 @@ xftpSendFile' c userId filePath numRecipients = do
key <- liftIO C.randomSbKey
nonce <- liftIO C.randomCbNonce
-- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
fId <- withStore c $ \db -> createSndFile db g userId numRecipients filePath relPrefixPath key nonce
fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce
addXFTPSndWorker c Nothing
pure fId
@@ -332,16 +337,17 @@ runXFTPSndPrepareWorker c doWork = do
withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
where
encryptFileForUpload :: SndFile -> FilePath -> m (FileDigest, [(XFTPChunkSpec, FileDigest)])
encryptFileForUpload SndFile {key, nonce, filePath} fsEncPath = do
let fileName = takeFileName filePath
fileSize <- fromInteger <$> getFileSize filePath
encryptFileForUpload SndFile {key, nonce, srcFile} fsEncPath = do
let CryptoFile {filePath} = srcFile
fileName = takeFileName filePath
fileSize <- liftIO $ fromInteger <$> CF.getFileContentsSize srcFile
when (fileSize > maxFileSize) $ throwError $ INTERNAL "max file size exceeded"
let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}
fileSize' = fromIntegral (B.length fileHdr) + fileSize
chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize
chunkSizes' = map fromIntegral chunkSizes
encSize = sum chunkSizes'
void $ liftError (INTERNAL . show) $ encryptFile filePath fileHdr key nonce fileSize' encSize fsEncPath
void $ liftError (INTERNAL . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize fsEncPath
digest <- liftIO $ LC.sha512Hash <$> LB.readFile fsEncPath
let chunkSpecs = prepareChunkSpecs fsEncPath chunkSizes
chunkDigests <- map FileDigest <$> mapM (liftIO . getChunkDigest) chunkSpecs

View File

@@ -59,6 +59,8 @@ import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
import Simplex.FileTransfer.Types
import Simplex.FileTransfer.Util (uniqueCombine)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..))
import qualified Simplex.Messaging.Crypto.File as CF
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String (StrEncoding (..))
@@ -102,6 +104,7 @@ cliCryptoError = \case
FTCECryptoError e -> CLIError $ "Error decrypting file: " <> show e
FTCEInvalidHeader e -> CLIError $ "Invalid file header: " <> e
FTCEInvalidAuthTag -> CLIError "Error decrypting file: incorrect auth tag"
FTCEInvalidFileSize -> CLIError "Error decrypting file: incorrect file size"
FTCEFileIOError e -> CLIError $ "File IO error: " <> show e
data CliCommand
@@ -301,7 +304,8 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
defChunkSize = head chunkSizes
chunkSizes' = map fromIntegral chunkSizes
encSize = sum chunkSizes'
withExceptT (CLIError . show) $ encryptFile filePath fileHdr key nonce fileSize' encSize encPath
srcFile = CF.plain filePath
withExceptT (CLIError . show) $ encryptFile srcFile fileHdr key nonce fileSize' encSize encPath
digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
let chunkSpecs = prepareChunkSpecs encPath chunkSizes
fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []}
@@ -434,7 +438,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths
when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch"
liftIO $ printNoNewLine "Decrypting file..."
path <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce getFilePath
CryptoFile path _ <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce $ fmap CF.plain . getFilePath
forM_ chunks $ acknowledgeFileChunk a
whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
liftIO $ do

View File

@@ -16,6 +16,8 @@ import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64)
import Simplex.FileTransfer.Types (FileHeader (..), authTagSize)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..))
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding
@@ -23,20 +25,21 @@ import Simplex.Messaging.Util (liftEitherWith)
import UnliftIO
import UnliftIO.Directory (removeFile)
encryptFile :: FilePath -> ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT FTCryptoError IO ()
encryptFile filePath fileHdr key nonce fileSize' encSize encFile = do
encryptFile :: CryptoFile -> ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT FTCryptoError IO ()
encryptFile srcFile fileHdr key nonce fileSize' encSize encFile = do
sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
withFile filePath ReadMode $ \r -> withFile encFile WriteMode $ \w -> do
CF.withFile srcFile ReadMode $ \r -> withFile encFile WriteMode $ \w -> do
let lenStr = smpEncode fileSize'
(hdr, !sb') = LC.sbEncryptChunk sb $ lenStr <> fileHdr
padLen = encSize - authTagSize - fileSize' - 8
liftIO $ B.hPut w hdr
sb2 <- encryptChunks r w (sb', fileSize' - fromIntegral (B.length fileHdr))
CF.hGetTag r
sb3 <- encryptPad w (sb2, padLen)
let tag = BA.convert $ LC.sbAuth sb3
liftIO $ B.hPut w tag
where
encryptChunks r = encryptChunks_ $ liftIO . B.hGet r . fromIntegral
encryptChunks r = encryptChunks_ $ liftIO . CF.hGet r . fromIntegral
encryptPad = encryptChunks_ $ \sz -> pure $ B.replicate (fromIntegral sz) '#'
encryptChunks_ :: (Int64 -> IO ByteString) -> Handle -> (LC.SbState, Int64) -> ExceptT FTCryptoError IO LC.SbState
encryptChunks_ get w (!sb, !len)
@@ -49,28 +52,28 @@ encryptFile filePath fileHdr key nonce fileSize' encSize encFile = do
liftIO $ B.hPut w ch'
encryptChunks_ get w (sb', len - chSize)
decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO String) -> ExceptT FTCryptoError IO FilePath
decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO CryptoFile) -> ExceptT FTCryptoError IO CryptoFile
decryptChunks _ [] _ _ _ = throwError $ FTCEInvalidHeader "empty"
decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse chPaths of
decryptChunks encSize (chPath : chPaths) key nonce getDestFile = case reverse chPaths of
[] -> do
(!authOk, !f) <- liftEither . first FTCECryptoError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (LB.readFile chPath)
unless authOk $ throwError FTCEInvalidAuthTag
(FileHeader {fileName}, !f') <- parseFileHeader f
path <- withExceptT FTCEFileIOError $ getFilePath fileName
liftIO $ LB.writeFile path f'
pure path
destFile <- withExceptT FTCEFileIOError $ getDestFile fileName
CF.writeFile destFile f'
pure destFile
lastPath : chPaths' -> do
(state, expectedLen, ch) <- decryptFirstChunk
(FileHeader {fileName}, ch') <- parseFileHeader ch
path <- withExceptT FTCEFileIOError $ getFilePath fileName
authOk <- liftIO . withFile path WriteMode $ \h -> do
liftIO $ LB.hPut h ch'
destFile@(CryptoFile path _) <- withExceptT FTCEFileIOError $ getDestFile fileName
authOk <- CF.withFile destFile WriteMode $ \h -> liftIO $ do
CF.hPut h ch'
state' <- foldM (decryptChunk h) state $ reverse chPaths'
decryptLastChunk h state' expectedLen
unless authOk $ do
removeFile path
throwError FTCEInvalidAuthTag
pure path
pure destFile
where
decryptFirstChunk = do
sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
@@ -83,7 +86,7 @@ decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse ch
ch <- LB.readFile chPth
let len' = len + LB.length ch
(ch', sb') = LC.sbDecryptChunkLazy sb ch
LB.hPut h ch'
CF.hPut h ch'
pure (sb', len')
decryptLastChunk h (!sb, !len) expectedLen = do
ch <- LB.readFile lastPath
@@ -93,7 +96,8 @@ decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse ch
len' = len + LB.length ch2
ch3 = LB.take (LB.length ch2 - len' + expectedLen) ch2
tag :: ByteString = BA.convert (LC.sbAuth sb')
LB.hPut h ch3
CF.hPut h ch3
CF.hPutTag h
pure $ B.length tag'' == 16 && BA.constEq tag'' tag
where
parseFileHeader :: LazyByteString -> ExceptT FTCryptoError IO (FileHeader, LazyByteString)
@@ -106,10 +110,3 @@ decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse ch
readChunks :: [FilePath] -> IO LB.ByteString
readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) ""
data FTCryptoError
= FTCECryptoError C.CryptoError
| FTCEInvalidHeader String
| FTCEInvalidAuthTag
| FTCEFileIOError String
deriving (Show, Eq, Exception)

View File

@@ -13,6 +13,7 @@ import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
import Simplex.FileTransfer.Description
import Simplex.Messaging.Agent.Protocol (RcvFileId, SndFileId)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (fromTextField_)
@@ -49,7 +50,7 @@ data RcvFile = RcvFile
chunks :: [RcvFileChunk],
prefixPath :: FilePath,
tmpPath :: Maybe FilePath,
savePath :: FilePath,
saveFile :: CryptoFile,
status :: RcvFileStatus,
deleted :: Bool
}
@@ -120,7 +121,7 @@ data SndFile = SndFile
key :: C.SbKey,
nonce :: C.CbNonce,
chunks :: [SndFileChunk],
filePath :: FilePath,
srcFile :: CryptoFile,
prefixPath :: Maybe FilePath,
status :: SndFileStatus,
deleted :: Bool

View File

@@ -119,12 +119,12 @@ import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust, isNothing, catMaybes)
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Clock.System (systemToUTCTime)
import Simplex.FileTransfer.Agent (closeXFTPAgent, xftpDeleteRcvFile', deleteSndFileInternal, deleteSndFileRemote, xftpReceiveFile', xftpSendFile', startXFTPWorkers, toFSFilePath)
import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpReceiveFile', xftpSendFile')
import Simplex.FileTransfer.Description (ValidFileDescription)
import Simplex.FileTransfer.Protocol (FileParty (..))
import Simplex.FileTransfer.Util (removePath)
@@ -140,6 +140,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client (ProtocolClient (..), ServerTransmission)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -356,15 +357,15 @@ xftpStartWorkers :: AgentErrorMonad m => AgentClient -> Maybe FilePath -> m ()
xftpStartWorkers c = withAgentEnv c . startXFTPWorkers c
-- | Receive XFTP file
xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> m RcvFileId
xftpReceiveFile c = withAgentEnv c .: xftpReceiveFile' c
xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> m RcvFileId
xftpReceiveFile c = withAgentEnv c .:. xftpReceiveFile' c
-- | Delete XFTP rcv file (deletes work files from file system and db records)
xftpDeleteRcvFile :: AgentErrorMonad m => AgentClient -> RcvFileId -> m ()
xftpDeleteRcvFile c = withAgentEnv c . xftpDeleteRcvFile' c
-- | Send XFTP file
xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> FilePath -> Int -> m SndFileId
xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> CryptoFile -> Int -> m SndFileId
xftpSendFile c = withAgentEnv c .:. xftpSendFile' c
-- | Delete XFTP snd file internally (deletes work files from file system and db records)
@@ -2339,8 +2340,8 @@ mkAgentConfirmation :: AgentMonad m => Compatible Version -> AgentClient -> Conn
mkAgentConfirmation (Compatible agentVersion) c cData sq srv connInfo
| agentVersion == 1 = pure $ AgentConnInfo connInfo
| otherwise = do
qInfo <- createReplyQueue c cData sq srv
pure $ AgentConnInfoReply (qInfo :| []) connInfo
qInfo <- createReplyQueue c cData sq srv
pure $ AgentConnInfoReply (qInfo :| []) connInfo
enqueueConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
enqueueConfirmation c cData sq connInfo e2eEncryption_ = do

View File

@@ -255,6 +255,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Agent.Store.SQLite.Migrations (DownMigration (..), MTRError, Migration (..), MigrationsToRun (..), mtrErrorDescription)
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Crypto.Ratchet (RatchetX448, SkippedMsgDiff (..), SkippedMsgKeys)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
@@ -2080,8 +2081,8 @@ 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 -> FilePath -> IO (Either StoreError RcvFileId)
createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath savePath = runExceptT $ do
createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> IO (Either StoreError RcvFileId)
createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath (CryptoFile savePath cfArgs) = runExceptT $ do
(rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile fd
liftIO $
forM_ chunks $ \fc@FileChunk {replicas} -> do
@@ -2095,8 +2096,8 @@ createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath save
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, status) VALUES (?,?,?,?,?,?,?,?,?,?,?)"
((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize) :. (prefixPath, tmpPath, savePath, RFSReceiving))
"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) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize) :. (prefixPath, tmpPath, savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving))
rcvFileId <- liftIO $ insertedRowId db
pure (rcvFileEntityId, rcvFileId)
insertChunk :: FileChunk -> DBRcvFileId -> IO Int64
@@ -2136,15 +2137,17 @@ getRcvFile db rcvFileId = runExceptT $ do
DB.query
db
[sql|
SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, status, deleted
SELECT 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, deleted
FROM rcv_files
WHERE rcv_file_id = ?
|]
(Only rcvFileId)
where
toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath, FilePath, RcvFileStatus, Bool) -> RcvFile
toFile (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath, savePath, status, deleted) =
RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath, savePath, status, deleted, chunks = []}
toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath) :. (FilePath, Maybe C.SbKey, Maybe C.CbNonce, RcvFileStatus, Bool) -> RcvFile
toFile ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, saveKey_, saveNonce_, status, deleted)) =
let cfArgs = CFArgs <$> saveKey_ <*> saveNonce_
saveFile = CryptoFile savePath cfArgs
in RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath, saveFile, status, deleted, chunks = []}
getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk]
getChunks rcvFileEntityId userId fileTmpPath = do
chunks <-
@@ -2333,13 +2336,13 @@ getRcvFilesExpired db ttl = do
|]
(Only cutoffTs)
createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> Int -> FilePath -> FilePath -> C.SbKey -> C.CbNonce -> IO (Either StoreError SndFileId)
createSndFile db gVar userId numRecipients path prefixPath key nonce =
createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> IO (Either StoreError SndFileId)
createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce =
createWithRandomId gVar $ \sndFileEntityId ->
DB.execute
db
"INSERT INTO snd_files (snd_file_entity_id, user_id, num_recipients, key, nonce, path, prefix_path, status) VALUES (?,?,?,?,?,?,?,?)"
(sndFileEntityId, userId, numRecipients, key, nonce, path, prefixPath, SFSNew)
"INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status) VALUES (?,?,?,?,?,?,?,?,?,?)"
(sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients, prefixPath, key, nonce, SFSNew)
getSndFileByEntityId :: DB.Connection -> SndFileId -> IO (Either StoreError SndFile)
getSndFileByEntityId db sndFileEntityId = runExceptT $ do
@@ -2363,15 +2366,17 @@ getSndFile db sndFileId = runExceptT $ do
DB.query
db
[sql|
SELECT snd_file_entity_id, user_id, num_recipients, digest, key, nonce, path, prefix_path, status, deleted
SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted
FROM snd_files
WHERE snd_file_id = ?
|]
(Only sndFileId)
where
toFile :: (SndFileId, UserId, Int, Maybe FileDigest, C.SbKey, C.CbNonce, FilePath, Maybe FilePath, SndFileStatus, Bool) -> SndFile
toFile (sndFileEntityId, userId, numRecipients, digest, key, nonce, filePath, prefixPath, status, deleted) =
SndFile {sndFileId, sndFileEntityId, userId, numRecipients, digest, key, nonce, filePath, prefixPath, status, deleted, chunks = []}
toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce, SndFileStatus, Bool) -> SndFile
toFile (sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce, status, deleted) =
let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_
srcFile = CryptoFile srcPath cfArgs
in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, chunks = []}
getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk]
getChunks sndFileEntityId userId numRecipients filePrefixPath = do
chunks <-

View File

@@ -67,6 +67,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receip
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Transport.Client (TransportHost)
@@ -99,7 +100,8 @@ schemaMigrations =
("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts),
("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages),
("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes),
("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes)
("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files)
]
-- | The list of migrations in ascending order by date

View File

@@ -0,0 +1,24 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20230829_crypto_files :: Query
m20230829_crypto_files =
[sql|
ALTER TABLE rcv_files ADD COLUMN save_file_key BLOB;
ALTER TABLE rcv_files ADD COLUMN save_file_nonce BLOB;
ALTER TABLE snd_files ADD COLUMN src_file_key BLOB;
ALTER TABLE snd_files ADD COLUMN src_file_nonce BLOB;
|]
down_m20230829_crypto_files :: Query
down_m20230829_crypto_files =
[sql|
ALTER TABLE rcv_files DROP COLUMN save_file_key;
ALTER TABLE rcv_files DROP COLUMN save_file_nonce;
ALTER TABLE snd_files DROP COLUMN src_file_key;
ALTER TABLE snd_files DROP COLUMN src_file_nonce;
|]

View File

@@ -271,6 +271,8 @@ CREATE TABLE rcv_files(
error TEXT,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
save_file_key BLOB,
save_file_nonce BLOB,
UNIQUE(rcv_file_entity_id)
);
CREATE TABLE rcv_file_chunks(
@@ -311,6 +313,9 @@ CREATE TABLE snd_files(
error TEXT,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
,
src_file_key BLOB,
src_file_nonce BLOB
);
CREATE TABLE snd_file_chunks(
snd_file_chunk_id INTEGER PRIMARY KEY,

View File

@@ -0,0 +1,125 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Messaging.Crypto.File
( CryptoFile (..),
CryptoFileArgs (..),
CryptoFileHandle (..),
FTCryptoError (..),
Simplex.Messaging.Crypto.File.readFile,
Simplex.Messaging.Crypto.File.writeFile,
withFile,
hPut,
hPutTag,
hGet,
hGetTag,
plain,
randomArgs,
getFileContentsSize,
)
where
import Control.Exception
import Control.Monad.Except
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J
import qualified Data.ByteArray as BA
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (isJust)
import GHC.Generics (Generic)
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Util (liftEitherWith)
import System.Directory (getFileSize)
import UnliftIO (Handle, IOMode (..))
import qualified UnliftIO as IO
import UnliftIO.STM
-- Possibly encrypted local file
data CryptoFile = CryptoFile {filePath :: FilePath, cryptoArgs :: Maybe CryptoFileArgs}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON CryptoFile where
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
data CryptoFileArgs = CFArgs {fileKey :: C.SbKey, fileNonce :: C.CbNonce}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON CryptoFileArgs where toEncoding = J.genericToEncoding J.defaultOptions
data CryptoFileHandle = CFHandle Handle (Maybe (TVar LC.SbState))
readFile :: CryptoFile -> ExceptT FTCryptoError IO LazyByteString
readFile (CryptoFile path cfArgs) = do
s <- liftIO $ LB.readFile path
case cfArgs of
Just (CFArgs (C.SbKey key) (C.CbNonce nonce)) -> do
let len = LB.length s - fromIntegral C.authTagSize
when (len < 0) $ throwError FTCEInvalidFileSize
let (s', tag') = LB.splitAt len s
(tag :| cs) <- liftEitherWith FTCECryptoError $ LC.secretBox LC.sbDecryptChunk key nonce s'
unless (BA.constEq (LB.toStrict tag') tag) $ throwError FTCEInvalidAuthTag
pure $ LB.fromChunks cs
Nothing -> pure s
writeFile :: CryptoFile -> LazyByteString -> ExceptT FTCryptoError IO ()
writeFile (CryptoFile path cfArgs) s = do
s' <- case cfArgs of
Just (CFArgs (C.SbKey key) (C.CbNonce nonce)) ->
liftEitherWith FTCECryptoError $ LB.fromChunks <$> LC.secretBoxTailTag LC.sbEncryptChunk key nonce s
Nothing -> pure s
liftIO $ LB.writeFile path s'
withFile :: CryptoFile -> IOMode -> (CryptoFileHandle -> ExceptT FTCryptoError IO a) -> ExceptT FTCryptoError IO a
withFile (CryptoFile path cfArgs) mode action = do
sb <- forM cfArgs $ \(CFArgs key nonce) ->
liftEitherWith FTCECryptoError (LC.sbInit key nonce) >>= newTVarIO
IO.withFile path mode $ \h -> action $ CFHandle h sb
hPut :: CryptoFileHandle -> LazyByteString -> IO ()
hPut (CFHandle h sb_) s = LB.hPut h =<< maybe (pure s) encrypt sb_
where
encrypt sb = atomically $ stateTVar sb (`LC.sbEncryptChunkLazy` s)
hPutTag :: CryptoFileHandle -> IO ()
hPutTag (CFHandle h sb_) = forM_ sb_ $ B.hPut h . BA.convert . LC.sbAuth <=< readTVarIO
hGet :: CryptoFileHandle -> Int -> IO ByteString
hGet (CFHandle h sb_) n = B.hGet h n >>= maybe pure decrypt sb_
where
decrypt sb s = atomically $ stateTVar sb (`LC.sbDecryptChunk` s)
-- | Read and validate the auth tag.
-- This function should be called after reading the whole file, it assumes you know the file size and read only the needed bytes.
hGetTag :: CryptoFileHandle -> ExceptT FTCryptoError IO ()
hGetTag (CFHandle h sb_) = forM_ sb_ $ \sb -> do
tag <- liftIO $ B.hGet h C.authTagSize
tag' <- LC.sbAuth <$> readTVarIO sb
unless (BA.constEq tag tag') $ throwError FTCEInvalidAuthTag
data FTCryptoError
= FTCECryptoError C.CryptoError
| FTCEInvalidHeader String
| FTCEInvalidFileSize
| FTCEInvalidAuthTag
| FTCEFileIOError String
deriving (Show, Eq, Exception)
plain :: FilePath -> CryptoFile
plain = (`CryptoFile` Nothing)
randomArgs :: IO CryptoFileArgs
randomArgs = CFArgs <$> C.randomSbKey <*> C.randomCbNonce
getFileContentsSize :: CryptoFile -> IO Integer
getFileContentsSize (CryptoFile path cfArgs) = do
size <- getFileSize path
pure $ if isJust cfArgs then size - fromIntegral C.authTagSize else size

View File

@@ -17,6 +17,8 @@ module Simplex.Messaging.Crypto.Lazy
sbEncryptTailTag,
sbDecryptTailTag,
fastReplicate,
secretBox,
secretBoxTailTag,
SbState,
cbInit,
sbInit,

View File

@@ -0,0 +1,97 @@
{-# LANGUAGE OverloadedStrings #-}
module CoreTests.CryptoFileTests (cryptoFileTests) where
import AgentTests.FunctionalAPITests (runRight_)
import Control.Monad.Except
import Crypto.Random (getRandomBytes)
import qualified Data.ByteString.Lazy as LB
import GHC.IO.IOMode (IOMode (..))
import qualified Simplex.FileTransfer.Types as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..))
import qualified Simplex.Messaging.Crypto.File as CF
import System.Directory (getFileSize)
import Test.Hspec
cryptoFileTests :: Spec
cryptoFileTests = do
it "should write/read file" testWriteReadFile
it "should put/get file" testPutGetFile
it "should write/get file" testWriteGetFile
it "should put/read file" testPutReadFile
it "should fail reading empty or small file" testSmallFile
testFilePath :: FilePath
testFilePath = "tests/tmp/testcryptofile"
testWriteReadFile :: IO ()
testWriteReadFile = do
s <- LB.fromStrict <$> getRandomBytes 100000
file <- mkCryptoFile
runRight_ $ do
CF.writeFile file s
liftIO $ CF.getFileContentsSize file `shouldReturn` 100000
liftIO $ getFileSize testFilePath `shouldReturn` 100000 + fromIntegral C.authTagSize
s' <- CF.readFile file
liftIO $ s `shouldBe` s'
testPutGetFile :: IO ()
testPutGetFile = do
s <- LB.fromStrict <$> getRandomBytes 50000
s' <- LB.fromStrict <$> getRandomBytes 50000
file <- mkCryptoFile
runRight_ $ do
CF.withFile file WriteMode $ \h -> liftIO $ do
CF.hPut h s
CF.hPut h s'
CF.hPutTag h
liftIO $ CF.getFileContentsSize file `shouldReturn` 100000
liftIO $ getFileSize testFilePath `shouldReturn` 100000 + fromIntegral C.authTagSize
CF.withFile file ReadMode $ \h -> do
s1 <- liftIO $ CF.hGet h 30000
s2 <- liftIO $ CF.hGet h 40000
s3 <- liftIO $ CF.hGet h 30000
CF.hGetTag h
liftIO $ (s <> s') `shouldBe` LB.fromStrict (s1 <> s2 <> s3)
testWriteGetFile :: IO ()
testWriteGetFile = do
s <- LB.fromStrict <$> getRandomBytes 100000
file <- mkCryptoFile
runRight_ $ do
CF.writeFile file s
CF.withFile file ReadMode $ \h -> do
s' <- liftIO $ CF.hGet h 50000
s'' <- liftIO $ CF.hGet h 50000
CF.hGetTag h
liftIO $ runExceptT (CF.hGetTag h) `shouldReturn` Left FTCEInvalidAuthTag
liftIO $ s `shouldBe` LB.fromStrict (s' <> s'')
testPutReadFile :: IO ()
testPutReadFile = do
s <- LB.fromStrict <$> getRandomBytes 50000
s' <- LB.fromStrict <$> getRandomBytes 50000
file <- mkCryptoFile
runRight_ $ do
CF.withFile file WriteMode $ \h -> liftIO $ do
CF.hPut h s
CF.hPut h s'
runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidAuthTag
runRight_ $ do
CF.withFile file WriteMode $ \h -> liftIO $ do
CF.hPut h s
CF.hPut h s'
CF.hPutTag h
s'' <- CF.readFile file
liftIO $ (s <> s') `shouldBe` s''
testSmallFile :: IO ()
testSmallFile = do
file <- mkCryptoFile
LB.writeFile testFilePath ""
runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize
LB.writeFile testFilePath "123"
runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize
mkCryptoFile :: IO CryptoFile
mkCryptoFile = CryptoFile testFilePath . Just <$> CF.randomArgs

View File

@@ -5,6 +5,7 @@ import AgentTests.SchemaDump (schemaDumpTest)
import CLITests
import Control.Logger.Simple
import CoreTests.BatchingTests
import CoreTests.CryptoFileTests
import CoreTests.CryptoTests
import CoreTests.EncodingTests
import CoreTests.ProtocolErrorTests
@@ -43,6 +44,7 @@ main = do
describe "Protocol error tests" protocolErrorTests
describe "Version range" versionRangeTests
describe "Encryption tests" cryptoTests
describe "Encrypted files tests" cryptoFileTests
describe "Retry interval tests" retryIntervalTests
describe "Util tests" utilTests
describe "SMP server via TLS" $ serverTests (transport @TLS)

View File

@@ -10,8 +10,8 @@ import AgentTests.FunctionalAPITests (get, getSMPAgentClient', rfGet, runRight,
import Control.Concurrent (threadDelay)
import Control.Logger.Simple
import Control.Monad.Except
import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Int (Int64)
import Data.List (find, isSuffixOf)
import Data.Maybe (fromJust)
@@ -22,6 +22,8 @@ import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
import Simplex.Messaging.Agent (AgentClient, disconnectAgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendFile, xftpStartWorkers)
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..), BrokerErrorType (..), RcvFileId, SndFileId, noAuthSrv)
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs)
import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Protocol (BasicAuth, ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory)
@@ -32,8 +34,9 @@ import XFTPCLI
import XFTPClient
xftpAgentTests :: Spec
xftpAgentTests = around_ testBracket . describe "Functional API" $ do
xftpAgentTests = around_ testBracket . describe "agent XFTP API" $ do
it "should send and receive file" testXFTPAgentSendReceive
it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted
it "should resume receiving file after restart" testXFTPAgentReceiveRestore
it "should cleanup rcv tmp path after permanent error" testXFTPAgentReceiveCleanup
it "should resume sending file after restart" testXFTPAgentSendRestore
@@ -54,22 +57,24 @@ xftpAgentTests = around_ testBracket . describe "Functional API" $ do
it "should fail without password" $ testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr
it "should fail with incorrect password" $ testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr
rfProgress :: (MonadIO m, MonadFail m) => AgentClient -> Int64 -> m ()
rfProgress :: forall m. (HasCallStack, MonadIO m, MonadFail m) => AgentClient -> Int64 -> m ()
rfProgress c expected = loop 0
where
loop :: HasCallStack => Int64 -> m ()
loop prev = do
(_, _, RFPROG rcvd total) <- rfGet c
checkProgress (prev, expected) (rcvd, total) loop
sfProgress :: (MonadIO m, MonadFail m) => AgentClient -> Int64 -> m ()
sfProgress :: forall m. (HasCallStack, MonadIO m, MonadFail m) => AgentClient -> Int64 -> m ()
sfProgress c expected = loop 0
where
loop :: HasCallStack => Int64 -> m ()
loop prev = do
(_, _, SFPROG sent total) <- sfGet c
checkProgress (prev, expected) (sent, total) loop
-- checks that progress increases till it reaches total
checkProgress :: MonadIO m => (Int64, Int64) -> (Int64, Int64) -> (Int64 -> m ()) -> m ()
checkProgress :: (HasCallStack, MonadIO m) => (Int64, Int64) -> (Int64, Int64) -> (Int64 -> m ()) -> m ()
checkProgress (prev, expected) (progress, total) loop
| total /= expected = error "total /= expected"
| progress <= prev = error "progress <= prev"
@@ -77,10 +82,9 @@ checkProgress (prev, expected) (progress, total) loop
| progress < total = loop progress
| otherwise = pure ()
testXFTPAgentSendReceive :: IO ()
testXFTPAgentSendReceive :: HasCallStack => IO ()
testXFTPAgentSendReceive = withXFTPServer $ do
filePath <- createRandomFile
-- send file, delete snd file internally
sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
(rfd1, rfd2) <- runRight $ do
@@ -99,42 +103,67 @@ testXFTPAgentSendReceive = withXFTPServer $ do
xftpDeleteRcvFile rcp rfId
disconnectAgentClient rcp
createRandomFile :: IO FilePath
testXFTPAgentSendReceiveEncrypted :: HasCallStack => IO ()
testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do
filePath <- createRandomFile
s <- LB.readFile filePath
file <- CryptoFile (senderFiles </> "encrypted_testfile") . Just <$> CF.randomArgs
runRight_ $ CF.writeFile file s
sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
(rfd1, rfd2) <- runRight $ do
(sfId, _, rfd1, rfd2) <- testSendCF sndr file
xftpDeleteSndFileInternal sndr sfId
pure (rfd1, rfd2)
-- receive file, delete rcv file
testReceiveDelete rfd1 filePath
testReceiveDelete rfd2 filePath
where
testReceiveDelete rfd originalFilePath = do
rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
cfArgs <- Just <$> CF.randomArgs
runRight_ $ do
rfId <- testReceiveCF rcp rfd cfArgs originalFilePath
xftpDeleteRcvFile rcp rfId
disconnectAgentClient rcp
createRandomFile :: HasCallStack => IO FilePath
createRandomFile = do
let filePath = senderFiles </> "testfile"
xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath]
getFileSize filePath `shouldReturn` mb 17
pure filePath
testSend :: AgentClient -> FilePath -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSend sndr filePath = do
testSend :: HasCallStack => AgentClient -> FilePath -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSend sndr = testSendCF sndr . CF.plain
testSendCF :: HasCallStack => AgentClient -> CryptoFile -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient)
testSendCF sndr file = do
xftpStartWorkers sndr (Just senderFiles)
sfId <- xftpSendFile sndr 1 filePath 2
sfId <- xftpSendFile sndr 1 file 2
sfProgress sndr $ mb 18
("", sfId', SFDONE sndDescr [rfd1, rfd2]) <- sfGet sndr
liftIO $ sfId' `shouldBe` sfId
pure (sfId, sndDescr, rfd1, rfd2)
testReceive :: AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceive rcp rfd originalFilePath = do
testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceive rcp rfd = testReceiveCF rcp rfd Nothing
testReceiveCF :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId
testReceiveCF rcp rfd cfArgs originalFilePath = do
xftpStartWorkers rcp (Just recipientFiles)
rfId <- xftpReceiveFile rcp 1 rfd
rfId <- xftpReceiveFile rcp 1 rfd cfArgs
rfProgress rcp $ mb 18
("", rfId', RFDONE path) <- rfGet rcp
liftIO $ do
rfId' `shouldBe` rfId
file <- B.readFile originalFilePath
B.readFile path `shouldReturn` file
sentFile <- LB.readFile originalFilePath
runExceptT (CF.readFile $ CryptoFile path cfArgs) `shouldReturn` Right sentFile
pure rfId
getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FRecipient)
getFileDescription path =
ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
logCfgNoLogs :: LogConfig
logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False}
testXFTPAgentReceiveRestore :: IO ()
testXFTPAgentReceiveRestore :: HasCallStack => IO ()
testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -149,7 +178,7 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
rfId <- runRight $ do
xftpStartWorkers rcp (Just recipientFiles)
rfId <- xftpReceiveFile rcp 1 rfd
rfId <- xftpReceiveFile rcp 1 rfd Nothing
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
pure rfId
disconnectAgentClient rcp
@@ -182,7 +211,7 @@ testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do
-- tmp path should be removed after receiving file
doesDirectoryExist tmpPath `shouldReturn` False
testXFTPAgentReceiveCleanup :: IO ()
testXFTPAgentReceiveCleanup :: HasCallStack => IO ()
testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -197,7 +226,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
rcp <- getSMPAgentClient' agentCfg initAgentServers testDB2
rfId <- runRight $ do
xftpStartWorkers rcp (Just recipientFiles)
rfId <- xftpReceiveFile rcp 1 rfd
rfId <- xftpReceiveFile rcp 1 rfd Nothing
liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt
pure rfId
disconnectAgentClient rcp
@@ -216,7 +245,7 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do
-- tmp path should be removed after permanent error
doesDirectoryExist tmpPath `shouldReturn` False
testXFTPAgentSendRestore :: IO ()
testXFTPAgentSendRestore :: HasCallStack => IO ()
testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -224,7 +253,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
sfId <- runRight $ do
xftpStartWorkers sndr (Just senderFiles)
sfId <- xftpSendFile sndr 1 filePath 2
sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2
liftIO $ timeout 1000000 (get sndr) `shouldReturn` Nothing -- wait for worker to encrypt and attempt to create file
pure sfId
disconnectAgentClient sndr
@@ -264,7 +293,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
runRight_ $
void $ testReceive rcp rfd1 filePath
testXFTPAgentSendCleanup :: IO ()
testXFTPAgentSendCleanup :: HasCallStack => IO ()
testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -273,7 +302,7 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
sfId <- runRight $ do
xftpStartWorkers sndr (Just senderFiles)
sfId <- xftpSendFile sndr 1 filePath 2
sfId <- xftpSendFile sndr 1 (CF.plain filePath) 2
-- wait for progress events for 5 out of 6 chunks - at this point all chunks should be created on the server
forM_ [1 .. 5 :: Integer] $ \_ -> do
(_, _, SFPROG _ _) <- sfGet sndr
@@ -300,7 +329,7 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
doesDirectoryExist prefixPath `shouldReturn` False
doesFileExist encPath `shouldReturn` False
testXFTPAgentDelete :: IO ()
testXFTPAgentDelete :: HasCallStack => IO ()
testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
withXFTPServer $ do
filePath <- createRandomFile
@@ -331,11 +360,11 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs $
rcp2 <- getSMPAgentClient' agentCfg initAgentServers testDB2
runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
testXFTPAgentDeleteRestore :: IO ()
testXFTPAgentDeleteRestore :: HasCallStack => IO ()
testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -375,11 +404,11 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do
rcp2 <- getSMPAgentClient' agentCfg initAgentServers testDB3
runRight $ do
xftpStartWorkers rcp2 (Just recipientFiles)
rfId <- xftpReceiveFile rcp2 1 rfd2
rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing
("", rfId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp2
liftIO $ rfId' `shouldBe` rfId
testXFTPAgentRequestAdditionalRecipientIDs :: IO ()
testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => IO ()
testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
filePath <- createRandomFile
@@ -387,7 +416,7 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
sndr <- getSMPAgentClient' agentCfg initAgentServers testDB
rfds <- runRight $ do
xftpStartWorkers sndr (Just senderFiles)
sfId <- xftpSendFile sndr 1 filePath 500
sfId <- xftpSendFile sndr 1 (CF.plain filePath) 500
sfProgress sndr $ mb 18
("", sfId', SFDONE _sndDescr rfds) <- sfGet sndr
liftIO $ do
@@ -404,7 +433,7 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
void $ testReceive rcp (rfds !! 299) filePath
void $ testReceive rcp (rfds !! 499) filePath
testXFTPServerTest :: Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
testXFTPServerTest newFileBasicAuth srv =
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ -> do
a <- getSMPAgentClient' agentCfg initAgentServers testDB -- initially passed server is not running

View File

@@ -57,10 +57,10 @@ withXFTPServerCfg cfg =
withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
withXFTPServer :: IO a -> IO a
withXFTPServer :: HasCallStack => IO a -> IO a
withXFTPServer = withXFTPServerCfg testXFTPServerConfig . const
withXFTPServer2 :: IO a -> IO a
withXFTPServer2 :: HasCallStack => IO a -> IO a
withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} . const
xftpTestPort :: ServiceName