From 5dc3d739b206edc2b4706ba0eef64ad4492e68e6 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Thu, 31 Aug 2023 22:43:58 +0100 Subject: [PATCH 1/7] agent: support encrypted local files (#837) * agent: support encrypted local files * migration, update store, api * tests, fix * use CF.plain --- simplexmq.cabal | 3 + src/Simplex/FileTransfer/Agent.hs | 30 +++-- src/Simplex/FileTransfer/Client/Main.hs | 8 +- src/Simplex/FileTransfer/Crypto.hs | 41 +++--- src/Simplex/FileTransfer/Types.hs | 5 +- src/Simplex/Messaging/Agent.hs | 15 ++- src/Simplex/Messaging/Agent/Store/SQLite.hs | 37 +++--- .../Agent/Store/SQLite/Migrations.hs | 4 +- .../Migrations/M20230829_crypto_files.hs | 24 ++++ .../Store/SQLite/Migrations/agent_schema.sql | 5 + src/Simplex/Messaging/Crypto/File.hs | 125 ++++++++++++++++++ src/Simplex/Messaging/Crypto/Lazy.hs | 2 + tests/CoreTests/CryptoFileTests.hs | 97 ++++++++++++++ tests/Test.hs | 2 + tests/XFTPAgent.hs | 99 +++++++++----- tests/XFTPClient.hs | 4 +- 16 files changed, 402 insertions(+), 99 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230829_crypto_files.hs create mode 100644 src/Simplex/Messaging/Crypto/File.hs create mode 100644 tests/CoreTests/CryptoFileTests.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index cf02c13c1..7850890bc 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -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 diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index 14b6af33b..f4eaae1a7 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 951b62a8e..b40169def 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Crypto.hs b/src/Simplex/FileTransfer/Crypto.hs index 71f5dec96..64b66dfc7 100644 --- a/src/Simplex/FileTransfer/Crypto.hs +++ b/src/Simplex/FileTransfer/Crypto.hs @@ -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) diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index 0e0c4ac0d..e51cb14e3 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index d0b089600..6dac14717 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 9040274ce..77175634a 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -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 <- diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index d84d8d2fe..6d46b7cc0 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230829_crypto_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230829_crypto_files.hs new file mode 100644 index 000000000..a2ed8321b --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230829_crypto_files.hs @@ -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; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 5f355591e..dbb1dface 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -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, diff --git a/src/Simplex/Messaging/Crypto/File.hs b/src/Simplex/Messaging/Crypto/File.hs new file mode 100644 index 000000000..ab55a9198 --- /dev/null +++ b/src/Simplex/Messaging/Crypto/File.hs @@ -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 diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs index ab972c8da..6fb37adf7 100644 --- a/src/Simplex/Messaging/Crypto/Lazy.hs +++ b/src/Simplex/Messaging/Crypto/Lazy.hs @@ -17,6 +17,8 @@ module Simplex.Messaging.Crypto.Lazy sbEncryptTailTag, sbDecryptTailTag, fastReplicate, + secretBox, + secretBoxTailTag, SbState, cbInit, sbInit, diff --git a/tests/CoreTests/CryptoFileTests.hs b/tests/CoreTests/CryptoFileTests.hs new file mode 100644 index 000000000..0e750d5b9 --- /dev/null +++ b/tests/CoreTests/CryptoFileTests.hs @@ -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 diff --git a/tests/Test.hs b/tests/Test.hs index 21c6453e5..5c07cde1e 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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) diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index ad7c81f56..4562c5b76 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -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 diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 658344aed..50d75377a 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -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 From 17a1a911d885eae8b939fd6deaa797f3dc72289c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 1 Sep 2023 22:24:53 +0100 Subject: [PATCH 2/7] import stateTVar --- src/Simplex/Messaging/Crypto/File.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Simplex/Messaging/Crypto/File.hs b/src/Simplex/Messaging/Crypto/File.hs index ab55a9198..789bdd509 100644 --- a/src/Simplex/Messaging/Crypto/File.hs +++ b/src/Simplex/Messaging/Crypto/File.hs @@ -21,6 +21,7 @@ module Simplex.Messaging.Crypto.File ) where +import Control.Concurrent.STM (stateTVar) import Control.Exception import Control.Monad.Except import Data.Aeson (FromJSON, ToJSON) From 980e5c4d1ec15f44290542fd2a5d1c08456f00d1 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Mon, 4 Sep 2023 22:02:12 +0100 Subject: [PATCH 3/7] agent: add debugging info (#840) --- src/Simplex/Messaging/Agent/Client.hs | 22 +++++++++++++++------- src/Simplex/Messaging/Agent/TRcvQueues.hs | 1 + 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 66396bd36..6ad86aa26 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -229,6 +229,7 @@ data AgentClient = AgentClient subscrConns :: TVar (Set ConnId), activeSubs :: TRcvQueues, pendingSubs :: TRcvQueues, + removedSubs :: TMap (UserId, SMPServer, SMP.RecipientId) SMPClientError, pendingMsgsQueued :: TMap SndQAddr Bool, smpQueueMsgQueues :: TMap SndQAddr (TQueue InternalId, TMVar ()), smpQueueMsgDeliveries :: TMap SndQAddr (Async ()), @@ -305,6 +306,7 @@ newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do subscrConns <- newTVar S.empty activeSubs <- RQ.empty pendingSubs <- RQ.empty + removedSubs <- TM.empty pendingMsgsQueued <- TM.empty smpQueueMsgQueues <- TM.empty smpQueueMsgDeliveries <- TM.empty @@ -341,6 +343,7 @@ newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do subscrConns, activeSubs, pendingSubs, + removedSubs, pendingMsgsQueued, smpQueueMsgQueues, smpQueueMsgDeliveries, @@ -857,8 +860,9 @@ processSubResult :: AgentClient -> RcvQueue -> Either SMPClientError () -> IO (E processSubResult c rq r = do case r of Left e -> - atomically . unless (temporaryClientError e) $ + unless (temporaryClientError e) . atomically $ do RQ.deleteQueue rq (pendingSubs c) + TM.insert (RQ.qKey rq) e (removedSubs c) _ -> addSubscription c rq pure r @@ -1345,14 +1349,15 @@ withNextSrv c userId usedSrvs initUsed action = do writeTVar usedSrvs $! used' action srvAuth -data SubInfo = SubInfo {userId :: UserId, server :: Text, rcvId :: Text} +data SubInfo = SubInfo {userId :: UserId, server :: Text, rcvId :: Text, subError :: Maybe String} deriving (Show, Generic) -instance ToJSON SubInfo where toEncoding = J.genericToEncoding J.defaultOptions +instance ToJSON SubInfo where toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} data SubscriptionsInfo = SubscriptionsInfo { activeSubscriptions :: [SubInfo], - pendingSubscriptions :: [SubInfo] + pendingSubscriptions :: [SubInfo], + removedSubscriptions :: [SubInfo] } deriving (Show, Generic) @@ -1362,9 +1367,12 @@ getAgentSubscriptions :: MonadIO m => AgentClient -> m SubscriptionsInfo getAgentSubscriptions c = do activeSubscriptions <- getSubs activeSubs pendingSubscriptions <- getSubs pendingSubs - pure $ SubscriptionsInfo {activeSubscriptions, pendingSubscriptions} + removedSubscriptions <- getRemovedSubs + pure $ SubscriptionsInfo {activeSubscriptions, pendingSubscriptions, removedSubscriptions} where - getSubs sel = map subInfo . M.keys <$> readTVarIO (getRcvQueues $ sel c) - subInfo (uId, srv, rId) = SubInfo {userId = uId, server = enc srv, rcvId = enc rId} + getSubs sel = map (`subInfo` Nothing) . M.keys <$> readTVarIO (getRcvQueues $ sel c) + getRemovedSubs = map (uncurry subInfo . second Just) . M.assocs <$> readTVarIO (removedSubs c) + subInfo :: (UserId, SMPServer, SMP.RecipientId) -> Maybe SMPClientError -> SubInfo + subInfo (uId, srv, rId) err = SubInfo {userId = uId, server = enc srv, rcvId = enc rId, subError = show <$> err} enc :: StrEncoding a => a -> Text enc = decodeLatin1 . strEncode diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs index 6af2a4ed4..ffdaf3631 100644 --- a/src/Simplex/Messaging/Agent/TRcvQueues.hs +++ b/src/Simplex/Messaging/Agent/TRcvQueues.hs @@ -10,6 +10,7 @@ module Simplex.Messaging.Agent.TRcvQueues deleteQueue, getSessQueues, getDelSessQueues, + qKey, ) where From 351f42650c57f310fc1ea858ff9b7178823f1fd4 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Wed, 6 Sep 2023 15:42:47 +0400 Subject: [PATCH 4/7] export isCompatibleRange function (#841) --- src/Simplex/Messaging/Version.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Simplex/Messaging/Version.hs b/src/Simplex/Messaging/Version.hs index 276352ffb..dc8cfff68 100644 --- a/src/Simplex/Messaging/Version.hs +++ b/src/Simplex/Messaging/Version.hs @@ -17,6 +17,7 @@ module Simplex.Messaging.Version safeVersionRange, versionToRange, isCompatible, + isCompatibleRange, proveCompatible, compatibleVersion, ) From 504465f8e2922c473076ece934af358947b10f99 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 8 Sep 2023 13:31:11 +0100 Subject: [PATCH 5/7] xftp: add 64kb file chunk (#842) * xftp: add 64kb file chunk * disable chunk size 64kb in the agent * revert rename --- simplexmq.cabal | 1 + src/Simplex/FileTransfer/Chunks.hs | 35 +++++++++++++++++++++++++ src/Simplex/FileTransfer/Client/Main.hs | 19 +++++--------- src/Simplex/FileTransfer/Description.hs | 13 +-------- src/Simplex/FileTransfer/Server/Main.hs | 5 ++-- 5 files changed, 46 insertions(+), 27 deletions(-) create mode 100644 src/Simplex/FileTransfer/Chunks.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 7850890bc..ef75bdec0 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -35,6 +35,7 @@ flag swift library exposed-modules: Simplex.FileTransfer.Agent + Simplex.FileTransfer.Chunks Simplex.FileTransfer.Client Simplex.FileTransfer.Client.Agent Simplex.FileTransfer.Client.Main diff --git a/src/Simplex/FileTransfer/Chunks.hs b/src/Simplex/FileTransfer/Chunks.hs new file mode 100644 index 000000000..0b35649c5 --- /dev/null +++ b/src/Simplex/FileTransfer/Chunks.hs @@ -0,0 +1,35 @@ +module Simplex.FileTransfer.Chunks where + +import Data.Word (Word32) + +serverChunkSizes :: [Word32] +serverChunkSizes = [chunkSize0, chunkSize1, chunkSize2, chunkSize3] +{-# INLINE serverChunkSizes #-} + +chunkSize0 :: Word32 +chunkSize0 = kb 64 +{-# INLINE chunkSize0 #-} + +chunkSize1 :: Word32 +chunkSize1 = kb 256 +{-# INLINE chunkSize1 #-} + +chunkSize2 :: Word32 +chunkSize2 = mb 1 +{-# INLINE chunkSize2 #-} + +chunkSize3 :: Word32 +chunkSize3 = mb 4 +{-# INLINE chunkSize3 #-} + +kb :: Integral a => a -> a +kb n = 1024 * n +{-# INLINE kb #-} + +mb :: Integral a => a -> a +mb n = 1024 * kb n +{-# INLINE mb #-} + +gb :: Integral a => a -> a +gb n = 1024 * mb n +{-# INLINE gb #-} diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index b40169def..65de06ed4 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -17,9 +17,6 @@ module Simplex.FileTransfer.Client.Main cliSendFileOpts, prepareChunkSizes, prepareChunkSpecs, - chunkSize1, - chunkSize2, - chunkSize3, maxFileSize, fileSizeLen, getChunkDigest, @@ -49,6 +46,7 @@ import qualified Data.Text as T import Data.Word (Word32) import GHC.Records (HasField (getField)) import Options.Applicative +import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Client import Simplex.FileTransfer.Client.Agent import Simplex.FileTransfer.Client.Presets @@ -78,15 +76,6 @@ import UnliftIO.Directory xftpClientVersion :: String xftpClientVersion = "1.0.1" -chunkSize1 :: Word32 -chunkSize1 = kb 256 - -chunkSize2 :: Word32 -chunkSize2 = mb 1 - -chunkSize3 :: Word32 -chunkSize3 = mb 4 - maxFileSize :: Int64 maxFileSize = gb 1 @@ -533,7 +522,11 @@ getFileDescription' path = prepareChunkSizes :: Int64 -> [Word32] prepareChunkSizes size' = prepareSizes size' where - (smallSize, bigSize) = if size' > size34 chunkSize3 then (chunkSize2, chunkSize3) else (chunkSize1, chunkSize2) + (smallSize, bigSize) + | size' > size34 chunkSize3 = (chunkSize2, chunkSize3) + | otherwise = (chunkSize1, chunkSize2) + -- | size' > size34 chunkSize2 = (chunkSize1, chunkSize2) + -- | otherwise = (chunkSize0, chunkSize1) size34 sz = (fromIntegral sz * 3) `div` 4 prepareSizes 0 = [] prepareSizes size diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index 0fa99e372..a28b3ae13 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/src/Simplex/FileTransfer/Description.hs @@ -53,6 +53,7 @@ import qualified Data.Yaml as Y import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics (Generic) +import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Protocol import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -236,18 +237,6 @@ instance (Integral a, Show a) => StrEncoding (FileSize a) where A.decimal ] -kb :: Integral a => a -> a -kb n = 1024 * n -{-# INLINE kb #-} - -mb :: Integral a => a -> a -mb n = 1024 * kb n -{-# INLINE mb #-} - -gb :: Integral a => a -> a -gb n = 1024 * mb n -{-# INLINE gb #-} - instance (Integral a, Show a) => IsString (FileSize a) where fromString = either error id . strDecode . B.pack diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 5da183437..50f7c97c8 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -16,7 +16,8 @@ import Data.Maybe (fromMaybe) import qualified Data.Text as T import Network.Socket (HostName) import Options.Applicative -import Simplex.FileTransfer.Description (FileSize (..), kb, mb) +import Simplex.FileTransfer.Chunks +import Simplex.FileTransfer.Description (FileSize (..)) import Simplex.FileTransfer.Server (runXFTPServer) import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defFileExpirationHours) import qualified Simplex.Messaging.Crypto as C @@ -138,7 +139,7 @@ xftpServerCLI cfgPath logPath = do storeLogFile = enableStoreLog $> storeLogFilePath, filesPath = T.unpack $ strictIni "FILES" "path" ini, fileSizeQuota = either error unFileSize <$> strDecodeIni "FILES" "storage_quota" ini, - allowedChunkSizes = [kb 256, mb 1, mb 4], + allowedChunkSizes = serverChunkSizes, allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini, newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini, fileExpiration = From 84ce03786756042f13442ff023022e1e6ab39607 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 10 Sep 2023 17:07:19 +0100 Subject: [PATCH 6/7] extend SMP protocol to allow creating new queues without subscriptions (#839) * Trace auto-subs flag * Replace Bools with SubscriptionMode * Handle SMOnlyCreate * Wire remaining todos * Update tests and fix * Bump protocol level * Apply suggestions from code review Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> * Scrub needs_sub from agent DB * Scrub a few more needSubs from the agent api * change API, fix test * agent: do not subscribe to queue when creating reply queue * fix encoding * WIP: SMOnlyCreate test * Add SM guard for confirmQueue Allows the test case to pump the allowConnection reply without getting PROHIBITED. * Remove tracing * add noMessages, remove unnecessary getConnectionMessage from test * add sending messages to the test --------- Co-authored-by: IC Rainbow Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> --- apps/smp-server/Main.hs | 1 - src/Simplex/Messaging/Agent.hs | 144 ++++++++++++------------ src/Simplex/Messaging/Agent/Client.hs | 9 +- src/Simplex/Messaging/Agent/Protocol.hs | 19 ++-- src/Simplex/Messaging/Client.hs | 5 +- src/Simplex/Messaging/Protocol.hs | 43 +++++-- src/Simplex/Messaging/Server.hs | 15 ++- src/Simplex/Messaging/Transport.hs | 2 +- tests/AgentTests.hs | 52 +++++---- tests/AgentTests/FunctionalAPITests.hs | 129 ++++++++++++++------- tests/AgentTests/NotificationTests.hs | 18 +-- tests/ServerTests.hs | 30 ++--- 12 files changed, 274 insertions(+), 193 deletions(-) diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index 14738c154..92bdfded4 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -3,7 +3,6 @@ module Main where import Control.Logger.Simple -import Data.Maybe import Simplex.Messaging.Server.Main import System.Environment diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 6dac14717..880822ba0 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -148,7 +148,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, UserProtocol, XFTPServerWithAuth) +import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SubscriptionMode (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, UserProtocol, XFTPServerWithAuth) import qualified Simplex.Messaging.Protocol as SMP import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util @@ -189,20 +189,20 @@ deleteUser :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> m () deleteUser c = withAgentEnv c .: deleteUser' c -- | Create SMP agent connection (NEW command) asynchronously, synchronous response is new connection id -createConnectionAsync :: forall m c. (AgentErrorMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId -createConnectionAsync c userId corrId enableNtfs cMode = withAgentEnv c $ newConnAsync c userId corrId enableNtfs cMode +createConnectionAsync :: forall m c. (AgentErrorMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> SubscriptionMode -> m ConnId +createConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .: newConnAsync c userId aCorrId enableNtfs -- | Join SMP agent connection (JOIN command) asynchronously, synchronous response is new connection id -joinConnectionAsync :: AgentErrorMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId -joinConnectionAsync c userId corrId enableNtfs = withAgentEnv c .: joinConnAsync c userId corrId enableNtfs +joinConnectionAsync :: AgentErrorMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> m ConnId +joinConnectionAsync c userId aCorrId enableNtfs = withAgentEnv c .:. joinConnAsync c userId aCorrId enableNtfs -- | Allow connection to continue after CONF notification (LET command), no synchronous response allowConnectionAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> m () allowConnectionAsync c = withAgentEnv c .:: allowConnectionAsync' c -- | Accept contact after REQ notification (ACPT command) asynchronously, synchronous response is new connection id -acceptContactAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> m ConnId -acceptContactAsync c corrId enableNtfs = withAgentEnv c .: acceptContactAsync' c corrId enableNtfs +acceptContactAsync :: AgentErrorMonad m => AgentClient -> ACorrId -> Bool -> ConfirmationId -> ConnInfo -> SubscriptionMode -> m ConnId +acceptContactAsync c aCorrId enableNtfs = withAgentEnv c .:. acceptContactAsync' c aCorrId enableNtfs -- | Acknowledge message (ACK command) asynchronously, no synchronous response ackMessageAsync :: forall m. AgentErrorMonad m => AgentClient -> ACorrId -> ConnId -> AgentMsgId -> Maybe MsgReceiptInfo -> m () @@ -221,20 +221,20 @@ deleteConnectionsAsync :: AgentErrorMonad m => AgentClient -> [ConnId] -> m () deleteConnectionsAsync c = withAgentEnv c . deleteConnectionsAsync' c -- | Create SMP agent connection (NEW command) -createConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) -createConnection c userId enableNtfs cMode clientData = withAgentEnv c $ newConn c userId "" enableNtfs cMode clientData +createConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> m (ConnId, ConnectionRequestUri c) +createConnection c userId enableNtfs = withAgentEnv c .:. newConn c userId "" enableNtfs -- | Join SMP agent connection (JOIN command) -joinConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId -joinConnection c userId enableNtfs = withAgentEnv c .: joinConn c userId "" enableNtfs +joinConnection :: AgentErrorMonad m => AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> m ConnId +joinConnection c userId enableNtfs = withAgentEnv c .:. joinConn c userId "" enableNtfs -- | Allow connection to continue after CONF notification (LET command) allowConnection :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m () allowConnection c = withAgentEnv c .:. allowConnection' c -- | Accept contact after REQ notification (ACPT command) -acceptContact :: AgentErrorMonad m => AgentClient -> Bool -> ConfirmationId -> ConnInfo -> m ConnId -acceptContact c enableNtfs = withAgentEnv c .: acceptContact' c "" enableNtfs +acceptContact :: AgentErrorMonad m => AgentClient -> Bool -> ConfirmationId -> ConnInfo -> SubscriptionMode -> m ConnId +acceptContact c enableNtfs = withAgentEnv c .:. acceptContact' c "" enableNtfs -- | Reject contact (RJCT command) rejectContact :: AgentErrorMonad m => AgentClient -> ConnId -> ConfirmationId -> m () @@ -427,10 +427,10 @@ client c@AgentClient {rcvQ, subQ} = forever $ do processCommand :: forall m. AgentMonad m => AgentClient -> (EntityId, APartyCmd 'Client) -> m (EntityId, APartyCmd 'Agent) processCommand c (connId, APC e cmd) = second (APC e) <$> case cmd of - NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing - JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c userId connId enableNtfs cReq connInfo + NEW enableNtfs (ACM cMode) subMode -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing subMode + JOIN enableNtfs (ACR _ cReq) subMode connInfo -> (,OK) <$> joinConn c userId connId enableNtfs cReq connInfo subMode LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK) - ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo + ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo SMSubscribe RJCT invId -> rejectContact' c connId invId $> (connId, OK) SUB -> subscribeConnection' c connId $> (connId, OK) SEND msgFlags msgBody -> (connId,) . MID <$> sendMessage' c connId msgFlags msgBody @@ -462,10 +462,10 @@ deleteUser' c userId delSMPQueues = do whenM (withStore' c (`deleteUserWithoutConns` userId)) $ atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId) -newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId -newConnAsync c userId corrId enableNtfs cMode = do +newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> SubscriptionMode -> m ConnId +newConnAsync c userId corrId enableNtfs cMode subMode = do connId <- newConnNoQueues c userId "" enableNtfs cMode - enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ NEW enableNtfs (ACM cMode) + enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ NEW enableNtfs (ACM cMode) subMode pure connId newConnNoQueues :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> m ConnId @@ -476,8 +476,8 @@ newConnNoQueues c userId connId enableNtfs cMode = do let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, duplexHandshake = Nothing, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk} withStore c $ \db -> createNewConn db g cData cMode -joinConnAsync :: AgentMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId -joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData {crAgentVRange} _) cInfo = do +joinConnAsync :: AgentMonad m => AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> m ConnId +joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData {crAgentVRange} _) cInfo subMode = do aVRange <- asks $ smpAgentVRange . config case crAgentVRange `compatibleVersion` aVRange of Just (Compatible connAgentVersion) -> do @@ -485,10 +485,10 @@ joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData let duplexHS = connAgentVersion /= 1 cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk} connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation - enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) cInfo + enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) subMode cInfo pure connId _ -> throwError $ AGENT A_VERSION -joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _cInfo = +joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _subMode _cInfo = throwError $ CMD PROHIBITED allowConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> ConfirmationId -> ConnInfo -> m () @@ -498,13 +498,13 @@ allowConnectionAsync' c corrId connId confId ownConnInfo = enqueueCommand c corrId connId (Just server) $ AClientCommand $ APC SAEConn $ LET confId ownConnInfo _ -> throwError $ CMD PROHIBITED -acceptContactAsync' :: AgentMonad m => AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> m ConnId -acceptContactAsync' c corrId enableNtfs invId ownConnInfo = do +acceptContactAsync' :: AgentMonad m => AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> SubscriptionMode -> m ConnId +acceptContactAsync' c corrId enableNtfs invId ownConnInfo subMode = do Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId) withStore c (`getConn` contactConnId) >>= \case SomeConn _ (ContactConnection ConnData {userId} _) -> do withStore' c $ \db -> acceptInvitation db invId ownConnInfo - joinConnAsync c userId corrId enableNtfs connReq ownConnInfo `catchAgentError` \err -> do + joinConnAsync c userId corrId enableNtfs connReq ownConnInfo subMode `catchAgentError` \err -> do withStore' c (`unacceptInvitation` invId) throwError err _ -> throwError $ CMD PROHIBITED @@ -558,21 +558,23 @@ switchConnectionAsync' c corrId connId = pure . connectionStats $ DuplexConnection cData rqs' sqs _ -> throwError $ CMD PROHIBITED -newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) -newConn c userId connId enableNtfs cMode clientData = - getSMPServer c userId >>= newConnSrv c userId connId enableNtfs cMode clientData +newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> m (ConnId, ConnectionRequestUri c) +newConn c userId connId enableNtfs cMode clientData subMode = + getSMPServer c userId >>= newConnSrv c userId connId enableNtfs cMode clientData subMode -newConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) -newConnSrv c userId connId enableNtfs cMode clientData srv = do +newConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) +newConnSrv c userId connId enableNtfs cMode clientData subMode srv = do connId' <- newConnNoQueues c userId connId enableNtfs cMode - newRcvConnSrv c userId connId' enableNtfs cMode clientData srv + newRcvConnSrv c userId connId' enableNtfs cMode clientData subMode srv -newRcvConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) -newRcvConnSrv c userId connId enableNtfs cMode clientData srv = do +newRcvConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> SubscriptionMode -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c) +newRcvConnSrv c userId connId enableNtfs cMode clientData subMode srv = do AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config - (rq, qUri) <- newRcvQueue c userId connId srv smpClientVRange `catchAgentError` \e -> liftIO (print e) >> throwError e + (rq, qUri) <- newRcvQueue c userId connId srv smpClientVRange subMode `catchAgentError` \e -> liftIO (print e) >> throwError e void . withStore c $ \db -> updateNewConnRcv db connId rq - addSubscription c rq + case subMode of + SMOnlyCreate -> pure () + SMSubscribe -> addSubscription c rq when enableNtfs $ do ns <- asks ntfSupervisor atomically $ sendNtfSubCommand ns (connId, NSCCreate) @@ -584,13 +586,13 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData srv = do withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange) -joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> m ConnId -joinConn c userId connId enableNtfs cReq cInfo = do +joinConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> m ConnId +joinConn c userId connId enableNtfs cReq cInfo subMode = do srv <- case cReq of CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _ -> getNextServer c userId [qServer q] _ -> getSMPServer c userId - joinConnSrv c userId connId enableNtfs cReq cInfo srv + joinConnSrv c userId connId enableNtfs cReq cInfo subMode srv startJoinInvitation :: AgentMonad m => UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> m (Compatible Version, ConnData, SndQueue, CR.Ratchet 'C.X448, CR.E2ERatchetParams 'C.X448) startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) = do @@ -609,8 +611,8 @@ startJoinInvitation userId connId enableNtfs (CRInvitationUri ConnReqUriData {cr pure (aVersion, cData, q, rc, e2eSndParams) _ -> throwError $ AGENT A_VERSION -joinConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SMPServerWithAuth -> m ConnId -joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo srv = do +joinConnSrv :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> SMPServerWithAuth -> m ConnId +joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo subMode srv = do (aVersion, cData@ConnData {connAgentVersion}, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv g <- asks idsDrg connId' <- withStore c $ \db -> runExceptT $ do @@ -620,7 +622,7 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo srv = do let sq = (q :: SndQueue) {connId = connId'} cData' = (cData :: ConnData) {connId = connId'} duplexHS = connAgentVersion /= 1 - tryError (confirmQueue aVersion c cData' sq srv cInfo $ Just e2eSndParams) >>= \case + tryError (confirmQueue aVersion c cData' sq srv cInfo (Just e2eSndParams) subMode) >>= \case Right _ -> do unless duplexHS . void $ enqueueMessage c cData' sq SMP.noMsgFlags HELLO pure connId' @@ -628,34 +630,36 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo srv = do -- possible improvement: recovery for failure on network timeout, see rfcs/2022-04-20-smp-conf-timeout-recovery.md withStore' c (`deleteConn` connId') throwError e -joinConnSrv c userId connId enableNtfs (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) cInfo srv = do +joinConnSrv c userId connId enableNtfs (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) cInfo subMode srv = do aVRange <- asks $ smpAgentVRange . config clientVRange <- asks $ smpClientVRange . config case ( qUri `compatibleVersion` clientVRange, crAgentVRange `compatibleVersion` aVRange ) of (Just qInfo, Just vrsn) -> do - (connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing srv + (connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing subMode srv sendInvitation c userId qInfo vrsn cReq cInfo pure connId' _ -> throwError $ AGENT A_VERSION -joinConnSrvAsync :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SMPServerWithAuth -> m () -joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo srv = do +joinConnSrvAsync :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> SMPServerWithAuth -> m () +joinConnSrvAsync c userId connId enableNtfs inv@CRInvitationUri {} cInfo subMode srv = do (aVersion, cData, q, rc, e2eSndParams) <- startJoinInvitation userId connId enableNtfs inv dbQueueId <- withStore c $ \db -> runExceptT $ do liftIO $ createRatchet db connId rc ExceptT $ updateNewConnSnd db connId q let q' = (q :: SndQueue) {dbQueueId} - confirmQueueAsync aVersion c cData q' srv cInfo $ Just e2eSndParams -joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _srv = do + confirmQueueAsync aVersion c cData q' srv cInfo (Just e2eSndParams) subMode +joinConnSrvAsync _c _userId _connId _enableNtfs (CRContactUri _) _cInfo _subMode _srv = do throwError $ CMD PROHIBITED -createReplyQueue :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> m SMPQueueInfo -createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} srv = do - (rq, qUri) <- newRcvQueue c userId connId srv $ versionToRange smpClientVersion +createReplyQueue :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SubscriptionMode -> SMPServerWithAuth -> m SMPQueueInfo +createReplyQueue c ConnData {userId, connId, enableNtfs} SndQueue {smpClientVersion} subMode srv = do + (rq, qUri) <- newRcvQueue c userId connId srv (versionToRange smpClientVersion) subMode let qInfo = toVersionT qUri smpClientVersion - addSubscription c rq + case subMode of + SMOnlyCreate -> pure () + SMSubscribe -> addSubscription c rq void . withStore c $ \db -> upgradeSndConnToDuplex db connId rq when enableNtfs $ do ns <- asks ntfSupervisor @@ -677,13 +681,13 @@ allowConnection' c connId confId ownConnInfo = withConnLock c connId "allowConne _ -> throwError $ CMD PROHIBITED -- | Accept contact (ACPT command) in Reader monad -acceptContact' :: AgentMonad m => AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> m ConnId -acceptContact' c connId enableNtfs invId ownConnInfo = withConnLock c connId "acceptContact" $ do +acceptContact' :: AgentMonad m => AgentClient -> ConnId -> Bool -> InvitationId -> ConnInfo -> SubscriptionMode -> m ConnId +acceptContact' c connId enableNtfs invId ownConnInfo subMode = withConnLock c connId "acceptContact" $ do Invitation {contactConnId, connReq} <- withStore c (`getInvitation` invId) withStore c (`getConn` contactConnId) >>= \case SomeConn _ (ContactConnection ConnData {userId} _) -> do withStore' c $ \db -> acceptInvitation db invId ownConnInfo - joinConn c userId connId enableNtfs connReq ownConnInfo `catchAgentError` \err -> do + joinConn c userId connId enableNtfs connReq ownConnInfo subMode `catchAgentError` \err -> do withStore' c (`unacceptInvitation` invId) throwError err _ -> throwError $ CMD PROHIBITED @@ -891,16 +895,16 @@ runCommandProcessing c@AgentClient {subQ} server_ = do processCmd :: RetryInterval -> AsyncCmdId -> PendingCommand -> m () processCmd ri cmdId PendingCommand {corrId, userId, connId, command} = case command of AClientCommand (APC _ cmd) -> case cmd of - NEW enableNtfs (ACM cMode) -> noServer $ do + NEW enableNtfs (ACM cMode) subMode -> noServer $ do usedSrvs <- newTVarIO ([] :: [SMPServer]) tryCommand . withNextSrv c userId usedSrvs [] $ \srv -> do - (_, cReq) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing srv + (_, cReq) <- newRcvConnSrv c userId connId enableNtfs cMode Nothing subMode srv notify $ INV (ACR cMode cReq) - JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) connInfo -> noServer $ do + JOIN enableNtfs (ACR _ cReq@(CRInvitationUri ConnReqUriData {crSmpQueues = q :| _} _)) subMode connInfo -> noServer $ do let initUsed = [qServer q] usedSrvs <- newTVarIO initUsed tryCommand . withNextSrv c userId usedSrvs initUsed $ \srv -> do - joinConnSrvAsync c userId connId enableNtfs cReq connInfo srv + joinConnSrvAsync c userId connId enableNtfs cReq connInfo subMode srv notify OK LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK @@ -1173,7 +1177,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl -- so the condition is not necessary here, strictly speaking. _ -> unless (duplexHandshake == Just True) $ do srv <- getSMPServer c userId - qInfo <- createReplyQueue c cData sq srv + qInfo <- createReplyQueue c cData sq SMSubscribe srv void . enqueueMessage c cData sq SMP.noMsgFlags $ REPLY [qInfo] AM_A_MSG_ -> notify $ SENT mId AM_A_RCVD_ -> pure () @@ -1291,7 +1295,7 @@ switchDuplexConnection c (DuplexConnection cData@ConnData {connId, userId} rqs s -- try to get the server that is different from all queues, or at least from the primary rcv queue srvAuth@(ProtoServerWithAuth srv _) <- getNextServer c userId $ map qServer (L.toList rqs) <> map qServer (L.toList sqs) srv' <- if srv == server then getNextServer c userId [server] else pure srvAuth - (q, qUri) <- newRcvQueue c userId connId srv' clientVRange + (q, qUri) <- newRcvQueue c userId connId srv' clientVRange SMSubscribe let rq' = (q :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} void . withStore c $ \db -> addConnRcvQueue db connId rq' addSubscription c rq' @@ -2318,15 +2322,15 @@ connectReplyQueues c cData@ConnData {userId, connId} ownConnInfo (qInfo :| _) = dbQueueId <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq enqueueConfirmation c cData sq {dbQueueId} ownConnInfo Nothing -confirmQueueAsync :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m () -confirmQueueAsync v c cData sq srv connInfo e2eEncryption_ = do +confirmQueueAsync :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> SubscriptionMode -> m () +confirmQueueAsync v c cData sq srv connInfo e2eEncryption_ subMode = do resumeMsgDelivery c cData sq - msgId <- storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation v c cData sq srv connInfo + msgId <- storeConfirmation c cData sq e2eEncryption_ =<< mkAgentConfirmation v c cData sq srv connInfo subMode queuePendingMsgs c sq [msgId] -confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m () -confirmQueue v@(Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo e2eEncryption_ = do - msg <- mkConfirmation =<< mkAgentConfirmation v c cData sq srv connInfo +confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> SubscriptionMode -> m () +confirmQueue v@(Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo e2eEncryption_ subMode = do + msg <- mkConfirmation =<< mkAgentConfirmation v c cData sq srv connInfo subMode sendConfirmation c sq msg withStore' c $ \db -> setSndQueueStatus db sq Confirmed where @@ -2336,11 +2340,11 @@ confirmQueue v@(Compatible agentVersion) c cData@ConnData {connId} sq srv connIn encConnInfo <- agentRatchetEncrypt db connId (smpEncode aMessage) e2eEncConnInfoLength pure . smpEncode $ AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo} -mkAgentConfirmation :: AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> m AgentMessage -mkAgentConfirmation (Compatible agentVersion) c cData sq srv connInfo +mkAgentConfirmation :: AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> SubscriptionMode -> m AgentMessage +mkAgentConfirmation (Compatible agentVersion) c cData sq srv connInfo subMode | agentVersion == 1 = pure $ AgentConnInfo connInfo | otherwise = do - qInfo <- createReplyQueue c cData sq srv + qInfo <- createReplyQueue c cData sq subMode srv pure $ AgentConnInfoReply (qInfo :| []) connInfo enqueueConfirmation :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m () diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 6ad86aa26..89849d246 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -182,6 +182,7 @@ import Simplex.Messaging.Protocol SMPMsgMeta (..), SProtocolType (..), SndPublicVerifyKey, + SubscriptionMode (..), UserProtocol, XFTPServer, XFTPServerWithAuth, @@ -749,7 +750,7 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do (sKey, _) <- C.generateSignatureKeyPair a (dhKey, _) <- C.generateKeyPair' r <- runExceptT $ do - SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth + SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth SMSubscribe liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp @@ -823,8 +824,8 @@ mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q) getSessionMode :: AgentMonad' m => AgentClient -> m TransportSessionMode getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig -newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri) -newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do +newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> SubscriptionMode -> m (RcvQueue, SMPQueueUri) +newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do C.SignAlg a <- asks (cmdSignAlg . config) (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a (dhKey, privDhKey) <- liftIO C.generateKeyPair' @@ -832,7 +833,7 @@ newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange = do logServer "-->" c srv "" "NEW" tSess <- mkTransportSession c userId srv connId QIK {rcvId, sndId, rcvPublicDhKey} <- - withClient c tSess "NEW" $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth + withClient c tSess "NEW" $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth subMode logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] let rq = RcvQueue diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index e4c720aef..3053132b9 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -197,6 +197,7 @@ import Simplex.Messaging.Protocol SMPServerWithAuth, SndPublicVerifyKey, SrvLoc (..), + SubscriptionMode, legacyEncodeServer, legacyServerP, legacyStrEncodeServer, @@ -313,9 +314,9 @@ type ConnInfo = ByteString -- | Parameterized type for SMP agent protocol commands and responses from all participants. data ACommand (p :: AParty) (e :: AEntity) where - NEW :: Bool -> AConnectionMode -> ACommand Client AEConn -- response INV + NEW :: Bool -> AConnectionMode -> SubscriptionMode -> ACommand Client AEConn -- response INV INV :: AConnectionRequestUri -> ACommand Agent AEConn - JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client AEConn -- response OK + JOIN :: Bool -> AConnectionRequestUri -> SubscriptionMode -> ConnInfo -> ACommand Client AEConn -- response OK CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake LET :: ConfirmationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender @@ -337,7 +338,7 @@ data ACommand (p :: AParty) (e :: AEntity) where MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent AEConn ACK :: AgentMsgId -> Maybe MsgReceiptInfo -> ACommand Client AEConn - RCVD :: MsgMeta -> NonEmpty MsgReceipt -> ACommand Agent AEConn + RCVD :: MsgMeta -> NonEmpty MsgReceipt -> ACommand Agent AEConn SWCH :: ACommand Client AEConn OFF :: ACommand Client AEConn DEL :: ACommand Client AEConn @@ -998,7 +999,7 @@ data AMessage REPLY (NonEmpty SMPQueueInfo) | -- | agent envelope for the client message A_MSG MsgBody - | -- | agent envelope for delivery receipt + | -- | agent envelope for delivery receipt A_RCVD (NonEmpty AMessageReceipt) | -- | the message instructing the client to continue sending messages (after ERR QUOTA) QCONT SndQAddr @@ -1736,8 +1737,8 @@ commandP binaryP = >>= \case ACmdTag SClient e cmd -> ACmd SClient e <$> case cmd of - NEW_ -> s (NEW <$> strP_ <*> strP) - JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> binaryP) + NEW_ -> s (NEW <$> strP_ <*> strP_ <*> strP) + JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> strP_ <*> binaryP) LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP) ACPT_ -> s (ACPT <$> A.takeTill (== ' ') <* A.space <*> binaryP) RJCT_ -> s (RJCT <$> A.takeByteString) @@ -1798,9 +1799,9 @@ parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX -- | Serialize SMP agent command. serializeCommand :: ACommand p e -> ByteString serializeCommand = \case - NEW ntfs cMode -> s (NEW_, ntfs, cMode) + NEW ntfs cMode subMode -> s (NEW_, ntfs, cMode, subMode) INV cReq -> s (INV_, cReq) - JOIN ntfs cReq cInfo -> s (JOIN_, ntfs, cReq, Str $ serializeBinary cInfo) + JOIN ntfs cReq subMode cInfo -> s (JOIN_, ntfs, cReq, subMode, Str $ serializeBinary cInfo) CONF confId srvs cInfo -> B.unwords [s CONF_, confId, strEncodeList srvs, serializeBinary cInfo] LET confId cInfo -> B.unwords [s LET_, confId, serializeBinary cInfo] REQ invId srvs cInfo -> B.unwords [s REQ_, invId, s srvs, serializeBinary cInfo] @@ -1905,7 +1906,7 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody APC e <$$> case cmd of SEND msgFlags body -> SEND msgFlags <$$> getBody body MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body - JOIN ntfs qUri cInfo -> JOIN ntfs qUri <$$> getBody cInfo + JOIN ntfs qUri subMode cInfo -> JOIN ntfs qUri subMode <$$> getBody cInfo CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo LET confId cInfo -> LET confId <$$> getBody cInfo REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 571b9e741..5152c0212 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -495,9 +495,10 @@ createSMPQueue :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> + SubscriptionMode -> ExceptT SMPClientError IO QueueIdsKeys -createSMPQueue c rpKey rKey dhKey auth = - sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth) >>= \case +createSMPQueue c rpKey rKey dhKey auth subMode = + sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case IDS qik -> pure qik r -> throwE . PCEUnexpectedResponse $ bshow r diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 2de573349..cd3c4ad64 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -47,6 +47,7 @@ module Simplex.Messaging.Protocol -- * SMP protocol types ProtocolEncoding (..), Command (..), + SubscriptionMode (..), Party (..), Cmd (..), BrokerMsg (..), @@ -154,7 +155,7 @@ import Control.Concurrent (threadDelay) import Control.Monad.Except import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J -import Data.Attoparsec.ByteString.Char8 (Parser) +import Data.Attoparsec.ByteString.Char8 (Parser, ()) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -276,7 +277,7 @@ type EntityId = ByteString -- | Parameterized type for SMP protocol commands from all clients. data Command (p :: Party) where -- SMP recipient commands - NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> Command Recipient + NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient SUB :: Command Recipient KEY :: SndPublicVerifyKey -> Command Recipient NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient @@ -299,6 +300,26 @@ deriving instance Show (Command p) deriving instance Eq (Command p) +data SubscriptionMode = SMSubscribe | SMOnlyCreate + deriving (Eq, Show) + +instance StrEncoding SubscriptionMode where + strEncode = \case + SMSubscribe -> "subscribe" + SMOnlyCreate -> "only-create" + strP = + (A.string "subscribe" $> SMSubscribe) <|> (A.string "only-create" $> SMOnlyCreate) + "SubscriptionMode" + +instance Encoding SubscriptionMode where + smpEncode = \case + SMSubscribe -> "S" + SMOnlyCreate -> "C" + smpP = A.anyChar >>= \case + 'S' -> pure SMSubscribe + 'C' -> pure SMOnlyCreate + _ -> fail "bad SubscriptionMode" + data BrokerMsg where -- SMP broker messages (responses, client messages, notifications) IDS :: QueueIdsKeys -> BrokerMsg @@ -1044,13 +1065,13 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding err msg | msg -> err where instance PartyI p => ProtocolEncoding ErrorType (Command p) where type Tag (Command p) = CommandTag p encodeProtocol v = \case - NEW rKey dhKey auth_ -> case auth_ of - Just auth - | v >= 5 -> new <> e ('A', auth) - | otherwise -> new - _ -> new + NEW rKey dhKey auth_ subMode + | v >= 6 -> new <> auth <> e subMode + | v == 5 -> new <> auth + | otherwise -> new where new = e (NEW_, ' ', rKey, dhKey) + auth = maybe "" (e . ('A',)) auth_ SUB -> e SUB_ KEY k -> e (KEY_, ' ', k) NKEY k dhKey -> e (NKEY_, ' ', k, dhKey) @@ -1102,10 +1123,12 @@ instance ProtocolEncoding ErrorType Cmd where CT SRecipient tag -> Cmd SRecipient <$> case tag of NEW_ - | v >= 5 -> new <*> optional (A.char 'A' *> smpP) - | otherwise -> new <*> pure Nothing + | v >= 6 -> new <*> auth <*> smpP + | v == 5 -> new <*> auth <*> pure SMSubscribe + | otherwise -> new <*> pure Nothing <*> pure SMSubscribe where new = NEW <$> _smpP <*> smpP + auth = optional (A.char 'A' *> smpP) SUB_ -> pure SUB KEY_ -> KEY <$> _smpP NKEY_ -> NKEY <$> _smpP <*> smpP @@ -1269,7 +1292,7 @@ tPutLog th s = do -- ByteString does not include length byte, it is added by tEncodeBatch data TransportBatch = TBTransmissions Int ByteString | TBTransmission ByteString | TBLargeTransmission --- | encodes and batches transmissions into blocks, +-- | encodes and batches transmissions into blocks, batchTransmissions :: Bool -> Int -> NonEmpty SentRawTransmission -> [TransportBatch] batchTransmissions batch bSize | batch = reverse . mkBatch [] . L.map tEncode diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 5651a883f..6ec234788 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -362,7 +362,7 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult verifyTransmission sig_ signed queueId cmd = case cmd of - Cmd SRecipient (NEW k _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k + Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey Cmd SSender PING -> pure $ VRVerified Nothing @@ -422,10 +422,10 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv Cmd SNotifier NSUB -> subscribeNotifications Cmd SRecipient command -> case command of - NEW rKey dhKey auth -> + NEW rKey dhKey auth subMode -> ifM allowNew - (createQueue st rKey dhKey) + (createQueue st rKey dhKey subMode) (pure (corrId, queueId, ERR AUTH)) where allowNew = do @@ -440,8 +440,8 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv OFF -> suspendQueue_ st DEL -> delQueueAndMsgs st where - createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m (Transmission BrokerMsg) - createQueue st recipientKey dhKey = time "NEW" $ do + createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> SubscriptionMode -> m (Transmission BrokerMsg) + createQueue st recipientKey dhKey subMode = time "NEW" $ do (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair' let rcvDhSecret = C.dh' dhKey privDhKey qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey} @@ -472,7 +472,10 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Serv stats <- asks serverStats atomically $ modifyTVar' (qCreated stats) (+ 1) atomically $ modifyTVar' (qCount stats) (+ 1) - subscribeQueue qr rId $> IDS (qik ids) + case subMode of + SMOnlyCreate -> pure () + SMSubscribe -> void $ subscribeQueue qr rId + pure $ IDS (qik ids) logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO () logCreateById s rId = diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 3c44e0989..4572a861e 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -98,7 +98,7 @@ smpBlockSize :: Int smpBlockSize = 16384 supportedSMPServerVRange :: VersionRange -supportedSMPServerVRange = mkVersionRange 1 5 +supportedSMPServerVRange = mkVersionRange 1 6 simplexMQVersion :: String simplexMQVersion = showVersion SMQ.version diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 2fc76494f..fbd2a54ed 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -21,6 +21,7 @@ import Control.Monad (forM_) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Type.Equality +import GHC.Stack (withFrozenCallStack) import Network.HTTP.Types (urlEncode) import SMPAgentClient import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn) @@ -123,12 +124,12 @@ h #: t = tPutRaw h t >> (<#:) h -- | action and expected response -- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r` (#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> AEntityTransmission 'Agent 'AEConn -> Expectation -action #> (corrId, connId, cmd) = action `shouldReturn` (corrId, connId, Right cmd) +action #> (corrId, connId, cmd) = withFrozenCallStack $ action `shouldReturn` (corrId, connId, Right cmd) -- | action and predicate for the response -- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p` (=#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation -action =#> p = action >>= (`shouldSatisfy` p . correctTransmission) +action =#> p = withFrozenCallStack $ action >>= (`shouldSatisfy` p . correctTransmission) correctTransmission :: (ACorrId, ConnId, Either AgentErrorType cmd) -> (ACorrId, ConnId, cmd) correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of @@ -163,9 +164,9 @@ pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO () testDuplexConnection _ alice bob = do - ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV") + ("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV subscribe") let cReq' = strEncode cReq - bob #: ("11", "alice", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK) + bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK) ("", "bob", Right (CONF confId _ "bob's connInfo")) <- (alice <#:) alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK) bob <# ("", "alice", INFO "alice's connInfo") @@ -196,9 +197,9 @@ testDuplexConnection _ alice bob = do testDuplexConnRandomIds :: Transport c => TProxy c -> c -> c -> IO () testDuplexConnRandomIds _ alice bob = do - ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV") + ("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV subscribe") let cReq' = strEncode cReq - ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " 14\nbob's connInfo") + ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") ("", bobConn', Right (CONF confId _ "bob's connInfo")) <- (alice <#:) bobConn' `shouldBe` bobConn alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False @@ -229,10 +230,10 @@ testDuplexConnRandomIds _ alice bob = do testContactConnection :: Transport c => TProxy c -> c -> c -> c -> IO () testContactConnection _ alice bob tom = do - ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON") + ("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON subscribe") let cReq' = strEncode cReq - bob #: ("11", "alice", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice", OK) + bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK) ("", "alice_contact", Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:) alice #: ("2", "bob", "ACPT " <> aInvId <> " 16\nalice's connInfo") #> ("2", "bob", OK) ("", "alice", Right (CONF bConfId _ "alice's connInfo")) <- (bob <#:) @@ -245,7 +246,7 @@ testContactConnection _ alice bob tom = do bob <#= \case ("", "alice", Msg "hi") -> True; _ -> False bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK) - tom #: ("21", "alice", "JOIN T " <> cReq' <> " 14\ntom's connInfo") #> ("21", "alice", OK) + tom #: ("21", "alice", "JOIN T " <> cReq' <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK) ("", "alice_contact", Right (REQ aInvId' _ "tom's connInfo")) <- (alice <#:) alice #: ("4", "tom", "ACPT " <> aInvId' <> " 16\nalice's connInfo") #> ("4", "tom", OK) ("", "alice", Right (CONF tConfId _ "alice's connInfo")) <- (tom <#:) @@ -260,10 +261,10 @@ testContactConnection _ alice bob tom = do testContactConnRandomIds :: Transport c => TProxy c -> c -> c -> IO () testContactConnRandomIds _ alice bob = do - ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON") + ("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON subscribe") let cReq' = strEncode cReq - ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " 14\nbob's connInfo") + ("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") ("", aliceContact', Right (REQ aInvId _ "bob's connInfo")) <- (alice <#:) aliceContact' `shouldBe` aliceContact @@ -283,9 +284,9 @@ testContactConnRandomIds _ alice bob = do testRejectContactRequest :: Transport c => TProxy c -> c -> c -> IO () testRejectContactRequest _ alice bob = do - ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON") + ("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON subscribe") let cReq' = strEncode cReq - bob #: ("11", "alice", "JOIN T " <> cReq' <> " 10\nbob's info") #> ("11", "alice", OK) + bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 10\nbob's info") #> ("11", "alice", OK) ("", "a_contact", Right (REQ aInvId _ "bob's info")) <- (alice <#:) -- RJCT must use correct contact connection alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND) @@ -314,7 +315,7 @@ testSubscription _ alice1 alice2 bob = do testSubscrNotification :: Transport c => TProxy c -> (ThreadId, ThreadId) -> c -> IO () testSubscrNotification t (server, _) client = do - client #: ("1", "conn1", "NEW T INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False + client #: ("1", "conn1", "NEW T INV subscribe") =#> \case ("1", "conn1", INV {}) -> True; _ -> False client #:# "nothing should be delivered to client before the server is killed" killThread server client <#. ("", "", DOWN testSMPServer ["conn1"]) @@ -424,9 +425,9 @@ testConcurrentMsgDelivery :: Transport c => TProxy c -> c -> c -> IO () testConcurrentMsgDelivery _ alice bob = do connect (alice, "alice") (bob, "bob") - ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV") + ("1", "bob2", Right (INV cReq)) <- alice #: ("1", "bob2", "NEW T INV subscribe") let cReq' = strEncode cReq - bob #: ("11", "alice2", "JOIN T " <> cReq' <> " 14\nbob's connInfo") #> ("11", "alice2", OK) + bob #: ("11", "alice2", "JOIN T " <> cReq' <> " subscribe 14\nbob's connInfo") #> ("11", "alice2", OK) ("", "bob2", Right (CONF _confId _ "bob's connInfo")) <- (alice <#:) -- below commands would be needed to accept bob's connection, but alice does not -- alice #: ("2", "bob", "LET " <> _confId <> " 16\nalice's connInfo") #> ("2", "bob", OK) @@ -489,9 +490,9 @@ testResumeDeliveryQuotaExceeded _ alice bob = do connect :: forall c. Transport c => (c, ByteString) -> (c, ByteString) -> IO () connect (h1, name1) (h2, name2) = do - ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV") + ("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV subscribe") let cReq' = strEncode cReq - h2 #: ("c2", name1, "JOIN T " <> cReq' <> " 5\ninfo2") #> ("c2", name1, OK) + h2 #: ("c2", name1, "JOIN T " <> cReq' <> " subscribe 5\ninfo2") #> ("c2", name1, OK) ("", _, Right (CONF connId _ "info2")) <- (h1 <#:) h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK) h2 <# ("", name1, INFO "info1") @@ -510,9 +511,9 @@ sendMessage (h1, name1) (h2, name2) msg = do -- connect' :: forall c. Transport c => c -> c -> IO (ByteString, ByteString) -- connect' h1 h2 = do --- ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW T INV") +-- ("c1", conn2, Right (INV cReq)) <- h1 #: ("c1", "", "NEW T INV subscribe") -- let cReq' = strEncode cReq --- ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN T " <> cReq' <> " 5\ninfo2") +-- ("c2", conn1, Right OK) <- h2 #: ("c2", "", "JOIN T " <> cReq' <> " subscribe 5\ninfo2") -- ("", _, Right (REQ connId _ "info2")) <- (h1 <#:) -- h1 #: ("c3", conn2, "ACPT " <> connId <> " 5\ninfo1") =#> \case ("c3", c, OK) -> c == conn2; _ -> False -- h2 <# ("", conn1, INFO "info1") @@ -528,9 +529,9 @@ syntaxTests t = do it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX") describe "NEW" $ do describe "valid" $ do - it "with correct parameter" $ ("211", "", "NEW T INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False + it "with correct parameter" $ ("211", "", "NEW T INV subscribe") >#>= \case ("211", _, "INV" : _) -> True; _ -> False describe "invalid" $ do - it "with incorrect parameter" $ ("222", "", "NEW T hi") >#> ("222", "", "ERR CMD SYNTAX") + it "with incorrect parameter" $ ("222", "", "NEW T hi subscribe") >#> ("222", "", "ERR CMD SYNTAX") describe "JOIN" $ do describe "valid" $ do @@ -543,7 +544,8 @@ syntaxTests t = do <> urlEncode True sampleDhKey <> "&v=1" <> "&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D" - <> " 14\nbob's connInfo" + <> " subscribe " + <> "14\nbob's connInfo" ) >#> ("311", "a", "ERR SMP AUTH") describe "invalid" $ do @@ -551,8 +553,8 @@ syntaxTests t = do where -- simple test for one command with the expected response (>#>) :: ARawTransmission -> ARawTransmission -> Expectation - command >#> response = smpAgentTest t command `shouldReturn` response + command >#> response = withFrozenCallStack $ smpAgentTest t command `shouldReturn` response -- simple test for one command with a predicate for the expected response (>#>=) :: ARawTransmission -> ((ByteString, ByteString, [ByteString]) -> Bool) -> Expectation - command >#>= p = smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, connId, cmd) -> (cId, connId, B.words cmd)) + command >#>= p = withFrozenCallStack $ smpAgentTest t command >>= (`shouldSatisfy` p . \(cId, connId, cmd) -> (cId, connId, B.words cmd)) diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 6b0acbe1e..7f50e3591 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -54,7 +55,7 @@ import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..)) import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), supportedSMPClientVRange) +import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration @@ -68,11 +69,17 @@ import XFTPClient (testXFTPServer) type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e) -(##>) :: (HasCallStack, MonadIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m () -a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t) +(##>) :: (HasCallStack, MonadUnliftIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m () +a ##> t = withTimeout a (`shouldBe` t) -(=##>) :: (Show a, HasCallStack, MonadIO m) => m a -> (a -> Bool) -> m () -a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p) +(=##>) :: (Show a, HasCallStack, MonadUnliftIO m) => m a -> (a -> Bool) -> m () +a =##> p = withTimeout a (`shouldSatisfy` p) + +withTimeout :: MonadUnliftIO m => m a -> (a -> Expectation) -> m () +withTimeout a test = + timeout 10_000000 a >>= \case + Nothing -> error "operation timed out" + Just t -> liftIO $ test t get :: MonadIO m => AgentClient -> m (AEntityTransmission 'AEConn) get = get' @'AEConn @@ -204,6 +211,9 @@ functionalAPITests t = do testRatchetSyncSuspendForeground t it "should synchronize ratchets when clients start synchronization simultaneously" $ testRatchetSyncSimultaneous t + describe "Subscription mode OnlyCreate" $ do + it "messages delivered only when polled" $ + withSmpServer t testOnlyCreatePull describe "Inactive client disconnection" $ do it "should disconnect clients if it was inactive longer than TTL" $ testInactiveClientDisconnected t @@ -356,8 +366,8 @@ withAgentClients2 = withAgentClientsCfg2 agentCfg agentCfg runAgentClientTest :: HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientTest alice bob baseId = do runRight_ $ do - (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) @@ -391,10 +401,10 @@ runAgentClientTest alice bob baseId = do runAgentClientContactTest :: HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientContactTest alice bob baseId = do runRight_ $ do - (_, qInfo) <- createConnection alice 1 True SCMContact Nothing - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" + (_, qInfo) <- createConnection alice 1 True SCMContact Nothing SMSubscribe + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, REQ invId _ "bob's connInfo") <- get alice - bobId <- acceptContact alice True invId "alice's connInfo" + bobId <- acceptContact alice True invId "alice's connInfo" SMSubscribe ("", _, CONF confId _ "alice's connInfo") <- get bob allowConnection bob aliceId confId "bob's connInfo" get alice ##> ("", bobId, INFO "bob's connInfo") @@ -436,9 +446,9 @@ noMessages c err = tryGet `shouldReturn` () testAsyncInitiatingOffline :: HasCallStack => IO () testAsyncInitiatingOffline = withAgentClients2 $ \alice bob -> runRight_ $ do - (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing + (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe disconnectAgentClient alice - aliceId <- joinConnection bob 1 True cReq "bob's connInfo" + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe alice' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB subscribeConnection alice' bobId ("", _, CONF confId _ "bob's connInfo") <- get alice' @@ -451,8 +461,8 @@ testAsyncInitiatingOffline = testAsyncJoiningOfflineBeforeActivation :: HasCallStack => IO () testAsyncJoiningOfflineBeforeActivation = withAgentClients2 $ \alice bob -> runRight_ $ do - (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe disconnectAgentClient bob ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" @@ -466,9 +476,9 @@ testAsyncJoiningOfflineBeforeActivation = testAsyncBothOffline :: HasCallStack => IO () testAsyncBothOffline = withAgentClients2 $ \alice bob -> runRight_ $ do - (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing + (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe disconnectAgentClient alice - aliceId <- joinConnection bob 1 True cReq "bob's connInfo" + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe disconnectAgentClient bob alice' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB subscribeConnection alice' bobId @@ -485,9 +495,9 @@ testAsyncServerOffline :: HasCallStack => ATransport -> IO () testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do -- create connection and shutdown the server (bobId, cReq) <- withSmpServerStoreLogOn t testPort $ \_ -> - runRight $ createConnection alice 1 True SCMInvitation Nothing + runRight $ createConnection alice 1 True SCMInvitation Nothing SMSubscribe -- connection fails - Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo" + Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe ("", "", DOWN srv conns) <- nGet alice srv `shouldBe` testSMPServer conns `shouldBe` [bobId] @@ -497,7 +507,7 @@ testAsyncServerOffline t = withAgentClients2 $ \alice bob -> do liftIO $ do srv1 `shouldBe` testSMPServer conns1 `shouldBe` [bobId] - aliceId <- joinConnection bob 1 True cReq "bob's connInfo" + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) @@ -512,9 +522,9 @@ testAsyncHelloTimeout = do smpCfgV1 = (smpCfg agentCfg) {serverVRange = vr11} agentCfgV1 = agentCfg {smpAgentVRange = vr11, smpClientVRange = vr11, e2eEncryptVRange = vr11, smpCfg = smpCfgV1} withAgentClientsCfg2 agentCfgV1 agentCfg {helloTimeout = 1} $ \alice bob -> runRight_ $ do - (_, cReq) <- createConnection alice 1 True SCMInvitation Nothing + (_, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe disconnectAgentClient alice - aliceId <- joinConnection bob 1 True cReq "bob's connInfo" + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED) testAllowConnectionClientRestart :: HasCallStack => ATransport -> IO () @@ -526,8 +536,8 @@ testAllowConnectionClientRestart t = do (aliceId, bobId, confId) <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \_ -> do runRight $ do - (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice pure (aliceId, bobId, confId) @@ -995,13 +1005,46 @@ testRatchetSyncSimultaneous t = do disconnectAgentClient bob disconnectAgentClient bob2 +testOnlyCreatePull :: IO () +testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate + getMsg alice bobId + Just ("", _, CONF confId _ "bob's connInfo") <- timeout 5_000000 $ get alice + allowConnection alice bobId confId "alice's connInfo" + liftIO $ threadDelay 1_000000 + getMsg bob aliceId + get bob ##> ("", aliceId, INFO "alice's connInfo") + liftIO $ threadDelay 1_000000 + getMsg alice bobId + get alice ##> ("", bobId, CON) + getMsg bob aliceId + get bob ##> ("", aliceId, CON) + -- exchange messages + 4 <- sendMessage alice bobId SMP.noMsgFlags "hello" + get alice ##> ("", bobId, SENT 4) + getMsg bob aliceId + get bob =##> \case ("", c, Msg "hello") -> c == aliceId; _ -> False + ackMessage bob aliceId 4 Nothing + 5 <- sendMessage bob aliceId SMP.noMsgFlags "hello too" + get bob ##> ("", aliceId, SENT 5) + getMsg alice bobId + get alice =##> \case ("", c, Msg "hello too") -> c == bobId; _ -> False + ackMessage alice bobId 5 Nothing + where + getMsg :: AgentClient -> ConnId -> ExceptT AgentErrorType IO () + getMsg c cId = do + liftIO $ noMessages c "nothing should be delivered before GET" + Just _ <- getConnectionMessage c cId + pure () + makeConnection :: AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnection alice bob = makeConnectionForUsers alice 1 bob 1 makeConnectionForUsers :: AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId) makeConnectionForUsers alice aliceUserId bob bobUserId = do - (bobId, qInfo) <- createConnection alice aliceUserId True SCMInvitation Nothing - aliceId <- joinConnection bob bobUserId True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice aliceUserId True SCMInvitation Nothing SMSubscribe + aliceId <- joinConnection bob bobUserId True qInfo "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) @@ -1015,7 +1058,7 @@ testInactiveClientDisconnected t = do withSmpServerConfigOn t cfg' testPort $ \_ -> do alice <- getSMPAgentClient' agentCfg initAgentServers testDB runRight_ $ do - (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing + (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe nGet alice ##> ("", "", DOWN testSMPServer [connId]) disconnectAgentClient alice @@ -1026,7 +1069,7 @@ testActiveClientNotDisconnected t = do alice <- getSMPAgentClient' agentCfg initAgentServers testDB ts <- getSystemTime runRight_ $ do - (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing + (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe keepSubscribing alice connId ts disconnectAgentClient alice where @@ -1181,10 +1224,10 @@ testBatchedSubscriptions nCreate nDel t = do testAsyncCommands :: IO () testAsyncCommands = withAgentClients2 $ \alice bob -> runRight_ $ do - bobId <- createConnectionAsync alice 1 "1" True SCMInvitation + bobId <- createConnectionAsync alice 1 "1" True SCMInvitation SMSubscribe ("1", bobId', INV (ACR _ qInfo)) <- get alice liftIO $ bobId' `shouldBe` bobId - aliceId <- joinConnectionAsync bob 1 "2" True qInfo "bob's connInfo" + aliceId <- joinConnectionAsync bob 1 "2" True qInfo "bob's connInfo" SMSubscribe ("2", aliceId', OK) <- get bob liftIO $ aliceId' `shouldBe` aliceId ("", _, CONF confId _ "bob's connInfo") <- get alice @@ -1225,7 +1268,7 @@ testAsyncCommands = testAsyncCommandsRestore :: ATransport -> IO () testAsyncCommandsRestore t = do alice <- getSMPAgentClient' agentCfg initAgentServers testDB - bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation + bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation SMSubscribe liftIO $ noMessages alice "alice doesn't receive INV because server is down" disconnectAgentClient alice alice' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB @@ -1239,10 +1282,10 @@ testAsyncCommandsRestore t = do testAcceptContactAsync :: IO () testAcceptContactAsync = withAgentClients2 $ \alice bob -> runRight_ $ do - (_, qInfo) <- createConnection alice 1 True SCMContact Nothing - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" + (_, qInfo) <- createConnection alice 1 True SCMContact Nothing SMSubscribe + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, REQ invId _ "bob's connInfo") <- get alice - bobId <- acceptContactAsync alice "1" True invId "alice's connInfo" + bobId <- acceptContactAsync alice "1" True invId "alice's connInfo" SMSubscribe ("1", bobId', OK) <- get alice liftIO $ bobId' `shouldBe` bobId ("", _, CONF confId _ "alice's connInfo") <- get bob @@ -1280,9 +1323,9 @@ testDeleteConnectionAsync :: ATransport -> IO () testDeleteConnectionAsync t = do a <- getSMPAgentClient' agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB connIds <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing - (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing - (bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing + (bId1, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe + (bId2, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe + (bId3, _inv) <- createConnection a 1 True SCMInvitation Nothing SMSubscribe pure ([bId1, bId2, bId3] :: [ConnId]) runRight_ $ do deleteConnectionsAsync a connIds @@ -1301,10 +1344,10 @@ testJoinConnectionAsyncReplyError t = do a <- getSMPAgentClient' agentCfg initAgentServers testDB b <- getSMPAgentClient' agentCfg initAgentServersSrv2 testDB2 (aId, bId) <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do - bId <- createConnectionAsync a 1 "1" True SCMInvitation + bId <- createConnectionAsync a 1 "1" True SCMInvitation SMSubscribe ("1", bId', INV (ACR _ qInfo)) <- get a liftIO $ bId' `shouldBe` bId - aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" + aId <- joinConnectionAsync b 1 "2" True qInfo "bob's connInfo" SMSubscribe liftIO $ threadDelay 500000 ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId pure (aId, bId) @@ -1781,11 +1824,11 @@ testCreateQueueAuth clnt1 clnt2 = do a <- getClient clnt1 b <- getClient clnt2 r <- runRight $ do - tryError (createConnection a 1 True SCMInvitation Nothing) >>= \case + tryError (createConnection a 1 True SCMInvitation Nothing SMSubscribe) >>= \case Left (SMP AUTH) -> pure 0 Left e -> throwError e Right (bId, qInfo) -> - tryError (joinConnection b 1 True qInfo "bob's connInfo") >>= \case + tryError (joinConnection b 1 True qInfo "bob's connInfo" SMSubscribe) >>= \case Left (SMP AUTH) -> pure 1 Left e -> throwError e Right aId -> do @@ -1960,8 +2003,8 @@ getSMPAgentClient' cfg' initServers dbPath = do testServerMultipleIdentities :: HasCallStack => IO () testServerMultipleIdentities = withAgentClients2 $ \alice bob -> runRight_ $ do - (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing - aliceId <- joinConnection bob 1 True cReq "bob's connInfo" + (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + aliceId <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get alice ##> ("", bobId, CON) @@ -1969,7 +2012,7 @@ testServerMultipleIdentities = get bob ##> ("", aliceId, CON) exchangeGreetings alice bobId bob aliceId -- this saves queue with second server identity - Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo" + Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True secondIdentityCReq "bob's connInfo" SMSubscribe disconnectAgentClient bob bob' <- liftIO $ getSMPAgentClient' agentCfg initAgentServers testDB2 subscribeConnection bob' aliceId diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index f1e6ec842..d5e9db960 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -29,7 +29,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Types (NtfToken (..)) -import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..)) +import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), SMPMsgMeta (..), SubscriptionMode (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Transport (ATransport) @@ -217,8 +217,8 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do bob <- getSMPAgentClient' agentCfg initAgentServers testDB2 (bobId, aliceId, nonce, message) <- runRight $ do -- establish connection - (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get bob ##> ("", aliceId, INFO "alice's connInfo") @@ -280,9 +280,9 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do DeviceToken {} <- registerTestToken bob "bcde" NMInstant apnsQ -- establish connection liftIO $ threadDelay 50000 - (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe liftIO $ threadDelay 1000000 - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe liftIO $ threadDelay 750000 void $ messageNotification apnsQ ("", _, CONF confId _ "bob's connInfo") <- get alice @@ -333,8 +333,8 @@ testChangeNotificationsMode APNSMockServer {apnsQ} = do bob <- getSMPAgentClient' agentCfg initAgentServers testDB2 runRight_ $ do -- establish connection - (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get bob ##> ("", aliceId, INFO "alice's connInfo") @@ -399,8 +399,8 @@ testChangeToken APNSMockServer {apnsQ} = do bob <- getSMPAgentClient' agentCfg initAgentServers testDB2 (aliceId, bobId) <- runRight $ do -- establish connection - (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing - aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" + (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe + aliceId <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe ("", _, CONF confId _ "bob's connInfo") <- get alice allowConnection alice bobId confId "alice's connInfo" get bob ##> ("", aliceId, INFO "alice's connInfo") diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 0fa10ae4e..8a56be9b5 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -22,6 +22,7 @@ import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.Set as S +import GHC.Stack (withFrozenCallStack) import SMPClient import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding @@ -121,7 +122,7 @@ testCreateSecureV2 _ = withSmpServerConfigOn (transport @c) cfgV2 testPort $ \_ -> testSMPClient @c $ \h -> do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV2 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -185,7 +186,7 @@ testCreateSecure (ATransport t) = smpTest2 t $ \r s -> do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -249,7 +250,7 @@ testCreateDelete (ATransport t) = smpTest2 t $ \rh sh -> do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519 (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" @@ -320,7 +321,7 @@ stressTest (ATransport t) = (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519 (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair' rIds <- forM ([1 .. 50] :: [Int]) . const $ do - Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing) + Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe) pure rId let subscribeQueues h = forM_ rIds $ \rId -> do Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB) @@ -337,7 +338,7 @@ testAllowNewQueues t = testSMPClient @c $ \h -> do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing) + Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) pure () testDuplex :: ATransport -> Spec @@ -346,7 +347,7 @@ testDuplex (ATransport t) = smpTest2 t $ \alice bob -> do (arPub, arKey) <- C.generateSignatureKeyPair C.SEd448 (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing) + Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe) let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv -- aSnd ID is passed to Bob out-of-band @@ -362,7 +363,7 @@ testDuplex (ATransport t) = (brPub, brKey) <- C.generateSignatureKeyPair C.SEd448 (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing) + Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> encode bSnd) -- "reply_id ..." is ad-hoc, not a part of SMP protocol @@ -400,7 +401,7 @@ testSwitchSub (ATransport t) = smpTest3 t $ \rh1 rh2 sh -> do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing) + Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, _SEND "test1") (ok1, OK) #== "sent test message 1" @@ -845,7 +846,7 @@ createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (Se createAndSecureQueue h sPub = do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dhShared = C.dh' srvDh dhPriv Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) (rId', rId) #== "same queue ID" @@ -870,7 +871,7 @@ testTiming (ATransport t) = testSameTiming rh sh (goodKeySize, badKeySize, n) = do (rPub, rKey) <- generateKeys goodKeySize (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) @@ -1007,14 +1008,17 @@ sampleDhPubKey = "MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ=" sampleSig :: Maybe C.ASignature sampleSig = "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA==" +noAuth :: (Char, Maybe BasicAuth) +noAuth = ('A', Nothing) + syntaxTests :: ATransport -> Spec syntaxTests (ATransport t) = do it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN) describe "NEW" $ do it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX) it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX) - it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) - it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) + it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) + it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey, SMSubscribe)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) describe "KEY" $ do it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH) it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX) @@ -1049,4 +1053,4 @@ syntaxTests (ATransport t) = do (Maybe C.ASignature, ByteString, ByteString, smp) -> (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) -> Expectation - command >#> response = smpServerTest t command `shouldReturn` response + command >#> response = withFrozenCallStack $ smpServerTest t command `shouldReturn` response From 0cabe0690beee90f460ad7bada72294222e7e109 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sun, 10 Sep 2023 17:40:42 +0100 Subject: [PATCH 7/7] 5.4.0.2: xftp 1.1.1, ntf 1.6.1 --- package.yaml | 2 +- simplexmq.cabal | 2 +- src/Simplex/FileTransfer/Server/Main.hs | 2 +- src/Simplex/Messaging/Notifications/Server/Main.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/package.yaml b/package.yaml index fad82be22..3ed5b82fa 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplexmq -version: 5.3.0.1 +version: 5.4.0.2 synopsis: SimpleXMQ message broker description: | This package includes <./docs/Simplex-Messaging-Server.html server>, diff --git a/simplexmq.cabal b/simplexmq.cabal index ef75bdec0..dc9ab7e2e 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplexmq -version: 5.3.0.1 +version: 5.4.0.2 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 50f7c97c8..3f082e23c 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -33,7 +33,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) import Text.Read (readMaybe) xftpServerVersion :: String -xftpServerVersion = "1.0.1" +xftpServerVersion = "1.1.1" xftpServerCLI :: FilePath -> FilePath -> IO () xftpServerCLI cfgPath logPath = do diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index 46544af17..c141966d8 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -30,7 +30,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) import Text.Read (readMaybe) ntfServerVersion :: String -ntfServerVersion = "1.5.1" +ntfServerVersion = "1.6.1" defaultSMPBatchDelay :: Int defaultSMPBatchDelay = 10000