mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-03-30 14:16:00 +00:00
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:
committed by
GitHub
parent
4c0b8a31d2
commit
5dc3d739b2
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 <-
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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;
|
||||
|]
|
||||
@@ -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,
|
||||
|
||||
125
src/Simplex/Messaging/Crypto/File.hs
Normal file
125
src/Simplex/Messaging/Crypto/File.hs
Normal 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
|
||||
@@ -17,6 +17,8 @@ module Simplex.Messaging.Crypto.Lazy
|
||||
sbEncryptTailTag,
|
||||
sbDecryptTailTag,
|
||||
fastReplicate,
|
||||
secretBox,
|
||||
secretBoxTailTag,
|
||||
SbState,
|
||||
cbInit,
|
||||
sbInit,
|
||||
|
||||
97
tests/CoreTests/CryptoFileTests.hs
Normal file
97
tests/CoreTests/CryptoFileTests.hs
Normal 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
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user