dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-05-14 20:35:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into master-ghc9

Browse Source
This commit is contained in:
Evgeny Poberezkin
2023-09-10 18:00:33 +01:00
parent dc65197cfd 0cabe0690b
commit 887ccbcf6c
34 changed files with 744 additions and 329 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/smp-server/Main.hs
-1
View File
@@ -3,7 +3,6 @@
module Main where
import Control.Logger.Simple
import Data.Maybe
import Simplex.Messaging.Server.Main
import System.Environment
package.yaml
+1 -1
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 5.4.0.1
version: 5.4.0.2
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
simplexmq.cabal
+5 -1
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 5.4.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
@@ -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
@@ -89,11 +90,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 +539,7 @@ test-suite simplexmq-test
AgentTests.SQLiteTests
CLITests
CoreTests.BatchingTests
CoreTests.CryptoFileTests
CoreTests.CryptoTests
CoreTests.EncodingTests
CoreTests.ProtocolErrorTests
src/Simplex/FileTransfer/Agent.hs
+18 -12
View File
@@ -55,6 +55,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)
@@ -101,8 +103,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
@@ -111,7 +113,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
@@ -245,14 +248,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
@@ -279,8 +284,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
@@ -288,7 +293,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
@@ -334,16 +339,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
src/Simplex/FileTransfer/Chunks.hs
+35
View File
@@ -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 #-}
src/Simplex/FileTransfer/Client/Main.hs
+12 -15
View File
@@ -20,9 +20,6 @@ module Simplex.FileTransfer.Client.Main
cliSendFileOpts,
prepareChunkSizes,
prepareChunkSpecs,
chunkSize1,
chunkSize2,
chunkSize3,
maxFileSize,
fileSizeLen,
getChunkDigest,
@@ -51,6 +48,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
@@ -61,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 (..))
@@ -78,15 +78,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
@@ -104,6 +95,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
@@ -303,7 +295,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 = []}
@@ -436,7 +429,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
@@ -531,7 +524,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
src/Simplex/FileTransfer/Crypto.hs
+19 -22
View File
@@ -17,6 +17,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
@@ -24,20 +26,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)
@@ -50,28 +53,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
@@ -84,7 +87,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
@@ -94,7 +97,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)
@@ -107,10 +111,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)
src/Simplex/FileTransfer/Description.hs
+1 -12
View File
@@ -55,6 +55,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
@@ -238,18 +239,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
src/Simplex/FileTransfer/Server/Main.hs
+4 -3
View File
@@ -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
@@ -32,7 +33,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
import Text.Read (readMaybe)
xftpServerVersion :: String
xftpServerVersion = "1.1.0"
xftpServerVersion = "1.1.1"
xftpServerCLI :: FilePath -> FilePath -> IO ()
xftpServerCLI cfgPath logPath = do
@@ -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 =
src/Simplex/FileTransfer/Types.hs
+3 -2
View File
@@ -13,6 +13,7 @@ import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
import Simplex.FileTransfer.Description
import Simplex.Messaging.Agent.Protocol (RcvFileId, SndFileId)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (fromTextField_)
@@ -49,7 +50,7 @@ data RcvFile = RcvFile
chunks :: [RcvFileChunk],
prefixPath :: FilePath,
tmpPath :: Maybe FilePath,
savePath :: FilePath,
saveFile :: CryptoFile,
status :: RcvFileStatus,
deleted :: Bool
}
@@ -120,7 +121,7 @@ data SndFile = SndFile
key :: C.SbKey,
nonce :: C.CbNonce,
chunks :: [SndFileChunk],
filePath :: FilePath,
srcFile :: CryptoFile,
prefixPath :: Maybe FilePath,
status :: SndFileStatus,
deleted :: Bool
src/Simplex/Messaging/Agent.hs
+81 -76
View File
@@ -122,12 +122,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)
@@ -143,6 +143,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
@@ -150,7 +151,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
@@ -191,20 +192,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 ()
@@ -223,20 +224,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 ()
@@ -359,15 +360,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)
@@ -429,10 +430,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
@@ -464,10 +465,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
@@ -478,8 +479,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
@@ -487,10 +488,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 ()
@@ -500,13 +501,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
@@ -560,21 +561,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)
@@ -586,13 +589,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
@@ -611,8 +614,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
@@ -622,7 +625,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'
@@ -630,34 +633,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
@@ -679,13 +684,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
@@ -893,16 +898,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
@@ -1175,7 +1180,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 ()
@@ -1293,7 +1298,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'
@@ -2320,15 +2325,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
@@ -2338,12 +2343,12 @@ 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
pure $ AgentConnInfoReply (qInfo :| []) connInfo
qInfo <- createReplyQueue c cData sq subMode 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
src/Simplex/Messaging/Agent/Client.hs
+20 -11
View File
@@ -184,6 +184,7 @@ import Simplex.Messaging.Protocol
SMPMsgMeta (..),
SProtocolType (..),
SndPublicVerifyKey,
SubscriptionMode (..),
UserProtocol,
XFTPServer,
XFTPServerWithAuth,
@@ -231,6 +232,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 ()),
@@ -307,6 +309,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
@@ -343,6 +346,7 @@ newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do
subscrConns,
activeSubs,
pendingSubs,
removedSubs,
pendingMsgsQueued,
smpQueueMsgQueues,
smpQueueMsgDeliveries,
@@ -748,7 +752,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
@@ -822,8 +826,8 @@ mkSMPTSession q = mkTSession q.userId (qServer q) q.connId
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'
@@ -831,7 +835,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
@@ -859,8 +863,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
@@ -1347,14 +1352,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)
@@ -1364,9 +1370,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
src/Simplex/Messaging/Agent/Protocol.hs
+10 -9
View File
@@ -199,6 +199,7 @@ import Simplex.Messaging.Protocol
SMPServerWithAuth,
SndPublicVerifyKey,
SrvLoc (..),
SubscriptionMode,
legacyEncodeServer,
legacyServerP,
legacyStrEncodeServer,
@@ -315,9 +316,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
@@ -339,7 +340,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
@@ -1000,7 +1001,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
@@ -1739,8 +1740,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)
@@ -1801,9 +1802,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]
@@ -1908,7 +1909,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
src/Simplex/Messaging/Agent/Store/SQLite.hs
+21 -16
View File
@@ -259,6 +259,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
@@ -2084,8 +2085,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
@@ -2099,8 +2100,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
@@ -2140,15 +2141,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 <-
@@ -2337,13 +2340,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
@@ -2367,15 +2370,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 <-
src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs
+3 -1
View File
@@ -67,6 +67,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230701_delivery_receip
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230720_delete_expired_messages
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230722_indexes
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230814_indexes
import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
import Simplex.Messaging.Transport.Client (TransportHost)
@@ -99,7 +100,8 @@ schemaMigrations =
("m20230701_delivery_receipts", m20230701_delivery_receipts, Just down_m20230701_delivery_receipts),
("m20230720_delete_expired_messages", m20230720_delete_expired_messages, Just down_m20230720_delete_expired_messages),
("m20230722_indexes", m20230722_indexes, Just down_m20230722_indexes),
("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes)
("m20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
("m20230829_crypto_files", m20230829_crypto_files, Just down_m20230829_crypto_files)
]
-- | The list of migrations in ascending order by date
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230829_crypto_files.hs
+24
View File
@@ -0,0 +1,24 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230829_crypto_files where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20230829_crypto_files :: Query
m20230829_crypto_files =
[sql|
ALTER TABLE rcv_files ADD COLUMN save_file_key BLOB;
ALTER TABLE rcv_files ADD COLUMN save_file_nonce BLOB;
ALTER TABLE snd_files ADD COLUMN src_file_key BLOB;
ALTER TABLE snd_files ADD COLUMN src_file_nonce BLOB;
|]
down_m20230829_crypto_files :: Query
down_m20230829_crypto_files =
[sql|
ALTER TABLE rcv_files DROP COLUMN save_file_key;
ALTER TABLE rcv_files DROP COLUMN save_file_nonce;
ALTER TABLE snd_files DROP COLUMN src_file_key;
ALTER TABLE snd_files DROP COLUMN src_file_nonce;
|]
src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql
+5
View File
@@ -271,6 +271,8 @@ CREATE TABLE rcv_files(
error TEXT,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now')),
save_file_key BLOB,
save_file_nonce BLOB,
UNIQUE(rcv_file_entity_id)
);
CREATE TABLE rcv_file_chunks(
@@ -311,6 +313,9 @@ CREATE TABLE snd_files(
error TEXT,
created_at TEXT NOT NULL DEFAULT(datetime('now')),
updated_at TEXT NOT NULL DEFAULT(datetime('now'))
,
src_file_key BLOB,
src_file_nonce BLOB
);
CREATE TABLE snd_file_chunks(
snd_file_chunk_id INTEGER PRIMARY KEY,
src/Simplex/Messaging/Agent/TRcvQueues.hs
+1
View File
@@ -10,6 +10,7 @@ module Simplex.Messaging.Agent.TRcvQueues
deleteQueue,
getSessQueues,
getDelSessQueues,
qKey,
)
where
src/Simplex/Messaging/Client.hs
+3 -2
View File
@@ -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
src/Simplex/Messaging/Crypto/File.hs
+126
View File
@@ -0,0 +1,126 @@
{-# 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
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 (..), liftIO)
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
src/Simplex/Messaging/Crypto/Lazy.hs
+2
View File
@@ -17,6 +17,8 @@ module Simplex.Messaging.Crypto.Lazy
sbEncryptTailTag,
sbDecryptTailTag,
fastReplicate,
secretBox,
secretBoxTailTag,
SbState,
cbInit,
sbInit,
src/Simplex/Messaging/Notifications/Server/Main.hs
+1 -1
View File
@@ -30,7 +30,7 @@ import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
import Text.Read (readMaybe)
ntfServerVersion :: String
ntfServerVersion = "1.6.0"
ntfServerVersion = "1.6.1"
defaultSMPBatchDelay :: Int
defaultSMPBatchDelay = 10000
src/Simplex/Messaging/Protocol.hs
+33 -10
View File
@@ -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
src/Simplex/Messaging/Server.hs
+9 -6
View File
@@ -398,7 +398,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
@@ -459,10 +459,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
@@ -477,8 +477,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}
@@ -509,7 +509,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 =
src/Simplex/Messaging/Transport.hs
+1 -1
View File
@@ -98,7 +98,7 @@ smpBlockSize :: Int
smpBlockSize = 16384
supportedSMPServerVRange :: VersionRange
supportedSMPServerVRange = mkVersionRange 1 5
supportedSMPServerVRange = mkVersionRange 1 6
simplexMQVersion :: String
simplexMQVersion = showVersion SMQ.version
src/Simplex/Messaging/Version.hs
+1
View File
@@ -17,6 +17,7 @@ module Simplex.Messaging.Version
safeVersionRange,
versionToRange,
isCompatible,
isCompatibleRange,
proveCompatible,
compatibleVersion,
)
tests/AgentTests.hs
+27 -25
View File
@@ -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))
tests/AgentTests/FunctionalAPITests.hs
+86 -43
View File
@@ -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
@@ -67,11 +68,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
@@ -203,6 +210,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
@@ -355,8 +365,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)
@@ -390,10 +400,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")
@@ -435,9 +445,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'
@@ -450,8 +460,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"
@@ -465,9 +475,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
@@ -484,9 +494,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]
@@ -496,7 +506,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)
@@ -511,9 +521,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 ()
@@ -525,8 +535,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)
@@ -994,13 +1004,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)
@@ -1014,7 +1057,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
@@ -1025,7 +1068,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
@@ -1180,10 +1223,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
@@ -1224,7 +1267,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
@@ -1238,10 +1281,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
@@ -1279,9 +1322,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
@@ -1300,10 +1343,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)
@@ -1780,11 +1823,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
@@ -1959,8 +2002,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)
@@ -1968,7 +2011,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
tests/AgentTests/NotificationTests.hs
+9 -9
View File
@@ -31,7 +31,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)
@@ -218,8 +218,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")
@@ -281,9 +281,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
@@ -334,8 +334,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")
@@ -400,8 +400,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")
tests/CoreTests/CryptoFileTests.hs
+98
View File
@@ -0,0 +1,98 @@
{-# LANGUAGE OverloadedStrings #-}
module CoreTests.CryptoFileTests (cryptoFileTests) where
import AgentTests.FunctionalAPITests (runRight_)
import Control.Monad.Except
import Control.Monad.IO.Class
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
tests/ServerTests.hs
+17 -13
View File
@@ -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
tests/Test.hs
+2
View File
@@ -5,6 +5,7 @@ import AgentTests.SchemaDump (schemaDumpTest)
import CLITests
import Control.Logger.Simple
import CoreTests.BatchingTests
import CoreTests.CryptoFileTests
import CoreTests.CryptoTests
import CoreTests.EncodingTests
import CoreTests.ProtocolErrorTests
@@ -43,6 +44,7 @@ main = do
describe "Protocol error tests" protocolErrorTests
describe "Version range" versionRangeTests
describe "Encryption tests" cryptoTests
describe "Encrypted files tests" cryptoFileTests
describe "Retry interval tests" retryIntervalTests
describe "Util tests" utilTests
describe "SMP server via TLS" $ serverTests (transport @TLS)
tests/XFTPAgent.hs
+64 -35
View File
@@ -12,8 +12,8 @@ import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
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)
@@ -24,6 +24,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)
@@ -34,8 +36,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
@@ -56,22 +59,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"
@@ -79,10 +84,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
@@ -101,42 +105,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
@@ -151,7 +180,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
@@ -184,7 +213,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
@@ -199,7 +228,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
@@ -218,7 +247,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
@@ -226,7 +255,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
@@ -266,7 +295,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do
runRight_ $
void $ testReceive rcp rfd1 filePath
testXFTPAgentSendCleanup :: IO ()
testXFTPAgentSendCleanup :: HasCallStack => IO ()
testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do
filePath <- createRandomFile
@@ -275,7 +304,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
@@ -302,7 +331,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
@@ -333,11 +362,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
@@ -377,11 +406,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
@@ -389,7 +418,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
@@ -406,7 +435,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
tests/XFTPClient.hs
+2 -2
View File
@@ -57,10 +57,10 @@ withXFTPServerCfg cfg =
withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a
withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig
withXFTPServer :: IO a -> IO a
withXFTPServer :: HasCallStack => IO a -> IO a
withXFTPServer = withXFTPServerCfg testXFTPServerConfig . const
withXFTPServer2 :: IO a -> IO a
withXFTPServer2 :: HasCallStack => IO a -> IO a
withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} . const
xftpTestPort :: ServiceName