Compare commits

...
Author SHA1 Message Date
Alexander Bondarenko 689d87b5cf transport: add send-queueing timeout 2024-04-24 11:05:00 +03:00
Evgeny Poberezkin daa866f333 5.7.0.2 2024-04-22 18:59:33 +01:00
Evgeny Poberezkin fe28e02be7 agent: make version independent of PQ enqryption support (#1114)
* agent: make version independent of PQ enqryption support

* remove comment
2024-04-22 13:40:24 +01:00
Evgeny Poberezkin 1612a7e2c7 agent: reduce sizes for per-queue e2e encryption (#1113) 2024-04-22 09:25:03 +01:00
Evgeny Poberezkin b08314722d 5.7.0.1 2024-04-21 22:58:15 +01:00
Evgeny Poberezkin 2347b82b47 adjust timeouts and delayed response errors (#1112) 2024-04-21 22:57:07 +01:00
Evgeny Poberezkin 3d40393ae8 5.7.0.0 2024-04-20 18:20:18 +01:00
Alexander BondarenkoandEvgeny Poberezkin b98fdb672d transport: increase client timeouts, don't send command after timeout (#1110)
* transport: fix client handshake timeouts

* fix handshake timeout

* skip sending requests for timed out responses

* expose batch concurrency as PClient field

* move to NetworkConfig

* remove Request on timeout

* use record

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
2024-04-20 18:17:48 +01:00
Evgeny Poberezkin 3ba3172aaf xftp: enable ALPN in XFTP server (#1109) 2024-04-20 09:15:33 +01:00
Evgeny Poberezkin c00c223f3b remove (or make optional) client key from handshakes (#1104)
* remove (or make optional) client key from handshakes

* remove comment
2024-04-18 22:43:49 +01:00
2f43b43225 parameterize transport handle with transport peer to include server certificate (#1100)
* parameterize transport handle with transport peer to include server certificate

* include server certificate into THandle

* load server chain and sign key

* fix key type

* fix for 8.10

---------

Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
Co-authored-by: IC Rainbow <aenor.realm@gmail.com>
2024-04-17 17:46:22 +01:00
37 changed files with 447 additions and 426 deletions
+1 -1
View File
@@ -1,5 +1,5 @@
name: simplexmq
version: 5.6.2.2
version: 5.7.0.2
synopsis: SimpleXMQ message broker
description: |
This package includes <./docs/Simplex-Messaging-Server.html server>,
+1 -1
View File
@@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack
name: simplexmq
version: 5.6.2.2
version: 5.7.0.2
synopsis: SimpleXMQ message broker
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
<./docs/Simplex-Messaging-Client.html client> and
+13 -11
View File
@@ -51,7 +51,7 @@ import Simplex.Messaging.Protocol
RecipientId,
SenderId,
)
import Simplex.Messaging.Transport (ALPN, HandshakeError (VERSION), THandleAuth (..), THandleParams (..), TransportError (..), supportedParameters)
import Simplex.Messaging.Transport (ALPN, HandshakeError (VERSION), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters)
import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.Client
@@ -64,7 +64,7 @@ import UnliftIO.Directory
data XFTPClient = XFTPClient
{ http2Client :: HTTP2Client,
transportSession :: TransportSession FileResponse,
thParams :: THandleParams XFTPVersion,
thParams :: THandleParams XFTPVersion 'TClient,
config :: XFTPClientConfig
}
@@ -97,8 +97,8 @@ defaultXFTPClientConfig =
clientALPN = Just supportedXFTPhandshakes
}
getXFTPClient :: TVar ChaChaDRG -> TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
getXFTPClient g transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do
getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} disconnected = runExceptT $ do
let tcConfig = (transportClientConfig xftpNetworkConfig) {alpn = clientALPN}
http2Config = xftpHTTP2Config tcConfig config
username = proxyUsername transportSession
@@ -112,7 +112,7 @@ getXFTPClient g transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = VersionXFTP 1, thAuth = Nothing, implySessId = False, batch = True}
logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
thParams@THandleParams {thVersion} <- case sessionALPN of
Just "xftp/1" -> xftpClientHandshakeV1 g serverVRange keyHash http2Client thParams0
Just "xftp/1" -> xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
Nothing -> pure thParams0
_ -> throwError $ PCETransportError (TEHandshake VERSION)
logDebug $ "Client negotiated protocol: " <> tshow thVersion
@@ -120,19 +120,20 @@ getXFTPClient g transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN
atomically $ writeTVar clientVar $ Just c
pure c
xftpClientHandshakeV1 :: TVar ChaChaDRG -> VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP -> ExceptT XFTPClientError IO THandleParamsXFTP
xftpClientHandshakeV1 g serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do
shs <- getServerHandshake
xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient)
xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do
shs@XFTPServerHandshake {authPubKey = ck} <- getServerHandshake
(v, sk) <- processServerHandshake shs
(k, pk) <- atomically $ C.generateKeyPair g
sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash, authPubKey = k}
pure thParams0 {thAuth = Just THandleAuth {peerPubKey = sk, privKey = pk}, thVersion = v}
sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash}
pure thParams0 {thAuth = Just THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, sessSecret = Nothing}, thVersion = v}
where
getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake
getServerHandshake = do
let helloReq = H.requestNoBody "POST" "/" []
HTTP2Response {respBody = HTTP2Body {bodyHead = shsBody}} <-
liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c helloReq Nothing
liftHS . smpDecode =<< liftHS (C.unPad shsBody)
processServerHandshake :: XFTPServerHandshake -> ExceptT XFTPClientError IO (VersionXFTP, C.PublicKeyX25519)
processServerHandshake XFTPServerHandshake {xftpVersionRange, sessionId = serverSessId, authPubKey = serverAuth} = do
unless (sessionId == serverSessId) $ throwError $ PCEResponseError SESSION
case xftpVersionRange `compatibleVersion` serverVRange of
@@ -145,6 +146,7 @@ xftpClientHandshakeV1 g serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessi
_ -> throwError "bad certificate"
pubKey <- maybe (throwError "bad server key type") (`C.verifyX509` exact) serverKey
C.x509ToPublic (pubKey, []) >>= C.pubKey
sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO ()
sendClientHandshake chs = do
chs' <- liftHS $ C.pad (smpEncode chs) xftpBlockSize
let chsReq = H.requestBuilder "POST" "/" [] $ byteString chs'
+3 -4
View File
@@ -11,7 +11,6 @@ import Control.Logger.Simple (logInfo)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans (lift)
import Crypto.Random (ChaChaDRG)
import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as B
import Data.Text (Text)
@@ -61,15 +60,15 @@ newXFTPAgent config = do
type ME a = ExceptT XFTPClientAgentError IO a
getXFTPServerClient :: TVar ChaChaDRG -> XFTPClientAgent -> XFTPServer -> ME XFTPClient
getXFTPServerClient g XFTPClientAgent {xftpClients, config} srv = do
getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient
getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do
atomically getClientVar >>= either newXFTPClient waitForXFTPClient
where
connectClient :: ME XFTPClient
connectClient =
ExceptT $
first (XFTPClientAgentError srv)
<$> getXFTPClient g (1, srv, Nothing) (xftpConfig config) clientDisconnected
<$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected
clientDisconnected :: XFTPClient -> IO ()
clientDisconnected _ = do
+12 -13
View File
@@ -333,9 +333,9 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g)
digest <- liftIO $ getChunkDigest chunkSpec
let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest}
c <- withRetry retryCount $ getXFTPServerClient g a xftpServer
c <- withRetry retryCount $ getXFTPServerClient a xftpServer
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
withReconnect g a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
logInfo $ "uploaded chunk " <> tshow chunkNo
uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
let cs' = fromIntegral chunkSize : cs in (sum cs', cs')
@@ -445,7 +445,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch"
liftIO $ printNoNewLine "Decrypting file..."
CryptoFile path _ <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce $ fmap CF.plain . getFilePath
forM_ chunks $ acknowledgeFileChunk g a
forM_ chunks $ acknowledgeFileChunk a
whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
liftIO $ do
printNoNewLine $ "File downloaded: " <> path
@@ -456,7 +456,7 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..."
chunkPath <- uniqueCombine encPath $ show chunkNo
let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
withReconnect g a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec
withReconnect a server retryCount $ \c -> downloadXFTPChunk g c replicaKey (unChunkReplicaId replicaId) chunkSpec
logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath
downloaded <- atomically . stateTVar downloadedChunks $ \cs ->
let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs')
@@ -472,12 +472,12 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
ifM (doesDirectoryExist path) (uniqueCombine path name) $
ifM (doesFileExist path) (throwError "File already exists") (pure path)
_ -> (`uniqueCombine` name) . (</> "Downloads") =<< getHomeDirectory
acknowledgeFileChunk :: TVar ChaChaDRG -> XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
acknowledgeFileChunk g a FileChunk {replicas = replica : _} = do
acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
acknowledgeFileChunk a FileChunk {replicas = replica : _} = do
let FileChunkReplica {server, replicaId, replicaKey} = replica
c <- withRetry retryCount $ getXFTPServerClient g a server
c <- withRetry retryCount $ getXFTPServerClient a server
withRetry retryCount $ ackXFTPChunk c replicaKey (unChunkReplicaId replicaId)
acknowledgeFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
acknowledgeFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
printProgress :: String -> Int64 -> Int64 -> IO ()
printProgress s part total = printNoNewLine $ s <> " " <> show ((part * 100) `div` total) <> "%"
@@ -501,8 +501,7 @@ cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do
deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do
let FileChunkReplica {server, replicaId, replicaKey} = replica
g <- liftIO C.newRandom
withReconnect g a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId)
logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server
deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas"
@@ -570,9 +569,9 @@ prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) c
getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath
getEncPath path name = (`uniqueCombine` (name <> ".encrypted")) =<< maybe (liftIO getCanonicalTemporaryDirectory) pure path
withReconnect :: Show e => TVar ChaChaDRG -> XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a
withReconnect g a srv n run = withRetry n $ do
c <- withRetry n $ getXFTPServerClient g a srv
withReconnect :: Show e => XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a
withReconnect a srv n run = withRetry n $ do
c <- withRetry n $ getXFTPServerClient a srv
withExceptT (CLIError . show) (run c) `catchError` \e -> do
liftIO $ closeXFTPServerClient a srv
throwError e
+6 -6
View File
@@ -39,8 +39,8 @@ import Simplex.Messaging.Protocol
ProtocolErrorType (..),
ProtocolMsgTag (..),
ProtocolType (..),
RcvPublicDhKey,
RcvPublicAuthKey,
RcvPublicDhKey,
RecipientId,
SenderId,
SentRawTransmission,
@@ -48,14 +48,14 @@ import Simplex.Messaging.Protocol
SndPublicAuthKey,
Transmission,
TransmissionForAuth (..),
encodeTransmissionForAuth,
encodeTransmission,
encodeTransmissionForAuth,
messageTagP,
tDecodeParseValidate,
tEncodeBatch1,
tParse,
)
import Simplex.Messaging.Transport (THandleParams (..), TransportError (..))
import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..))
import Simplex.Messaging.Util ((<$?>))
xftpBlockSize :: Int
@@ -325,12 +325,12 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
Just Refl -> Just c
_ -> Nothing
xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey (corrId, fId, msg) = do
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg)
xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth (Just pKey) corrId tForAuth
xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> Transmission c -> Either TransportError ByteString
xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
xftpEncodeTransmission thParams (corrId, fId, msg) = do
let t = encodeTransmission thParams (corrId, fId, msg)
xftpEncodeBatch1 (Nothing, t)
@@ -339,7 +339,7 @@ xftpEncodeTransmission thParams (corrId, fId, msg) = do
xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize
xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
xftpDecodeTransmission thParams t = do
t' <- first (const BLOCK) $ C.unPad t
case tParse thParams t' of
+9 -9
View File
@@ -56,7 +56,7 @@ import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.Stats
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..))
import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..))
import Simplex.Messaging.Transport.Buffer (trimCR)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
@@ -75,7 +75,7 @@ import qualified UnliftIO.Exception as E
type M a = ReaderT XFTPEnv IO a
data XFTPTransportRequest = XFTPTransportRequest
{ thParams :: THandleParamsXFTP,
{ thParams :: THandleParamsXFTP 'TServer,
reqBody :: HTTP2Body,
request :: H.Request,
sendResponse :: H.Response -> IO ()
@@ -91,7 +91,7 @@ runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpSer
data Handshake
= HandshakeSent C.PrivateKeyX25519
| HandshakeAccepted THandleAuth VersionXFTP
| HandshakeAccepted (THandleAuth 'TServer) VersionXFTP
xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration} started = do
@@ -120,7 +120,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
Nothing -> pure () -- handshake response sent
Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here)
_ -> liftIO . sendResponse $ H.responseNoBody N.ok200 [] -- shouldn't happen: means server picked handshake protocol it doesn't know about
xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion))
xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion 'TServer))
xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse} = do
s <- atomically $ TM.lookup sessionId sessions
r <- runExceptT $ case s of
@@ -138,18 +138,18 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
shs <- encodeXftp hs
liftIO . sendResponse $ H.responseBuilder N.ok200 [] shs
pure Nothing
processClientHandshake privKey = do
processClientHandshake pk = do
unless (B.length bodyHead == xftpBlockSize) $ throwError HANDSHAKE
body <- liftHS $ C.unPad bodyHead
XFTPClientHandshake {xftpVersion, keyHash, authPubKey} <- liftHS $ smpDecode body
XFTPClientHandshake {xftpVersion, keyHash} <- liftHS $ smpDecode body
kh <- asks serverIdentity
unless (keyHash == kh) $ throwError HANDSHAKE
unless (xftpVersion `isCompatible` supportedFileServerVRange) $ throwError HANDSHAKE
let auth = THandleAuth {peerPubKey = authPubKey, privKey}
let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
atomically $ TM.insert sessionId (HandshakeAccepted auth xftpVersion) sessions
liftIO . sendResponse $ H.responseNoBody N.ok200 []
pure Nothing
sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion))
sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion 'TServer))
sendError err = do
runExceptT (encodeXftp err) >>= \case
Right bs -> liftIO . sendResponse $ H.responseBuilder N.ok200 [] bs
@@ -326,7 +326,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
data VerificationResult = VRVerified XFTPRequest | VRFailed
verifyXFTPTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
verifyXFTPTransmission auth_ tAuth authorized fId cmd =
case cmd of
FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
+3 -2
View File
@@ -19,7 +19,7 @@ import Options.Applicative
import Simplex.FileTransfer.Chunks
import Simplex.FileTransfer.Description (FileSize (..))
import Simplex.FileTransfer.Server (runXFTPServer)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
@@ -180,7 +180,8 @@ xftpServerCLI cfgPath logPath = do
serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
transportConfig =
defaultTransportServerConfig
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
alpn = Just supportedXFTPhandshakes
}
}
+14 -12
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
@@ -9,6 +10,7 @@
module Simplex.FileTransfer.Transport
( supportedFileServerVRange,
authCmdsXFTPVersion,
xftpClientHandshakeStub,
XFTPClientHandshake (..),
-- xftpClientHandshake,
@@ -51,7 +53,7 @@ import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol (CommandError)
import Simplex.Messaging.Transport (HandshakeError (..), SessionId, THandle (..), THandleParams (..), TransportError (..))
import Simplex.Messaging.Transport (HandshakeError (..), SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
import Simplex.Messaging.Transport.HTTP2.File
import Simplex.Messaging.Util (bshow)
import Simplex.Messaging.Version
@@ -76,20 +78,23 @@ type VersionRangeXFTP = VersionRange XFTPVersion
pattern VersionXFTP :: Word16 -> VersionXFTP
pattern VersionXFTP v = Version v
type THandleXFTP c = THandle XFTPVersion c
type THandleParamsXFTP = THandleParams XFTPVersion
type THandleXFTP c p = THandle XFTPVersion c p
type THandleParamsXFTP p = THandleParams XFTPVersion p
initialXFTPVersion :: VersionXFTP
initialXFTPVersion = VersionXFTP 1
authCmdsXFTPVersion :: VersionXFTP
authCmdsXFTPVersion = VersionXFTP 2
currentXFTPVersion :: VersionXFTP
currentXFTPVersion = VersionXFTP 2
supportedFileServerVRange :: VersionRangeXFTP
supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
-- XFTP protocol does not support handshake
xftpClientHandshakeStub :: c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c)
-- XFTP protocol does not use this handshake method
xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION
data XFTPServerHandshake = XFTPServerHandshake
@@ -103,19 +108,16 @@ data XFTPClientHandshake = XFTPClientHandshake
{ -- | agreed XFTP server protocol version
xftpVersion :: VersionXFTP,
-- | server identity - CA certificate fingerprint
keyHash :: C.KeyHash,
-- | pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
authPubKey :: C.PublicKeyX25519
keyHash :: C.KeyHash
}
instance Encoding XFTPClientHandshake where
smpEncode XFTPClientHandshake {xftpVersion, keyHash, authPubKey} =
smpEncode (xftpVersion, keyHash, authPubKey)
smpEncode XFTPClientHandshake {xftpVersion, keyHash} =
smpEncode (xftpVersion, keyHash)
smpP = do
(xftpVersion, keyHash) <- smpP
authPubKey <- smpP
Tail _compat <- smpP
pure XFTPClientHandshake {xftpVersion, keyHash, authPubKey}
pure XFTPClientHandshake {xftpVersion, keyHash}
instance Encoding XFTPServerHandshake where
smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey} =
+36 -44
View File
@@ -618,14 +618,14 @@ newConnAsync c userId corrId enableNtfs cMode pqInitKeys subMode = do
newConnNoQueues :: AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> PQSupport -> AM ConnId
newConnNoQueues c userId connId enableNtfs cMode pqSupport = do
g <- asks random
connAgentVersion <- asks $ maxVersion . ($ pqSupport) . smpAgentVRange . config
connAgentVersion <- asks $ maxVersion . smpAgentVRange . config
let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport}
withStore c $ \db -> createNewConn db g cData cMode
joinConnAsync :: AgentClient -> UserId -> ACorrId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
joinConnAsync c userId corrId enableNtfs cReqUri@CRInvitationUri {} cInfo pqSup subMode = do
withInvLock c (strEncode cReqUri) "joinConnAsync" $ do
lift (compatibleInvitationUri cReqUri pqSup) >>= \case
lift (compatibleInvitationUri cReqUri) >>= \case
Just (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible connAgentVersion) -> do
g <- asks random
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v)
@@ -729,16 +729,14 @@ newRcvConnSrv c userId connId enableNtfs cMode clientData pqInitKeys subMode srv
when enableNtfs $ do
ns <- asks ntfSupervisor
atomically $ sendNtfSubCommand ns (connId, NSCCreate)
let pqEnc = CR.connPQEncryption pqInitKeys
crData = ConnReqUriData SSSimplex (smpAgentVRange pqEnc) [qUri] clientData
e2eVRange = e2eEncryptVRange pqEnc
let crData = ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData
case cMode of
SCMContact -> pure (connId, CRContactUri crData)
SCMInvitation -> do
g <- asks random
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eVRange) (CR.initialPQEncryption pqInitKeys)
(pk1, pk2, pKem, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) (CR.initialPQEncryption pqInitKeys)
withStore' c $ \db -> createRatchetX3dhKeys db connId pk1 pk2 pKem
pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eVRange)
pure (connId, CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange)
joinConn :: AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM ConnId
joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
@@ -750,14 +748,14 @@ joinConn c userId connId enableNtfs cReq cInfo pqSupport subMode = do
startJoinInvitation :: UserId -> ConnId -> Bool -> ConnectionRequestUri 'CMInvitation -> PQSupport -> AM (Compatible VersionSMPA, ConnData, NewSndQueue, CR.Ratchet 'C.X448, CR.SndE2ERatchetParams 'C.X448)
startJoinInvitation userId connId enableNtfs cReqUri pqSup =
lift (compatibleInvitationUri cReqUri pqSup) >>= \case
lift (compatibleInvitationUri cReqUri) >>= \case
Just (qInfo, (Compatible e2eRcvParams@(CR.E2ERatchetParams v _ rcDHRr kem_)), aVersion@(Compatible connAgentVersion)) -> do
g <- asks random
let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v)
(pk1, pk2, pKem, e2eSndParams) <- liftIO $ CR.generateSndE2EParams g v (CR.replyKEM_ v kem_ pqSupport)
(_, rcDHRs) <- atomically $ C.generateKeyPair g
rcParams <- liftEitherWith cryptoError $ CR.pqX3dhSnd pk1 pk2 pKem e2eRcvParams
maxSupported <- asks $ maxVersion . ($ pqSup) . e2eEncryptVRange . config
maxSupported <- asks $ maxVersion . e2eEncryptVRange . config
let rcVs = CR.RatchetVersions {current = v, maxSupported}
rc = CR.initSndRatchet rcVs rcDHRr rcDHRs rcParams
q <- lift $ newSndQueue userId "" qInfo
@@ -767,29 +765,29 @@ startJoinInvitation userId connId enableNtfs cReqUri pqSup =
connRequestPQSupport :: AgentClient -> PQSupport -> ConnectionRequestUri c -> IO (Maybe (VersionSMPA, PQSupport))
connRequestPQSupport c pqSup cReq = withAgentEnv' c $ case cReq of
CRInvitationUri {} -> invPQSupported <$$> compatibleInvitationUri cReq pqSup
CRInvitationUri {} -> invPQSupported <$$> compatibleInvitationUri cReq
where
invPQSupported (_, Compatible (CR.E2ERatchetParams e2eV _ _ _), Compatible agentV) = (agentV, pqSup `CR.pqSupportAnd` versionPQSupport_ agentV (Just e2eV))
CRContactUri {} -> ctPQSupported <$$> compatibleContactUri cReq pqSup
CRContactUri {} -> ctPQSupported <$$> compatibleContactUri cReq
where
ctPQSupported (_, Compatible agentV) = (agentV, pqSup `CR.pqSupportAnd` versionPQSupport_ agentV Nothing)
compatibleInvitationUri :: ConnectionRequestUri 'CMInvitation -> PQSupport -> AM' (Maybe (Compatible SMPQueueInfo, Compatible (CR.RcvE2ERatchetParams 'C.X448), Compatible VersionSMPA))
compatibleInvitationUri (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) pqSup = do
compatibleInvitationUri :: ConnectionRequestUri 'CMInvitation -> AM' (Maybe (Compatible SMPQueueInfo, Compatible (CR.RcvE2ERatchetParams 'C.X448), Compatible VersionSMPA))
compatibleInvitationUri (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) = do
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
pure $
(,,)
<$> (qUri `compatibleVersion` smpClientVRange)
<*> (e2eRcvParamsUri `compatibleVersion` e2eEncryptVRange pqSup)
<*> (crAgentVRange `compatibleVersion` smpAgentVRange pqSup)
<*> (e2eRcvParamsUri `compatibleVersion` e2eEncryptVRange)
<*> (crAgentVRange `compatibleVersion` smpAgentVRange)
compatibleContactUri :: ConnectionRequestUri 'CMContact -> PQSupport -> AM' (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
compatibleContactUri (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) pqSup = do
compatibleContactUri :: ConnectionRequestUri 'CMContact -> AM' (Maybe (Compatible SMPQueueInfo, Compatible VersionSMPA))
compatibleContactUri (CRContactUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)}) = do
AgentConfig {smpClientVRange, smpAgentVRange} <- asks config
pure $
(,)
<$> (qUri `compatibleVersion` smpClientVRange)
<*> (crAgentVRange `compatibleVersion` smpAgentVRange pqSup)
<*> (crAgentVRange `compatibleVersion` smpAgentVRange)
versionPQSupport_ :: VersionSMPA -> Maybe CR.VersionE2E -> PQSupport
versionPQSupport_ agentV e2eV_ = PQSupport $ agentV >= pqdrSMPAgentVersion && maybe True (>= CR.pqRatchetE2EEncryptVersion) e2eV_
@@ -812,7 +810,7 @@ joinConnSrv c userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMod
void $ withStore' c $ \db -> deleteConn db Nothing connId'
throwError e
joinConnSrv c userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv =
lift (compatibleContactUri cReqUri pqSup) >>= \case
lift (compatibleContactUri cReqUri) >>= \case
Just (qInfo, vrsn) -> do
(connId', cReq) <- newConnSrv c userId connId enableNtfs SCMInvitation Nothing (CR.IKNoPQ pqSup) subMode srv
sendInvitation c userId qInfo vrsn cReq cInfo
@@ -1219,7 +1217,7 @@ enqueueMessageB c reqs = do
pure $ Right ((msgId, pqSecr), if null sqs' then Nothing else Just (cData, sqs', msgId))
where
storeSentMsg :: DB.Connection -> AgentConfig -> (ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage) -> IO (Either AgentErrorType ((ConnData, NonEmpty SndQueue, Maybe PQEncryption, MsgFlags, AMessage), InternalId, PQEncryption))
storeSentMsg db cfg req@(cData@ConnData {connId, pqSupport}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do
storeSentMsg db cfg req@(cData@ConnData {connId}, sq :| _, pqEnc_, msgFlags, aMessage) = fmap (first storeError) $ runExceptT $ do
let AgentConfig {smpAgentVRange, e2eEncryptVRange} = cfg
internalTs <- liftIO getCurrentTime
(internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
@@ -1227,10 +1225,9 @@ enqueueMessageB c reqs = do
agentMsg = AgentMessage privHeader aMessage
agentMsgStr = smpEncode agentMsg
internalHash = C.sha256Hash agentMsgStr
currentE2EVersion = maxVersion $ e2eEncryptVRange PQSupportOff
(encAgentMessage, pqEnc) <- agentRatchetEncrypt db cData agentMsgStr e2eEncUserMsgLength pqEnc_ currentE2EVersion
-- agent version range is determined by the connection suppport of PQ encryption, that is may be enabled when message is sent
let agentVersion = maxVersion $ smpAgentVRange pqSupport
currentE2EVersion = maxVersion e2eEncryptVRange
(encAgentMessage, pqEnc) <- agentRatchetEncrypt db cData agentMsgStr e2eEncAgentMsgLength pqEnc_ currentE2EVersion
let agentVersion = maxVersion smpAgentVRange
msgBody = smpEncode $ AgentMsgEnvelope {agentVersion, encAgentMessage}
msgType = agentMessageType agentMsg
msgData = SndMsgData {internalId, internalSndId, internalTs, msgType, msgFlags, msgBody, pqEncryption = pqEnc, internalHash, prevMsgHash}
@@ -1520,7 +1517,7 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni
let cData' = cData {pqSupport = pqSupport'} :: ConnData
AgentConfig {e2eEncryptVRange} <- asks config
g <- asks random
(pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion $ e2eEncryptVRange pqSupport') pqSupport'
(pk1, pk2, pKem, e2eParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqSupport'
enqueueRatchetKeyMsgs c cData' sqs e2eParams
withStore' c $ \db -> do
setConnRatchetSync db connId RSStarted
@@ -2046,7 +2043,7 @@ data ACKd = ACKd | ACKPending
-- | make sure to ACK or throw in each message processing branch
-- it cannot be finally, unfortunately, as sometimes it needs to be ACK+DEL
processSMPTransmission :: AgentClient -> ServerTransmission SMPVersion BrokerMsg -> AM ()
processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, sessId, rId, cmd) = do
processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v, sessId, isResponse, rId, cmd) = do
(rq, SomeConn _ conn) <- withStore c (\db -> getRcvConn db srv rId)
processSMP rq conn $ toConnData conn
where
@@ -2189,8 +2186,8 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
_ -> prohibited >> ack
_ -> prohibited >> ack
updateConnVersion :: Connection c -> ConnData -> VersionSMPA -> AM (Connection c)
updateConnVersion conn' cData'@ConnData {pqSupport} msgAgentVersion = do
aVRange <- asks $ ($ pqSupport) . smpAgentVRange . config
updateConnVersion conn' cData' msgAgentVersion = do
aVRange <- asks $ smpAgentVRange . config
let msgAVRange = fromMaybe (versionToRange msgAgentVersion) $ safeVersionRange (minVersion aVRange) msgAgentVersion
case msgAVRange `compatibleVersion` aVRange of
Just (Compatible av)
@@ -2221,7 +2218,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
ignored = pure "END from disconnected client - ignored"
_ -> do
logServer "<--" c srv rId $ "unexpected: " <> bshow cmd
notify . ERR $ BROKER (B.unpack $ strEncode srv) UNEXPECTED
notify . ERR $ BROKER (B.unpack $ strEncode srv) $ if isResponse then TIMEOUT else UNEXPECTED
where
notify :: forall e m. MonadIO m => AEntityI e => ACommand 'Agent e -> m ()
notify = atomically . notify'
@@ -2256,19 +2253,17 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
logServer "<--" c srv rId $ "MSG <CONF>:" <> logSecret srvMsgId
AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
let ConnData {pqSupport} = toConnData conn'
aVRange = smpAgentVRange pqSupport
e2eVRange = e2eEncryptVRange pqSupport
unless
(agentVersion `isCompatible` aVRange && smpClientVersion `isCompatible` smpClientVRange)
(agentVersion `isCompatible` smpAgentVRange && smpClientVersion `isCompatible` smpClientVRange)
(throwError $ AGENT A_VERSION)
case status of
New -> case (conn', e2eEncryption) of
-- party initiating connection
(RcvConnection _ _, Just (CR.AE2ERatchetParams _ e2eSndParams@(CR.E2ERatchetParams e2eVersion _ _ _))) -> do
unless (e2eVersion `isCompatible` e2eVRange) (throwError $ AGENT A_VERSION)
unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION)
(pk1, rcDHRs, pKem) <- withStore c (`getRatchetX3dhKeys` connId)
rcParams <- liftError cryptoError $ CR.pqX3dhRcv pk1 rcDHRs pKem e2eSndParams
let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eVRange}
let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eEncryptVRange}
pqSupport' = pqSupport `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just e2eVersion)
rc = CR.initRcvRatchet rcVs rcDHRs rcParams pqSupport'
g <- asks random
@@ -2450,7 +2445,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
ContactConnection {} -> do
-- show connection request even if invitaion via contact address is not compatible.
-- in case invitation not compatible, assume there is no PQ encryption support.
pqSupport <- lift $ maybe PQSupportOff pqSupported <$> compatibleInvitationUri connReq PQSupportOn
pqSupport <- lift $ maybe PQSupportOff pqSupported <$> compatibleInvitationUri connReq
g <- asks random
let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo = cInfo}
invId <- withStore c $ \db -> createInvitation db g newInv
@@ -2470,10 +2465,9 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), _v,
newRatchetKey e2eOtherPartyParams@(CR.E2ERatchetParams e2eVersion k1Rcv k2Rcv _) conn'@(DuplexConnection cData'@ConnData {lastExternalSndId, pqSupport} _ sqs) =
unlessM ratchetExists $ do
AgentConfig {e2eEncryptVRange} <- asks config
let connE2EVRange = e2eEncryptVRange pqSupport
unless (e2eVersion `isCompatible` connE2EVRange) (throwError $ AGENT A_VERSION)
unless (e2eVersion `isCompatible` e2eEncryptVRange) (throwError $ AGENT A_VERSION)
keys <- getSendRatchetKeys
let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion connE2EVRange}
let rcVs = CR.RatchetVersions {current = e2eVersion, maxSupported = maxVersion e2eEncryptVRange}
initRatchet rcVs keys
notifyAgreed
where
@@ -2579,8 +2573,7 @@ confirmQueue (Compatible agentVersion) c cData@ConnData {connId, pqSupport} sq s
where
mkConfirmation :: AgentMessage -> AM MsgBody
mkConfirmation aMessage = do
-- the version to be used when PQSupport is disabled
currentE2EVersion <- asks $ maxVersion . ($ PQSupportOff) . e2eEncryptVRange . config
currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config
withStore c $ \db -> runExceptT $ do
void . liftIO $ updateSndIds db connId
let pqEnc = CR.pqSupportToEnc pqSupport
@@ -2599,8 +2592,7 @@ enqueueConfirmation c cData sq connInfo e2eEncryption_ = do
storeConfirmation :: AgentClient -> ConnData -> SndQueue -> Maybe (CR.SndE2ERatchetParams 'C.X448) -> AgentMessage -> AM ()
storeConfirmation c cData@ConnData {connId, pqSupport, connAgentVersion = v} sq e2eEncryption_ agentMsg = do
-- the version to be used when PQSupport is disabled
currentE2EVersion <- asks $ maxVersion . ($ PQSupportOff) . e2eEncryptVRange . config
currentE2EVersion <- asks $ maxVersion . e2eEncryptVRange . config
withStore c $ \db -> runExceptT $ do
internalTs <- liftIO getCurrentTime
(internalId, internalSndId, prevMsgHash) <- liftIO $ updateSndIds db connId
@@ -2620,8 +2612,8 @@ enqueueRatchetKeyMsgs c cData (sq :| sqs) e2eEncryption = do
mapM_ (lift . enqueueSavedMessage c cData msgId) $ filter isActiveSndQ sqs
enqueueRatchetKey :: AgentClient -> ConnData -> SndQueue -> CR.RcvE2ERatchetParams 'C.X448 -> AM AgentMsgId
enqueueRatchetKey c cData@ConnData {connId, pqSupport} sq e2eEncryption = do
aVRange <- asks $ ($ pqSupport) . smpAgentVRange . config
enqueueRatchetKey c cData@ConnData {connId} sq e2eEncryption = do
aVRange <- asks $ smpAgentVRange . config
msgId <- storeRatchetKey $ maxVersion aVRange
lift $ submitPendingMsg c cData sq
pure $ unId msgId
+2 -3
View File
@@ -688,10 +688,9 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId
connectClient :: XFTPClientVar -> AM XFTPClient
connectClient v = do
cfg <- asks $ xftpCfg . config
g <- asks random
xftpNetworkConfig <- atomically $ getNetworkConfig c
liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $
X.getXFTPClient g tSess cfg {xftpNetworkConfig} $
X.getXFTPClient tSess cfg {xftpNetworkConfig} $
clientDisconnected v
clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
@@ -1008,7 +1007,7 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do
rcvPath <- getTempFilePath workDir
liftIO $ do
let tSess = (userId, srv, Nothing)
X.getXFTPClient g tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case
Right xftp -> withTestChunk filePath $ do
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+3 -3
View File
@@ -56,7 +56,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
import Simplex.Messaging.Client
import Simplex.Messaging.Client.Agent ()
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet (PQSupport, VersionRangeE2E, supportedE2EEncryptVRange)
import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Notifications.Transport (NTFVersion)
import Simplex.Messaging.Notifications.Types
@@ -117,8 +117,8 @@ data AgentConfig = AgentConfig
caCertificateFile :: FilePath,
privateKeyFile :: FilePath,
certificateFile :: FilePath,
e2eEncryptVRange :: PQSupport -> VersionRangeE2E,
smpAgentVRange :: PQSupport -> VersionRangeSMPA,
e2eEncryptVRange :: VersionRangeE2E,
smpAgentVRange :: VersionRangeSMPA,
smpClientVRange :: VersionRangeSMPC
}
+6 -11
View File
@@ -44,7 +44,7 @@ module Simplex.Messaging.Agent.Protocol
currentSMPAgentVersion,
supportedSMPAgentVRange,
e2eEncConnInfoLength,
e2eEncUserMsgLength,
e2eEncAgentMsgLength,
-- * SMP agent protocol types
ConnInfo,
@@ -272,16 +272,11 @@ deliveryRcptsSMPAgentVersion = VersionSMPA 4
pqdrSMPAgentVersion :: VersionSMPA
pqdrSMPAgentVersion = VersionSMPA 5
-- TODO v5.7 increase to 5
currentSMPAgentVersion :: VersionSMPA
currentSMPAgentVersion = VersionSMPA 4
currentSMPAgentVersion = VersionSMPA 5
-- TODO v5.7 remove dependency of version range on whether PQ support is needed
supportedSMPAgentVRange :: PQSupport -> VersionRangeSMPA
supportedSMPAgentVRange pq =
mkVersionRange duplexHandshakeSMPAgentVersion $ case pq of
PQSupportOn -> pqdrSMPAgentVersion
PQSupportOff -> currentSMPAgentVersion
supportedSMPAgentVRange :: VersionRangeSMPA
supportedSMPAgentVRange = mkVersionRange duplexHandshakeSMPAgentVersion currentSMPAgentVersion
-- it is shorter to allow all handshake headers,
-- including E2E (double-ratchet) parameters and
@@ -292,8 +287,8 @@ e2eEncConnInfoLength v = \case
PQSupportOn | v >= pqdrSMPAgentVersion -> 11122
_ -> 14848
e2eEncUserMsgLength :: VersionSMPA -> PQSupport -> Int
e2eEncUserMsgLength v = \case
e2eEncAgentMsgLength :: VersionSMPA -> PQSupport -> Int
e2eEncAgentMsgLength v = \case
-- reduced by 2222 (the increase of message ratchet header size)
PQSupportOn | v >= pqdrSMPAgentVersion -> 13634
_ -> 15856
+58 -45
View File
@@ -84,8 +84,8 @@ import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson.TH as J
@@ -107,19 +107,20 @@ import Simplex.Messaging.Protocol
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), runTransportClient)
import Simplex.Messaging.Transport.Client (SocksProxy, TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTransportClient)
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (bshow, raceAny_, threadDelay')
import Simplex.Messaging.Util (bshow, raceAny_, threadDelay', whenM)
import Simplex.Messaging.Version
import System.Timeout (timeout)
import UnliftIO (pooledMapConcurrentlyN)
-- | 'SMPClient' is a handle used to send commands to a specific SMP server.
--
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
data ProtocolClient v err msg = ProtocolClient
{ action :: Maybe (Async ()),
thParams :: THandleParams v,
thParams :: THandleParams v 'TClient,
sessionTs :: UTCTime,
client_ :: PClient v err msg
}
@@ -129,16 +130,16 @@ data PClient v err msg = PClient
transportSession :: TransportSession msg,
transportHost :: TransportHost,
tcpTimeout :: Int,
batchDelay :: Maybe Int,
rcvConcurrency :: Int,
pingErrorCount :: TVar Int,
clientCorrId :: TVar ChaChaDRG,
sentCommands :: TMap CorrId (Request err msg),
sndQ :: TBQueue ByteString,
sndQ :: TBQueue (TVar Bool, ByteString),
rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)),
msgQ :: Maybe (TBQueue (ServerTransmission v msg))
}
smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe THandleAuth -> STM SMPClient
smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> STM SMPClient
smpClientStub g sessionId thVersion thAuth = do
connected <- newTVar False
clientCorrId <- C.newRandomDRG g
@@ -165,7 +166,7 @@ smpClientStub g sessionId thVersion thAuth = do
transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing),
transportHost = "localhost",
tcpTimeout = 15_000_000,
batchDelay = Nothing,
rcvConcurrency = 8,
pingErrorCount,
clientCorrId,
sentCommands,
@@ -181,7 +182,7 @@ type SMPClient = ProtocolClient SMPVersion ErrorType BrokerMsg
type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg)
-- | Type synonym for transmission from some SPM server queue.
type ServerTransmission v msg = (TransportSession msg, Version v, SessionId, EntityId, msg)
type ServerTransmission v msg = (TransportSession msg, Version v, SessionId, Bool, EntityId, msg)
data HostMode
= -- | prefer (or require) onion hosts when connecting via SOCKS proxy
@@ -208,6 +209,8 @@ data NetworkConfig = NetworkConfig
tcpTimeout :: Int,
-- | additional timeout per kilobyte (1024 bytes) to be sent
tcpTimeoutPerKb :: Int64,
-- | break response timeouts into groups, so later responses get later deadlines
rcvConcurrency :: Int,
-- | TCP keep-alive options, Nothing to skip enabling keep-alive
tcpKeepAlive :: Maybe KeepAliveOpts,
-- | period for SMP ping commands (microseconds, 0 to disable)
@@ -228,9 +231,10 @@ defaultNetworkConfig =
hostMode = HMOnionViaSocks,
requiredHostMode = False,
sessionMode = TSMUser,
tcpConnectTimeout = 20_000_000,
tcpConnectTimeout = defaultTcpConnectTimeout,
tcpTimeout = 15_000_000,
tcpTimeoutPerKb = 5_000,
rcvConcurrency = 8,
tcpKeepAlive = Just defaultKeepAliveOpts,
smpPingInterval = 600_000_000, -- 10min
smpPingCount = 3,
@@ -238,8 +242,8 @@ defaultNetworkConfig =
}
transportClientConfig :: NetworkConfig -> TransportClientConfig
transportClientConfig NetworkConfig {socksProxy, tcpKeepAlive, logTLSErrors} =
TransportClientConfig {socksProxy, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
transportClientConfig NetworkConfig {socksProxy, tcpConnectTimeout, tcpKeepAlive, logTLSErrors} =
TransportClientConfig {socksProxy, tcpConnectTimeout, tcpKeepAlive, logTLSErrors, clientCredentials = Nothing, alpn = Nothing}
{-# INLINE transportClientConfig #-}
-- | protocol client configuration.
@@ -252,8 +256,8 @@ data ProtocolClientConfig v = ProtocolClientConfig
networkConfig :: NetworkConfig,
-- | client-server protocol version range
serverVRange :: VersionRange v,
-- | delay between sending batches of commands (microseconds)
batchDelay :: Maybe Int
-- | agree shared session secret (used in SMP proxy)
agreeSecret :: Bool
}
-- | Default protocol client configuration.
@@ -264,7 +268,7 @@ defaultClientConfig serverVRange =
defaultTransport = ("443", transport @TLS),
networkConfig = defaultNetworkConfig,
serverVRange,
batchDelay = Nothing
agreeSecret = False
}
{-# INLINE defaultClientConfig #-}
@@ -273,7 +277,8 @@ defaultSMPClientConfig = defaultClientConfig supportedClientSMPRelayVRange
{-# INLINE defaultSMPClientConfig #-}
data Request err msg = Request
{ entityId :: EntityId,
{ corrId :: CorrId,
entityId :: EntityId,
responseVar :: TMVar (Either (ProtocolClientError err) msg)
}
@@ -321,14 +326,14 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId)
-- A single queue can be used for multiple 'SMPClient' instances,
-- as 'SMPServerTransmission' includes server information.
getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig v -> Maybe (TBQueue (ServerTransmission v msg)) -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, agreeSecret} msgQ disconnected = do
case chooseTransportHost networkConfig (host srv) of
Right useHost ->
(atomically (mkProtocolClient useHost) >>= runClient useTransport useHost)
`catch` \(e :: IOException) -> pure . Left $ PCEIOError e
Left e -> pure $ Left e
where
NetworkConfig {tcpConnectTimeout, tcpTimeout, smpPingInterval} = networkConfig
NetworkConfig {tcpConnectTimeout, tcpTimeout, rcvConcurrency, smpPingInterval} = networkConfig
mkProtocolClient :: TransportHost -> STM (PClient v err msg)
mkProtocolClient transportHost = do
connected <- newTVar False
@@ -343,10 +348,10 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
transportSession,
transportHost,
tcpTimeout,
batchDelay,
pingErrorCount,
clientCorrId,
sentCommands,
rcvConcurrency,
sndQ,
rcvQ,
msgQ
@@ -375,7 +380,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO ()
client _ c cVar h = do
ks <- atomically $ C.generateKeyPair g
ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing
runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange) >>= \case
Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
Right th@THandle {params} -> do
@@ -387,10 +392,10 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
raceAny_ ([send c' th, process c', receive c' th] <> [ping c' | smpPingInterval > 0])
`finally` disconnected c'
send :: Transport c => ProtocolClient v err msg -> THandle v c -> IO ()
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPutLog h
send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= \(active, s) -> whenM (readTVarIO active) (void $ tPutLog h s)
receive :: Transport c => ProtocolClient v err msg -> THandle v c -> IO ()
receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
ping :: ProtocolClient v err msg -> IO ()
@@ -408,16 +413,16 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
process c = forever $ atomically (readTBQueue $ rcvQ $ client_ c) >>= mapM_ (processMsg c)
processMsg :: ProtocolClient v err msg -> SignedTransmission err msg -> IO ()
processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr)) =
if B.null $ bs corrId
then sendMsg respOrErr
else do
processMsg c@ProtocolClient {client_ = PClient {sentCommands}} (_, _, (corrId, entId, respOrErr))
| isResponse =
atomically (TM.lookup corrId sentCommands) >>= \case
Nothing -> sendMsg respOrErr
Just Request {entityId, responseVar} -> atomically $ do
TM.delete corrId sentCommands
putTMVar responseVar $ response entityId
| otherwise = sendMsg respOrErr
where
isResponse = not $ B.null $ bs corrId
response entityId
| entityId == entId =
case respOrErr of
@@ -428,7 +433,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
| otherwise = Left . PCEUnexpectedResponse $ bshow respOrErr
sendMsg :: Either err msg -> IO ()
sendMsg = \case
Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c entId msg) msgQ
Right msg -> atomically $ mapM_ (`writeTBQueue` serverTransmission c isResponse entId msg) msgQ
Left e -> putStrLn $ "SMP client error: " <> show e
proxyUsername :: TransportSession msg -> ByteString
@@ -525,11 +530,11 @@ processSUBResponse c (Response rId r) = case r of
Left e -> pure $ Left e
writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO ()
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c)
writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c False rId msg) (msgQ $ client_ c)
serverTransmission :: ProtocolClient v err msg -> RecipientId -> msg -> ServerTransmission v msg
serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} entityId message =
(transportSession, thVersion, sessionId, entityId, message)
serverTransmission :: ProtocolClient v err msg -> Bool -> RecipientId -> msg -> ServerTransmission v msg
serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} isResponse entityId message =
(transportSession, thVersion, sessionId, isResponse, entityId, message)
-- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue
--
@@ -677,23 +682,25 @@ streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockS
mapM_ (cb <=< sendBatch c) bs
sendBatch :: ProtocolClient v err msg -> TransportBatch (Request err msg) -> IO [Response err msg]
sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do
sendBatch c@ProtocolClient {client_ = PClient {rcvConcurrency, sndQ}} b = do
case b of
TBError e Request {entityId} -> do
putStrLn "send error: large message"
pure [Response entityId $ Left $ PCETransportError e]
TBTransmissions s n rs
| n > 0 -> do
atomically $ writeTBQueue sndQ s
mapConcurrently (getResponse c) rs
active <- newTVarIO True
atomically $ writeTBQueue sndQ (active, s)
pooledMapConcurrentlyN rcvConcurrency (getResponse c active) rs
| otherwise -> pure []
TBTransmission s r -> do
atomically $ writeTBQueue sndQ s
(: []) <$> getResponse c r
active <- newTVarIO True
atomically $ writeTBQueue sndQ (active, s)
(: []) <$> getResponse c active r
-- | Send Protocol command
sendProtocolCommand :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg
sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} pKey entId cmd =
sendProtocolCommand c@ProtocolClient {client_ = PClient {tcpTimeout, sndQ}, thParams = THandleParams {batch, blockSize}} pKey entId cmd =
ExceptT $ uncurry sendRecv =<< mkTransmission c (pKey, entId, cmd)
where
-- two separate "atomically" needed to avoid blocking
@@ -702,19 +709,25 @@ sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, thParams = THand
Left e -> pure . Left $ PCETransportError e
Right t
| B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg
| otherwise -> atomically (writeTBQueue sndQ s) >> response <$> getResponse c r
| otherwise -> do
active <- newTVarIO True
timeout tcpSendTimeout (atomically $ writeTBQueue sndQ (active, s)) >>= \case
Nothing -> pure $ Left PCEResponseTimeout
Just () -> response <$> getResponse c active r
where
-- TODO: move to configuration
tcpSendTimeout = tcpTimeout * 3 -- conservative timeout, allowing some asymmetry in uplink
s
| batch = tEncodeBatch1 t
| otherwise = tEncode t
-- TODO switch to timeout or TimeManager that supports Int64
getResponse :: ProtocolClient v err msg -> Request err msg -> IO (Response err msg)
getResponse ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} Request {entityId, responseVar} = do
getResponse :: ProtocolClient v err msg -> TVar Bool -> Request err msg -> IO (Response err msg)
getResponse ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount, sentCommands}} active Request {corrId, entityId, responseVar} = do
response <-
timeout tcpTimeout (atomically (takeTMVar responseVar)) >>= \case
Just r -> atomically (writeTVar pingErrorCount 0) $> r
Nothing -> pure $ Left PCEResponseTimeout
Nothing -> atomically (writeTVar active False >> TM.delete corrId sentCommands) $> Left PCEResponseTimeout
pure Response {entityId, response}
mkTransmission :: forall v err msg. ProtocolEncoding v err (ProtoCommand msg) => ProtocolClient v err msg -> ClientCommand msg -> IO (PCTransmission err msg)
@@ -729,17 +742,17 @@ mkTransmission ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCo
getNextCorrId = CorrId <$> C.randomBytes 24 clientCorrId -- also used as nonce
mkRequest :: CorrId -> STM (Request err msg)
mkRequest corrId = do
r <- Request entId <$> newEmptyTMVar
r <- Request corrId entId <$> newEmptyTMVar
TM.insert corrId r sentCommands
pure r
authTransmission :: Maybe THandleAuth -> Maybe C.APrivateAuthKey -> CorrId -> ByteString -> Either TransportError (Maybe TransmissionAuth)
authTransmission :: Maybe (THandleAuth 'TClient) -> Maybe C.APrivateAuthKey -> CorrId -> ByteString -> Either TransportError (Maybe TransmissionAuth)
authTransmission thAuth pKey_ (CorrId corrId) t = traverse authenticate pKey_
where
authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth
authenticate (C.APrivateAuthKey a pk) = case a of
C.SX25519 -> case thAuth of
Just THandleAuth {peerPubKey} -> Right $ TAAuthenticator $ C.cbAuthenticate peerPubKey pk (C.cbNonce corrId) t
Just THAuthClient {serverPeerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk (C.cbNonce corrId) t
Nothing -> Left TENoServerAuth
C.SEd25519 -> sign pk
C.SEd448 -> sign pk
+3 -8
View File
@@ -143,16 +143,11 @@ kdfX3DHE2EEncryptVersion = VersionE2E 2
pqRatchetE2EEncryptVersion :: VersionE2E
pqRatchetE2EEncryptVersion = VersionE2E 3
-- TODO v5.7 increase to 3
currentE2EEncryptVersion :: VersionE2E
currentE2EEncryptVersion = VersionE2E 2
currentE2EEncryptVersion = VersionE2E 3
-- TODO v5.7 remove dependency of version range on whether PQ encryption is used
supportedE2EEncryptVRange :: PQSupport -> VersionRangeE2E
supportedE2EEncryptVRange pq =
mkVersionRange kdfX3DHE2EEncryptVersion $ case pq of
PQSupportOn -> pqRatchetE2EEncryptVersion
PQSupportOff -> currentE2EEncryptVersion
supportedE2EEncryptVRange :: VersionRangeE2E
supportedE2EEncryptVRange = mkVersionRange kdfX3DHE2EEncryptVersion currentE2EEncryptVersion
data RatchetKEMState
= RKSProposed -- only KEM encapsulation key
@@ -152,7 +152,7 @@ instance Encoding ANewNtfEntity where
instance Protocol NTFVersion ErrorType NtfResponse where
type ProtoCommand NtfResponse = NtfCmd
type ProtoType NtfResponse = 'PNTF
protocolClientHandshake = ntfClientHandshake
protocolClientHandshake c _ks = ntfClientHandshake c
protocolPing = NtfCmd SSubscription PING
protocolError = \case
NRErr e -> Just e
@@ -47,7 +47,7 @@ import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server
import Simplex.Messaging.Server.Stats
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..))
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..))
import Simplex.Messaging.Transport.Server (runTransportServer, tlsServerCredentials)
import Simplex.Messaging.Util
import System.Exit (exitFailure)
@@ -218,7 +218,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge
receiveSMP :: M ()
receiveSMP = forever $ do
((_, srv, _), _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
((_, srv, _), _, _, _, ntfId, msg) <- atomically $ readTBQueue msgQ
let smpQueue = SMPQueueNtf srv ntfId
case msg of
SMP.NMSG nmsgNonce encNMsgMeta -> do
@@ -339,7 +339,7 @@ updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do
old <- atomically $ stateTVar tknStatus (,status)
when (old /= status) $ withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
runNtfClientTransport :: Transport c => THandleNTF c -> M ()
runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M ()
runNtfClientTransport th@THandle {params} = do
qSize <- asks $ clientQSize . config
ts <- liftIO getSystemTime
@@ -356,7 +356,7 @@ runNtfClientTransport th@THandle {params} = do
clientDisconnected :: NtfServerClient -> IO ()
clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
receive :: Transport c => THandleNTF c -> NtfServerClient -> M ()
receive :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> M ()
receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
ts <- liftIO $ tGet th
forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
@@ -371,7 +371,7 @@ receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ
where
write q t = atomically $ writeTBQueue q t
send :: Transport c => THandleNTF c -> NtfServerClient -> IO ()
send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO ()
send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
t <- atomically $ readTBQueue sndQ
void . liftIO $ tPut h [Right (Nothing, encodeTransmission params t)]
@@ -382,7 +382,7 @@ send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
data VerificationResult = VRVerified NtfRequest | VRFailed
verifyNtfTransmission :: Maybe (THandleAuth, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
verifyNtfTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do
st <- asks store
case cmd of
@@ -24,16 +24,16 @@ import Numeric.Natural
import Simplex.Messaging.Client.Agent
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Protocol
import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
import Simplex.Messaging.Notifications.Server.Push.APNS
import Simplex.Messaging.Notifications.Server.Stats
import Simplex.Messaging.Notifications.Server.Store
import Simplex.Messaging.Notifications.Server.StoreLog
import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport, THandleParams)
import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
import System.IO (IOMode (..))
import System.Mem.Weak (Weak)
@@ -161,13 +161,13 @@ data NtfRequest
data NtfServerClient = NtfServerClient
{ rcvQ :: TBQueue NtfRequest,
sndQ :: TBQueue (Transmission NtfResponse),
ntfThParams :: THandleParams NTFVersion,
ntfThParams :: THandleParams NTFVersion 'TServer,
connected :: TVar Bool,
rcvActiveAt :: TVar SystemTime,
sndActiveAt :: TVar SystemTime
}
newNtfServerClient :: Natural -> THandleParams NTFVersion -> SystemTime -> STM NtfServerClient
newNtfServerClient :: Natural -> THandleParams NTFVersion 'TServer -> SystemTime -> STM NtfServerClient
newNtfServerClient qSize ntfThParams ts = do
rcvQ <- newTBQueue qSize
sndQ <- newTBQueue qSize
@@ -13,8 +13,7 @@ import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Network.Socket (HostName)
import Options.Applicative
import Simplex.Messaging.Client (ProtocolClientConfig (..))
import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Notifications.Server (runNtfServer)
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
@@ -31,9 +30,6 @@ import System.FilePath (combine)
import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
import Text.Read (readMaybe)
defaultSMPBatchDelay :: Int
defaultSMPBatchDelay = 10000
ntfServerCLI :: FilePath -> FilePath -> IO ()
ntfServerCLI cfgPath logPath =
getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case
@@ -87,9 +83,7 @@ ntfServerCLI cfgPath logPath =
\# host is only used to print server address on start\n"
<> ("host: " <> host <> "\n")
<> ("port: " <> defaultServerPort <> "\n")
<> "log_tls_errors: off\n\
\# delay between command batches sent to SMP relays (microseconds), 0 to disable\n"
<> ("smp_batch_delay: " <> show defaultSMPBatchDelay <> "\n")
<> "log_tls_errors: off\n"
<> "websockets: off\n\n\
\[INACTIVE_CLIENTS]\n\
\# TTL and interval to check inactive clients\n\
@@ -111,8 +105,6 @@ ntfServerCLI cfgPath logPath =
enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
logStats = settingIsOn "STORE_LOG" "log_stats" ini
c = combine cfgPath . ($ defaultX509Config)
smpBatchDelay = readIniDefault defaultSMPBatchDelay "TRANSPORT" "smp_batch_delay" ini
batchDelay = if smpBatchDelay <= 0 then Nothing else Just smpBatchDelay
serverConfig =
NtfServerConfig
{ transports = iniTransports ini,
@@ -121,7 +113,7 @@ ntfServerCLI cfgPath logPath =
clientQSize = 64,
subQSize = 512,
pushQSize = 1048,
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {batchDelay}},
smpAgentCfg = defaultSMPClientAgentConfig,
apnsConfig = defaultAPNSPushClientConfig,
subsBatchSize = 900,
inactiveClientExpiration =
@@ -5,6 +5,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Simplex.Messaging.Notifications.Transport where
@@ -18,9 +19,9 @@ import qualified Data.X509 as X
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Transport
import Simplex.Messaging.Util (liftEitherWith)
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import Simplex.Messaging.Util (liftEitherWith)
ntfBlockSize :: Int
ntfBlockSize = 512
@@ -54,7 +55,7 @@ supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVers
supportedServerNTFVRange :: VersionRangeNTF
supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion
type THandleNTF c = THandle NTFVersion c
type THandleNTF c p = THandle NTFVersion c p
data NtfServerHandshake = NtfServerHandshake
{ ntfVersionRange :: VersionRangeNTF,
@@ -67,9 +68,7 @@ data NtfClientHandshake = NtfClientHandshake
{ -- | agreed SMP notifications server protocol version
ntfVersion :: VersionNTF,
-- | server identity - CA certificate fingerprint
keyHash :: C.KeyHash,
-- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
authPubKey :: Maybe C.PublicKeyX25519
keyHash :: C.KeyHash
}
instance Encoding NtfServerHandshake where
@@ -94,62 +93,61 @@ authEncryptCmdsP :: VersionNTF -> Parser a -> Parser (Maybe a)
authEncryptCmdsP v p = if v >= authBatchCmdsNTFVersion then Just <$> p else pure Nothing
instance Encoding NtfClientHandshake where
smpEncode NtfClientHandshake {ntfVersion, keyHash, authPubKey} =
smpEncode (ntfVersion, keyHash) <> encodeNtfAuthPubKey ntfVersion authPubKey
smpEncode NtfClientHandshake {ntfVersion, keyHash} =
smpEncode (ntfVersion, keyHash)
smpP = do
(ntfVersion, keyHash) <- smpP
-- TODO drop SMP v6: remove special parser and make key non-optional
authPubKey <- ntfAuthPubKeyP ntfVersion
pure NtfClientHandshake {ntfVersion, keyHash, authPubKey}
ntfAuthPubKeyP :: VersionNTF -> Parser (Maybe C.PublicKeyX25519)
ntfAuthPubKeyP v = if v >= authBatchCmdsNTFVersion then Just <$> smpP else pure Nothing
encodeNtfAuthPubKey :: VersionNTF -> Maybe C.PublicKeyX25519 -> ByteString
encodeNtfAuthPubKey v k
| v >= authBatchCmdsNTFVersion = maybe "" smpEncode k
| otherwise = ""
pure NtfClientHandshake {ntfVersion, keyHash}
-- | Notifcations server transport handshake.
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c)
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
let sk = C.signX509 serverSignKey $ C.publicToX509 k
sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange, authPubKey = Just sk}
getHandshake th >>= \case
NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = k'}
NtfClientHandshake {ntfVersion = v, keyHash}
| keyHash /= kh ->
throwError $ TEHandshake IDENTITY
| v `isCompatible` ntfVRange ->
pure $ ntfThHandle th v pk k'
pure $ ntfThHandleServer th v pk
| otherwise -> throwError $ TEHandshake VERSION
-- | Notifcations server client transport handshake.
ntfClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c)
ntfClientHandshake c (k, pk) keyHash ntfVRange = do
ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TClient)
ntfClientHandshake c keyHash ntfVRange = do
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
if sessionId /= sessId
then throwError TEBadSession
else case ntfVersionRange `compatibleVersion` ntfVRange of
Just (Compatible v) -> do
sk_ <- forM sk' $ \exact -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
serverKey <- getServerVerifyKey c
pubKey <- C.verifyX509 serverKey exact
C.x509ToPublic (pubKey, []) >>= C.pubKey
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = Just k}
pure $ ntfThHandle th v pk sk_
pubKey <- C.verifyX509 serverKey signedKey
(,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
pure $ ntfThHandleClient th v ck_
Nothing -> throwError $ TEHandshake VERSION
ntfThHandle :: forall c. THandleNTF c -> VersionNTF -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleNTF c
ntfThHandle th@THandle {params} v privKey k_ =
-- TODO drop SMP v6: make thAuth non-optional
let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
v3 = v >= authBatchCmdsNTFVersion
params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3}
in (th :: THandleNTF c) {params = params'}
ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer
ntfThHandleServer th v pk =
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
in ntfThHandle_ th v (Just thAuth)
ntfTHandle :: Transport c => c -> THandleNTF c
ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient
ntfThHandleClient th v ck_ =
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = Nothing}) <$> ck_
in ntfThHandle_ th v thAuth
ntfThHandle_ :: forall c p. THandleNTF c p -> VersionNTF -> Maybe (THandleAuth p) -> THandleNTF c p
ntfThHandle_ th@THandle {params} v thAuth =
-- TODO drop SMP v6: make thAuth non-optional
let v3 = v >= authBatchCmdsNTFVersion
params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3}
in (th :: THandleNTF c p) {params = params'}
ntfTHandle :: Transport c => c -> THandleNTF c p
ntfTHandle c = THandle {connection = c, params}
where
params = THandleParams {sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = VersionNTF 0, thAuth = Nothing, implySessId = False, batch = False}
+13 -13
View File
@@ -238,10 +238,10 @@ type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106
-- it is shorter to allow per-queue e2e encryption DH key in the "public" header
e2eEncConfirmationLength :: Int
e2eEncConfirmationLength = 15936
e2eEncConfirmationLength = 15920 -- 15881 .. 15976
e2eEncMessageLength :: Int
e2eEncMessageLength = 16032
e2eEncMessageLength = 16016 -- 16004 .. 16021
-- | SMP protocol clients
data Party = Recipient | Sender | Notifier
@@ -1075,7 +1075,7 @@ data CommandError
deriving (Eq, Read, Show)
-- | SMP transmission parser.
transmissionP :: THandleParams v -> Parser RawTransmission
transmissionP :: THandleParams v p -> Parser RawTransmission
transmissionP THandleParams {sessionId, implySessId} = do
authenticator <- smpP
authorized <- A.takeByteString
@@ -1089,10 +1089,10 @@ transmissionP THandleParams {sessionId, implySessId} = do
command <- A.takeByteString
pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command}
class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
type ProtoCommand msg = cmd | cmd -> msg
type ProtoType msg = (sch :: ProtocolType) | sch -> msg
protocolClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c)
protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c 'TClient)
protocolPing :: ProtoCommand msg
protocolError :: msg -> Maybe err
@@ -1308,7 +1308,7 @@ instance Encoding CommandError where
_ -> fail "bad command error type"
-- | Send signed SMP transmission to TCP transport.
tPut :: Transport c => THandle v c -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (batch params) (blockSize params)
where
tPutBatch :: TransportBatch () -> IO [Either TransportError ()]
@@ -1317,7 +1317,7 @@ tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (ba
TBTransmissions s n _ -> replicate n <$> tPutLog th s
TBTransmission s _ -> (: []) <$> tPutLog th s
tPutLog :: Transport c => THandle v c -> ByteString -> IO (Either TransportError ())
tPutLog :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
tPutLog th s = do
r <- tPutBlock th s
case r of
@@ -1383,7 +1383,7 @@ tEncodeBatch1 t = lenEncode 1 `B.cons` tEncodeForBatch t
-- tForAuth is lazy to avoid computing it when there is no key to sign
data TransmissionForAuth = TransmissionForAuth {tForAuth :: ~ByteString, tToSend :: ByteString}
encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> TransmissionForAuth
encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> TransmissionForAuth
encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId} t =
TransmissionForAuth {tForAuth, tToSend = if implySessId then t' else tForAuth}
where
@@ -1391,7 +1391,7 @@ encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId}
t' = encodeTransmission_ v t
{-# INLINE encodeTransmissionForAuth #-}
encodeTransmission :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> ByteString
encodeTransmission :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> ByteString
encodeTransmission THandleParams {thVersion = v, sessionId, implySessId} t =
if implySessId then t' else smpEncode sessionId <> t'
where
@@ -1404,11 +1404,11 @@ encodeTransmission_ v (CorrId corrId, queueId, command) =
{-# INLINE encodeTransmission_ #-}
-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
tGetParse :: Transport c => THandle v c -> IO (NonEmpty (Either TransportError RawTransmission))
tGetParse :: Transport c => THandle v c p -> IO (NonEmpty (Either TransportError RawTransmission))
tGetParse th@THandle {params} = eitherList (tParse params) <$> tGetBlock th
{-# INLINE tGetParse #-}
tParse :: THandleParams v -> ByteString -> NonEmpty (Either TransportError RawTransmission)
tParse :: THandleParams v p -> ByteString -> NonEmpty (Either TransportError RawTransmission)
tParse thParams@THandleParams {batch} s
| batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts
| otherwise = [tParse1 s]
@@ -1420,10 +1420,10 @@ eitherList :: (a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b
eitherList = either (\e -> [Left e])
-- | Receive client and server transmissions (determined by `cmd` type).
tGet :: forall v err cmd c. (ProtocolEncoding v err cmd, Transport c) => THandle v c -> IO (NonEmpty (SignedTransmission err cmd))
tGet :: forall v err cmd c p. (ProtocolEncoding v err cmd, Transport c) => THandle v c p -> IO (NonEmpty (SignedTransmission err cmd))
tGet th@THandle {params} = L.map (tDecodeParseValidate params) <$> tGetParse th
tDecodeParseValidate :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v -> Either TransportError RawTransmission -> SignedTransmission err cmd
tDecodeParseValidate :: forall v p err cmd. ProtocolEncoding v err cmd => THandleParams v p -> Either TransportError RawTransmission -> SignedTransmission err cmd
tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \case
Right RawTransmission {authenticator, authorized, sessId, corrId, entityId, command}
| implySessId || sessId == sessionId ->
+9 -9
View File
@@ -409,7 +409,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
logError "Unauthorized control port command"
hPutStrLn h "AUTH"
runClientTransport :: Transport c => THandleSMP c -> M ()
runClientTransport :: Transport c => THandleSMP c 'TServer -> M ()
runClientTransport th@THandle {params = THandleParams {thVersion, sessionId}} = do
q <- asks $ tbqSize . config
ts <- liftIO getSystemTime
@@ -457,7 +457,7 @@ cancelSub sub =
Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
_ -> return ()
receive :: Transport c => THandleSMP c -> Client -> M ()
receive :: Transport c => THandleSMP c 'TServer -> Client -> M ()
receive th@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
forever $ do
@@ -478,7 +478,7 @@ receive th@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActi
VRFailed -> Left (corrId, queueId, ERR AUTH)
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
send :: Transport c => THandleSMP c -> Client -> IO ()
send :: Transport c => THandleSMP c 'TServer -> Client -> IO ()
send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
forever $ do
@@ -493,7 +493,7 @@ send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do
NMSG {} -> 0
_ -> 1
disconnectTransport :: Transport c => THandle v c -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
disconnectTransport :: Transport c => THandle v c 'TServer -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disconnectTransport"
loop
@@ -514,7 +514,7 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
-- - the queue or party key do not exist.
-- In all cases, the time of the verification should depend only on the provided authorization type,
-- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result.
verifyTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult
verifyTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult
verifyTransmission auth_ tAuth authorized queueId cmd =
case cmd of
Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k
@@ -536,7 +536,7 @@ verifyTransmission auth_ tAuth authorized queueId cmd =
st <- asks queueStore
atomically $ getQueue st party queueId
verifyCmdAuthorization :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool
verifyCmdAuthorization :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool
verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth
where
verify :: C.APublicAuthKey -> TransmissionAuth -> Bool
@@ -548,12 +548,12 @@ verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAu
C.SX25519 -> verifyCmdAuth auth_ k s authorized
_ -> verifyCmdAuth auth_ dummyKeyX25519 s authorized `seq` False
verifyCmdAuth :: Maybe (THandleAuth, C.CbNonce) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> Bool
verifyCmdAuth :: Maybe (THandleAuth 'TServer, C.CbNonce) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> Bool
verifyCmdAuth auth_ k authenticator authorized = case auth_ of
Just (THandleAuth {privKey}, nonce) -> C.cbVerify k privKey nonce authenticator authorized
Just (THAuthServer {serverPrivKey = pk}, nonce) -> C.cbVerify k pk nonce authenticator authorized
Nothing -> False
dummyVerifyCmd :: Maybe (THandleAuth, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool
dummyVerifyCmd :: Maybe (THandleAuth 'TServer, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool
dummyVerifyCmd auth_ authorized = \case
TASignature (C.ASignature a s) -> C.verify' (dummySignKey a) s authorized
TAAuthenticator s -> verifyCmdAuth auth_ dummyKeyX25519 s authorized
+48 -30
View File
@@ -12,6 +12,7 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
-- |
@@ -77,7 +78,7 @@ module Simplex.Messaging.Transport
)
where
import Control.Applicative ((<|>))
import Control.Applicative (optional, (<|>))
import Control.Monad (forM)
import Control.Monad.Except
import Control.Monad.Trans.Except (throwE)
@@ -311,20 +312,20 @@ instance Transport TLS where
-- * SMP transport
-- | The handle for SMP encrypted transport connection over Transport.
data THandle v c = THandle
data THandle v c p = THandle
{ connection :: c,
params :: THandleParams v
params :: THandleParams v p
}
type THandleSMP c = THandle SMPVersion c
type THandleSMP c p = THandle SMPVersion c p
data THandleParams v = THandleParams
data THandleParams v p = THandleParams
{ sessionId :: SessionId,
blockSize :: Int,
-- | agreed server protocol version
thVersion :: Version v,
-- | peer public key for command authorization and shared secrets for entity ID encryption
thAuth :: Maybe THandleAuth,
thAuth :: Maybe (THandleAuth p),
-- | do NOT send session ID in transmission, but include it into signed message
-- based on protocol version
implySessId :: Bool,
@@ -333,10 +334,18 @@ data THandleParams v = THandleParams
batch :: Bool
}
data THandleAuth = THandleAuth
{ peerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key
privKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server)
}
data THandleAuth (p :: TransportPeer) where
THAuthClient ::
{ serverPeerPubKey :: C.PublicKeyX25519, -- used by the client to combine with client's private per-queue key
serverCertKey :: (X.CertificateChain, X.SignedExact X.PubKey), -- the key here is serverPeerPubKey signed with server certificate
sessSecret :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
} ->
THandleAuth 'TClient
THAuthServer ::
{ serverPrivKey :: C.PrivateKeyX25519, -- used by the server to combine with client's public per-queue key
sessSecret' :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
} ->
THandleAuth 'TServer
-- | TLS-unique channel binding
type SessionId = ByteString
@@ -390,7 +399,7 @@ encodeAuthEncryptCmds v k
| otherwise = ""
authEncryptCmdsP :: VersionSMP -> Parser a -> Parser (Maybe a)
authEncryptCmdsP v p = if v >= authCmdsSMPVersion then Just <$> p else pure Nothing
authEncryptCmdsP v p = if v >= authCmdsSMPVersion then optional p else pure Nothing
-- | Error of SMP encrypted transport over TCP.
data TransportError
@@ -438,13 +447,13 @@ serializeTransportError = \case
TEHandshake e -> "HANDSHAKE " <> bshow e
-- | Pad and send block to SMP transport.
tPutBlock :: Transport c => THandle v c -> ByteString -> IO (Either TransportError ())
tPutBlock :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
tPutBlock THandle {connection = c, params = THandleParams {blockSize}} block =
bimapM (const $ pure TELargeMsg) (cPut c) $
C.pad block blockSize
-- | Receive block from SMP transport.
tGetBlock :: Transport c => THandle v c -> IO (Either TransportError ByteString)
tGetBlock :: Transport c => THandle v c p -> IO (Either TransportError ByteString)
tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
msg <- cGet c blockSize
if B.length msg == blockSize
@@ -454,7 +463,7 @@ tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
-- | Server SMP transport handshake.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c)
smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TServer)
smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
sk = C.signX509 serverSignKey $ C.publicToX509 k
@@ -465,47 +474,56 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
| keyHash /= kh ->
throwE $ TEHandshake IDENTITY
| v `isCompatible` smpVRange ->
pure $ smpThHandle th v pk k'
pure $ smpThHandleServer th v pk k'
| otherwise -> throwE $ TEHandshake VERSION
-- | Client SMP transport handshake.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
smpClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c)
smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do
smpClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TClient)
smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange = do
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
if sessionId /= sessId
then throwE TEBadSession
else case smpVersionRange `compatibleVersion` smpVRange of
Just (Compatible v) -> do
sk_ <- forM authPubKey $ \(X.CertificateChain cert, exact) ->
ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) ->
liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
case cert of
[_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
_ -> throwError "bad certificate"
serverKey <- getServerVerifyKey c
pubKey <- C.verifyX509 serverKey exact
C.x509ToPublic (pubKey, []) >>= C.pubKey
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = Just k}
pure $ smpThHandle th v pk sk_
(,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_}
pure $ smpThHandleClient th v (snd <$> ks_) ck_
Nothing -> throwE $ TEHandshake VERSION
smpThHandle :: forall c. THandleSMP c -> VersionSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c
smpThHandle th@THandle {params} v privKey k_ =
-- TODO drop SMP v6: make thAuth non-optional
let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion}
in (th :: THandleSMP c) {params = params'}
smpThHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer
smpThHandleServer th v pk k_ =
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$> k_}
in smpThHandle_ th v (Just thAuth)
sendHandshake :: (Transport c, Encoding smp) => THandle v c -> smp -> ExceptT TransportError IO ()
smpThHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> Maybe C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient
smpThHandleClient th v pk_ ck_ =
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, sessSecret = C.dh' k <$> pk_}) <$> ck_
in smpThHandle_ th v thAuth
smpThHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> Maybe (THandleAuth p) -> THandleSMP c p
smpThHandle_ th@THandle {params} v thAuth =
-- TODO drop SMP v6: make thAuth non-optional
let params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion}
in (th :: THandleSMP c p) {params = params'}
sendHandshake :: (Transport c, Encoding smp) => THandle v c p -> smp -> ExceptT TransportError IO ()
sendHandshake th = ExceptT . tPutBlock th . smpEncode
-- ignores tail bytes to allow future extensions
getHandshake :: (Transport c, Encoding smp) => THandle v c -> ExceptT TransportError IO smp
getHandshake :: (Transport c, Encoding smp) => THandle v c p -> ExceptT TransportError IO smp
getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP =<<) <$> tGetBlock th
smpTHandle :: Transport c => c -> THandleSMP c
smpTHandle :: Transport c => c -> THandleSMP c p
smpTHandle c = THandle {connection = c, params}
where
params = THandleParams {sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = VersionSMP 0, thAuth = Nothing, implySessId = False, batch = True}
+23 -9
View File
@@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -10,6 +11,7 @@ module Simplex.Messaging.Transport.Client
runTLSTransportClient,
smpClientHandshake,
defaultSMPPort,
defaultTcpConnectTimeout,
defaultTransportClientConfig,
defaultSocksProxy,
TransportClientConfig (..),
@@ -52,6 +54,7 @@ import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.KeepAlive
import Simplex.Messaging.Util (bshow, (<$?>), catchAll, tshow)
import System.IO.Error
import System.Timeout (timeout)
import Text.Read (readMaybe)
import UnliftIO.Exception (IOException)
import qualified UnliftIO.Exception as E
@@ -112,6 +115,7 @@ instance IsString (NonEmpty TransportHost) where fromString = parseString strDec
data TransportClientConfig = TransportClientConfig
{ socksProxy :: Maybe SocksProxy,
tcpConnectTimeout :: Int,
tcpKeepAlive :: Maybe KeepAliveOpts,
logTLSErrors :: Bool,
clientCredentials :: Maybe (X.CertificateChain, T.PrivKey),
@@ -119,8 +123,12 @@ data TransportClientConfig = TransportClientConfig
}
deriving (Eq, Show)
-- time to resolve host, connect socket, set up TLS
defaultTcpConnectTimeout :: Int
defaultTcpConnectTimeout = 25_000_000
defaultTransportClientConfig :: TransportClientConfig
defaultTransportClientConfig = TransportClientConfig Nothing (Just defaultKeepAliveOpts) True Nothing Nothing
defaultTransportClientConfig = TransportClientConfig Nothing defaultTcpConnectTimeout (Just defaultKeepAliveOpts) True Nothing Nothing
clientTransportConfig :: TransportClientConfig -> TransportConfig
clientTransportConfig TransportClientConfig {logTLSErrors} =
@@ -131,7 +139,7 @@ runTransportClient :: Transport c => TransportClientConfig -> Maybe ByteString -
runTransportClient = runTLSTransportClient supportedParameters Nothing
runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpConnectTimeout, tcpKeepAlive, clientCredentials, alpn} proxyUsername host port keyHash client = do
serverCert <- newEmptyTMVarIO
let hostName = B.unpack $ strEncode host
clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials alpn serverCert
@@ -142,13 +150,19 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
sock <- connectTCP port
mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e)
let tCfg = clientTransportConfig cfg
connectTLS (Just hostName) tCfg clientParams sock >>= \tls -> do
chain <- atomically (tryTakeTMVar serverCert) >>= \case
Nothing -> do
logError "onServerCertificate didn't fire or failed to get cert chain"
closeTLS tls >> error "onServerCertificate failed"
Just c -> pure c
getClientConnection tCfg chain tls
tcpConnectTimeout `timeout` connectTLS (Just hostName) tCfg clientParams sock >>= \case
Nothing -> do
close sock
logError "connection timed out"
fail "connection timed out"
Just tls -> do
chain <-
atomically (tryTakeTMVar serverCert) >>= \case
Nothing -> do
logError "onServerCertificate didn't fire or failed to get cert chain"
closeTLS tls >> error "onServerCertificate failed"
Just c -> pure c
getClientConnection tCfg chain tls
client c `E.finally` closeConnection c
where
hostAddr = \case
@@ -24,7 +24,7 @@ import Numeric.Natural (Natural)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport (ALPN, SessionId, TLS (tlsALPN), getServerCerts, getServerVerifyKey, tlsUniq)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), runTLSTransportClient)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTLSTransportClient)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Util (eitherToMaybe)
import UnliftIO.STM
@@ -70,8 +70,16 @@ defaultHTTP2ClientConfig :: HTTP2ClientConfig
defaultHTTP2ClientConfig =
HTTP2ClientConfig
{ qSize = 64,
connTimeout = 10000000,
transportConfig = TransportClientConfig Nothing Nothing True Nothing Nothing,
connTimeout = defaultTcpConnectTimeout,
transportConfig =
TransportClientConfig
{ socksProxy = Nothing,
tcpConnectTimeout = defaultTcpConnectTimeout,
tcpKeepAlive = Nothing,
logTLSErrors = True,
clientCredentials = Nothing,
alpn = Nothing
},
bufferSize = defaultHTTP2BufferSize,
bodyHeadSize = 16384,
suportedTLSParams = http2TLSParams
+16 -25
View File
@@ -214,14 +214,13 @@ testDuplexConnection _ alice bob = testDuplexConnection' (alice, IKPQOn) (bob, P
testDuplexConnection' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testDuplexConnection' (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
pqSup = CR.pqEncToSupport pq
("1", "bob", Right (INV cReq)) <- alice #: ("1", "bob", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
("", "bob", Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` pqSup
pqSup' `shouldBe` CR.connPQEncryption aPQ
alice #: ("2", "bob", "LET " <> confId <> " 16\nalice's connInfo") #> ("2", "bob", OK)
bob <# ("", "alice", A.INFO pqSup "alice's connInfo")
bob <# ("", "alice", A.INFO bPQ "alice's connInfo")
bob <# ("", "alice", CON pq)
alice <# ("", "bob", CON pq)
-- message IDs 1 to 3 get assigned to control messages, so first MSG is assigned ID 4
@@ -253,15 +252,14 @@ testDuplexConnRandomIds _ alice bob = testDuplexConnRandomIds' (alice, IKPQOn) (
testDuplexConnRandomIds' :: (HasCallStack, Transport c) => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testDuplexConnRandomIds' (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
pqSup = CR.pqEncToSupport pq
("1", bobConn, Right (INV cReq)) <- alice #: ("1", "", "NEW T INV" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
("", bobConn', Right (A.CONF confId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` pqSup
pqSup' `shouldBe` CR.connPQEncryption aPQ
bobConn' `shouldBe` bobConn
alice #: ("2", bobConn, "LET " <> confId <> " 16\nalice's connInfo") =#> \case ("2", c, OK) -> c == bobConn; _ -> False
bob <# ("", aliceConn, A.INFO pqSup "alice's connInfo")
bob <# ("", aliceConn, A.INFO bPQ "alice's connInfo")
bob <# ("", aliceConn, CON pq)
alice <# ("", bobConn, CON pq)
alice #: ("2", bobConn, "SEND F :hello") #> ("2", bobConn, A.MID 4 pq)
@@ -291,17 +289,15 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do
("1", "alice_contact", Right (INV cReq)) <- alice #: ("1", "alice_contact", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
abPQ = pqConnectionMode aPQ bPQ
abPQSup = CR.pqEncToSupport abPQ
aPQMode = CR.connPQEncryption aPQ
bob #: ("11", "alice", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo") #> ("11", "alice", OK)
("", "alice_contact", Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` bPQ
("", "alice_contact", Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:)
alice #: ("2", "bob", "ACPT " <> aInvId <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("2", "bob", OK)
("", "alice", Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
pqSup'' `shouldBe` abPQSup
pqSup'' `shouldBe` bPQ
bob #: ("12", "alice", "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", "alice", OK)
alice <# ("", "bob", A.INFO abPQSup "bob's connInfo 2")
alice <# ("", "bob", A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2")
alice <# ("", "bob", CON abPQ)
bob <# ("", "alice", CON abPQ)
alice #: ("3", "bob", "SEND F :hi") #> ("3", "bob", A.MID 4 abPQ)
@@ -310,15 +306,13 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do
bob #: ("13", "alice", "ACK 4") #> ("13", "alice", OK)
let atPQ = pqConnectionMode aPQ tPQ
atPQSup = CR.pqEncToSupport atPQ
tom #: ("21", "alice", "JOIN T " <> cReq' <> enableKEMStr tPQ <> " subscribe 14\ntom's connInfo") #> ("21", "alice", OK)
("", "alice_contact", Right (A.REQ aInvId' pqSup3 _ "tom's connInfo")) <- (alice <#:)
pqSup3 `shouldBe` tPQ
("", "alice_contact", Right (A.REQ aInvId' PQSupportOn _ "tom's connInfo")) <- (alice <#:)
alice #: ("4", "tom", "ACPT " <> aInvId' <> enableKEMStr aPQMode <> " 16\nalice's connInfo") #> ("4", "tom", OK)
("", "alice", Right (A.CONF tConfId pqSup4 _ "alice's connInfo")) <- (tom <#:)
pqSup4 `shouldBe` atPQSup
pqSup4 `shouldBe` tPQ
tom #: ("22", "alice", "LET " <> tConfId <> " 16\ntom's connInfo 2") #> ("22", "alice", OK)
alice <# ("", "tom", A.INFO atPQSup "tom's connInfo 2")
alice <# ("", "tom", A.INFO (CR.connPQEncryption aPQ) "tom's connInfo 2")
alice <# ("", "tom", CON atPQ)
tom <# ("", "alice", CON atPQ)
alice #: ("5", "tom", "SEND F :hi there") #> ("5", "tom", A.MID 4 atPQ)
@@ -329,22 +323,20 @@ testContactConnection (alice, aPQ) (bob, bPQ) (tom, tPQ) = do
testContactConnRandomIds :: Transport c => (c, InitialKeys) -> (c, PQSupport) -> IO ()
testContactConnRandomIds (alice, aPQ) (bob, bPQ) = do
let pq = pqConnectionMode aPQ bPQ
pqSup = CR.pqEncToSupport pq
("1", aliceContact, Right (INV cReq)) <- alice #: ("1", "", "NEW T CON" <> pqConnModeStr aPQ <> " subscribe")
let cReq' = strEncode cReq
("11", aliceConn, Right OK) <- bob #: ("11", "", "JOIN T " <> cReq' <> enableKEMStr bPQ <> " subscribe 14\nbob's connInfo")
("", aliceContact', Right (A.REQ aInvId pqSup' _ "bob's connInfo")) <- (alice <#:)
pqSup' `shouldBe` bPQ
("", aliceContact', Right (A.REQ aInvId PQSupportOn _ "bob's connInfo")) <- (alice <#:)
aliceContact' `shouldBe` aliceContact
("2", bobConn, Right OK) <- alice #: ("2", "", "ACPT " <> aInvId <> enableKEMStr (CR.connPQEncryption aPQ) <> " 16\nalice's connInfo")
("", aliceConn', Right (A.CONF bConfId pqSup'' _ "alice's connInfo")) <- (bob <#:)
pqSup'' `shouldBe` pqSup
pqSup'' `shouldBe` bPQ
aliceConn' `shouldBe` aliceConn
bob #: ("12", aliceConn, "LET " <> bConfId <> " 16\nbob's connInfo 2") #> ("12", aliceConn, OK)
alice <# ("", bobConn, A.INFO pqSup "bob's connInfo 2")
alice <# ("", bobConn, A.INFO (CR.connPQEncryption aPQ) "bob's connInfo 2")
alice <# ("", bobConn, CON pq)
bob <# ("", aliceConn, CON pq)
@@ -358,7 +350,7 @@ testRejectContactRequest _ alice bob = do
("1", "a_contact", Right (INV cReq)) <- alice #: ("1", "a_contact", "NEW T CON subscribe")
let cReq' = strEncode cReq
bob #: ("11", "alice", "JOIN T " <> cReq' <> " subscribe 10\nbob's info") #> ("11", "alice", OK)
("", "a_contact", Right (A.REQ aInvId PQSupportOff _ "bob's info")) <- (alice <#:)
("", "a_contact", Right (A.REQ aInvId PQSupportOn _ "bob's info")) <- (alice <#:)
-- RJCT must use correct contact connection
alice #: ("2a", "bob", "RJCT " <> aInvId) #> ("2a", "bob", ERR $ CONN NOT_FOUND)
alice #: ("2b", "a_contact", "RJCT " <> aInvId) #> ("2b", "a_contact", OK)
@@ -571,12 +563,11 @@ connect' (h1, name1, pqMode1) (h2, name2, pqMode2) = do
("c1", _, Right (INV cReq)) <- h1 #: ("c1", name2, "NEW T INV" <> pqConnModeStr pqMode1 <> " subscribe")
let cReq' = strEncode cReq
pq = pqConnectionMode pqMode1 pqMode2
pqSup = CR.pqEncToSupport pq
h2 #: ("c2", name1, "JOIN T " <> cReq' <> enableKEMStr pqMode2 <> " subscribe 5\ninfo2") #> ("c2", name1, OK)
("", _, Right (A.CONF connId pqSup' _ "info2")) <- (h1 <#:)
pqSup' `shouldBe` pqSup
pqSup' `shouldBe` CR.connPQEncryption pqMode1
h1 #: ("c3", name2, "LET " <> connId <> " 5\ninfo1") #> ("c3", name2, OK)
h2 <# ("", name1, A.INFO pqSup "info1")
h2 <# ("", name1, A.INFO pqMode2 "info1")
h2 <# ("", name1, CON pq)
h1 <# ("", name2, CON pq)
+2 -2
View File
@@ -68,7 +68,7 @@ testE2ERatchetParams :: RcvE2ERatchetParamsUri 'C.X448
testE2ERatchetParams = E2ERatchetParamsUri (mkVersionRange (VersionE2E 1) (VersionE2E 1)) testDhPubKey testDhPubKey Nothing
testE2ERatchetParams12 :: RcvE2ERatchetParamsUri 'C.X448
testE2ERatchetParams12 = E2ERatchetParamsUri (supportedE2EEncryptVRange PQSupportOn) testDhPubKey testDhPubKey Nothing
testE2ERatchetParams12 = E2ERatchetParamsUri supportedE2EEncryptVRange testDhPubKey testDhPubKey Nothing
connectionRequest :: AConnectionRequestUri
connectionRequest =
@@ -82,7 +82,7 @@ connectionRequestCurrentRange :: AConnectionRequestUri
connectionRequestCurrentRange =
ACR SCMInvitation $
CRInvitationUri
connReqData {crAgentVRange = supportedSMPAgentVRange PQSupportOn, crSmpQueues = [queueV1, queueV1]}
connReqData {crAgentVRange = supportedSMPAgentVRange, crSmpQueues = [queueV1, queueV1]}
testE2ERatchetParams12
connectionRequestClientDataEmpty :: AConnectionRequestUri
+10 -10
View File
@@ -93,9 +93,9 @@ fullMsgLen :: Ratchet a -> Int
fullMsgLen Ratchet {rcSupportKEM, rcVersion} = headerLenLength + fullHeaderLen v rcSupportKEM + C.authTagSize + paddedMsgLen
where
v = current rcVersion
headerLenLength = case rcSupportKEM of
PQSupportOn | v >= pqRatchetE2EEncryptVersion -> 3 -- two bytes are added because of two Large used in new encoding
_ -> 1
headerLenLength
| v >= pqRatchetE2EEncryptVersion = 3 -- two bytes are added because of two Large used in new encoding
| otherwise = 1
testMessageHeader :: forall a. AlgorithmI a => VersionE2E -> C.SAlgorithm a -> Expectation
testMessageHeader v _ = do
@@ -520,7 +520,7 @@ initRatchets = do
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 Nothing e2eAlice
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
(_, pkBob3) <- atomically $ C.generateKeyPair g
let vs = testRatchetVersions PQSupportOff
let vs = testRatchetVersions
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOff
pure (alice, bob, encrypt' noSndKEM, decrypt' noRcvKEM, (\#>))
@@ -537,7 +537,7 @@ initRatchetsKEMProposed = do
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 Nothing e2eBob
(_, pkBob3) <- atomically $ C.generateKeyPair g
let vs = testRatchetVersions PQSupportOn
let vs = testRatchetVersions
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
@@ -555,7 +555,7 @@ initRatchetsKEMAccepted = do
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob
(_, pkBob3) <- atomically $ C.generateKeyPair g
let vs = testRatchetVersions PQSupportOn
let vs = testRatchetVersions
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
@@ -572,14 +572,14 @@ initRatchetsKEMProposedAgain = do
Right paramsBob <- pure $ pqX3dhSnd pkBob1 pkBob2 pKemParams_ e2eAlice
Right paramsAlice <- runExceptT $ pqX3dhRcv pkAlice1 pkAlice2 pKem_ e2eBob
(_, pkBob3) <- atomically $ C.generateKeyPair g
let vs = testRatchetVersions PQSupportOn
let vs = testRatchetVersions
bob = initSndRatchet vs (C.publicKey pkAlice2) pkBob3 paramsBob
alice = initRcvRatchet vs pkAlice2 paramsAlice PQSupportOn
pure (alice, bob, encrypt' hasSndKEM, decrypt' hasRcvKEM, (!#>))
testRatchetVersions :: PQSupport -> RatchetVersions
testRatchetVersions pq =
let v = maxVersion $ supportedE2EEncryptVRange pq
testRatchetVersions :: RatchetVersions
testRatchetVersions =
let v = maxVersion supportedE2EEncryptVRange
in RatchetVersions v v
encrypt_ :: AlgorithmI a => Maybe PQEncryption -> (TVar ChaChaDRG, Ratchet a, SkippedMsgKeys) -> ByteString -> IO (Either CryptoError (ByteString, Ratchet a, SkippedMsgDiff))
+32 -33
View File
@@ -187,9 +187,9 @@ agentCfgVPrev :: AgentConfig
agentCfgVPrev =
agentCfg
{ sndAuthAlg = C.AuthAlg C.SEd25519,
smpAgentVRange = \_ -> prevRange $ smpAgentVRange agentCfg PQSupportOff,
smpAgentVRange = prevRange $ smpAgentVRange agentCfg,
smpClientVRange = prevRange $ smpClientVRange agentCfg,
e2eEncryptVRange = \_ -> prevRange $ e2eEncryptVRange agentCfg PQSupportOff,
e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg,
smpCfg = smpCfgVPrev
}
@@ -198,14 +198,14 @@ agentCfgV7 :: AgentConfig
agentCfgV7 =
agentCfg
{ sndAuthAlg = C.AuthAlg C.SX25519,
smpAgentVRange = \_ -> V.mkVersionRange duplexHandshakeSMPAgentVersion $ max pqdrSMPAgentVersion currentSMPAgentVersion,
e2eEncryptVRange = \_ -> V.mkVersionRange CR.kdfX3DHE2EEncryptVersion $ max CR.pqRatchetE2EEncryptVersion CR.currentE2EEncryptVersion,
smpAgentVRange = V.mkVersionRange duplexHandshakeSMPAgentVersion $ max pqdrSMPAgentVersion currentSMPAgentVersion,
e2eEncryptVRange = V.mkVersionRange CR.kdfX3DHE2EEncryptVersion $ max CR.pqRatchetE2EEncryptVersion CR.currentE2EEncryptVersion,
smpCfg = smpCfgV7,
ntfCfg = ntfCfgV2
}
agentCfgRatchetVPrev :: AgentConfig
agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = \_ -> prevRange $ e2eEncryptVRange agentCfg PQSupportOff}
agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg}
prevRange :: VersionRange v -> VersionRange v
prevRange vr = vr {maxVersion = max (minVersion vr) (prevVersion $ maxVersion vr)}
@@ -546,28 +546,27 @@ testEnablePQEncryption =
(a, 4, "msg 1") \#>\ b
(b, 5, "msg 2") \#>\ a
-- 45 bytes is used by agent message envelope inside double ratchet message envelope
let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncUserMsgLength pqdrSMPAgentVersion pqEnc - 45) g'
let largeMsg g' pqEnc = atomically $ C.randomBytes (e2eEncAgentMsgLength pqdrSMPAgentVersion pqEnc - 45) g'
lrg <- largeMsg g PQSupportOff
(a, 6, lrg) \#>\ b
(b, 7, lrg) \#>\ a
-- enabling PQ encryption
(a, 8, lrg) \#>! b
(b, 9, lrg) \#>! a
-- switched to smaller envelopes (before reporting PQ encryption enabled)
sml <- largeMsg g PQSupportOn
-- fail because of message size
Left (A.CMD LARGE) <- tryError $ A.sendMessage ca bId PQEncOn SMP.noMsgFlags lrg
(11, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml
get ca =##> \case ("", connId, SENT 11) -> connId == bId; _ -> False
get cb =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False
ackMessage cb aId 10 Nothing
(9, PQEncOff) <- A.sendMessage ca bId PQEncOn SMP.noMsgFlags sml
get ca =##> \case ("", connId, SENT 9) -> connId == bId; _ -> False
get cb =##> \case ("", connId, MsgErr' 8 MsgSkipped {} PQEncOff msg') -> connId == aId && msg' == sml; _ -> False
ackMessage cb aId 8 Nothing
-- -- fail in reply to sync IDss
Left (A.CMD LARGE) <- tryError $ A.sendMessage cb aId PQEncOn SMP.noMsgFlags lrg
(12, PQEncOn) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml
get cb =##> \case ("", connId, SENT 12) -> connId == aId; _ -> False
get ca =##> \case ("", connId, MsgErr' 12 MsgSkipped {} PQEncOn msg') -> connId == bId && msg' == sml; _ -> False
ackMessage ca bId 12 Nothing
(10, PQEncOff) <- A.sendMessage cb aId PQEncOn SMP.noMsgFlags sml
get cb =##> \case ("", connId, SENT 10) -> connId == aId; _ -> False
get ca =##> \case ("", connId, MsgErr' 10 MsgSkipped {} PQEncOff msg') -> connId == bId && msg' == sml; _ -> False
ackMessage ca bId 10 Nothing
(a, 11, sml) \#>! b
-- PQ encryption now enabled
(b, 12, sml) !#>! a
(a, 13, sml) !#>! b
(b, 14, sml) !#>! a
-- disabling PQ encryption
@@ -797,8 +796,8 @@ testAllowConnectionClientRestart t = do
testIncreaseConnAgentVersion :: HasCallStack => ATransport -> IO ()
testIncreaseConnAgentVersion t = do
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB2
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
(aliceId, bobId) <- runRight $ do
(aliceId, bobId) <- makeConnection_ PQSupportOff alice bob
@@ -810,7 +809,7 @@ testIncreaseConnAgentVersion t = do
-- version doesn't increase if incompatible
disposeAgentClient alice
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
runRight_ $ do
subscribeConnection alice2 bobId
@@ -821,7 +820,7 @@ testIncreaseConnAgentVersion t = do
-- version increases if compatible
disposeAgentClient bob
bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB2
bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
runRight_ $ do
subscribeConnection bob2 aliceId
@@ -832,7 +831,7 @@ testIncreaseConnAgentVersion t = do
-- version doesn't decrease, even if incompatible
disposeAgentClient alice2
alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = \_ -> mkVersionRange 2 2} initAgentServers testDB
alice3 <- getSMPAgentClient' 5 agentCfg {smpAgentVRange = mkVersionRange 2 2} initAgentServers testDB
runRight_ $ do
subscribeConnection alice3 bobId
@@ -841,7 +840,7 @@ testIncreaseConnAgentVersion t = do
checkVersion bob2 aliceId 3
disposeAgentClient bob2
bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 1} initAgentServers testDB2
bob3 <- getSMPAgentClient' 6 agentCfg {smpAgentVRange = mkVersionRange 1 1} initAgentServers testDB2
runRight_ $ do
subscribeConnection bob3 aliceId
@@ -858,8 +857,8 @@ checkVersion c connId v = do
testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => ATransport -> IO ()
testIncreaseConnAgentVersionMaxCompatible t = do
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB2
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
(aliceId, bobId) <- runRight $ do
(aliceId, bobId) <- makeConnection_ PQSupportOff alice bob
@@ -871,7 +870,7 @@ testIncreaseConnAgentVersionMaxCompatible t = do
-- version increases to max compatible
disposeAgentClient alice
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
disposeAgentClient bob
bob2 <- getSMPAgentClient' 4 agentCfg {smpAgentVRange = supportedSMPAgentVRange} initAgentServers testDB2
@@ -886,8 +885,8 @@ testIncreaseConnAgentVersionMaxCompatible t = do
testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => ATransport -> IO ()
testIncreaseConnAgentVersionStartDifferentVersion t = do
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB2
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
(aliceId, bobId) <- runRight $ do
(aliceId, bobId) <- makeConnection_ PQSupportOff alice bob
@@ -899,7 +898,7 @@ testIncreaseConnAgentVersionStartDifferentVersion t = do
-- version increases to max compatible
disposeAgentClient alice
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB
alice2 <- getSMPAgentClient' 3 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
runRight_ $ do
subscribeConnection alice2 bobId
@@ -2454,8 +2453,8 @@ testDeliveryReceipts =
testDeliveryReceiptsVersion :: HasCallStack => ATransport -> IO ()
testDeliveryReceiptsVersion t = do
a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB
b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = \_ -> mkVersionRange 1 3} initAgentServers testDB2
a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
withSmpServerStoreMsgLogOn t testPort $ \_ -> do
(aId, bId) <- runRight $ do
(aId, bId) <- makeConnection_ PQSupportOff a b
@@ -2482,8 +2481,8 @@ testDeliveryReceiptsVersion t = do
subscribeConnection a' bId
subscribeConnection b' aId
exchangeGreetingsMsgId_ PQEncOff 6 a' bId b' aId
checkVersion a' bId 4
checkVersion b' aId 4
checkVersion a' bId 5
checkVersion b' aId 5
(8, PQEncOff) <- A.sendMessage a' bId PQEncOn SMP.noMsgFlags "hello"
get a' ##> ("", bId, SENT 8)
get b' =##> \case ("", c, Msg' 8 PQEncOff "hello") -> c == aId; _ -> False
+15 -5
View File
@@ -1,7 +1,9 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module CoreTests.BatchingTests (batchingTests) where
@@ -11,6 +13,9 @@ import Crypto.Random (ChaChaDRG)
import qualified Data.ByteString as B
import Data.ByteString.Char8 (ByteString)
import qualified Data.List.NonEmpty as L
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as XS
import qualified Data.X509.File as XF
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol
@@ -314,7 +319,7 @@ randomSEND_ a v sessId len = do
TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, sId, Cmd SSender $ SEND noMsgFlags msg)
pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) corrId tForAuth
testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion
testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion 'TClient
testTHandleParams v sessionId =
THandleParams
{ sessionId,
@@ -325,11 +330,16 @@ testTHandleParams v sessionId =
batch = True
}
testTHandleAuth :: VersionSMP -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe THandleAuth)
testTHandleAuth v g (C.APublicAuthKey a k) = case a of
testTHandleAuth :: VersionSMP -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe (THandleAuth 'TClient))
testTHandleAuth v g (C.APublicAuthKey a serverPeerPubKey) = case a of
C.SX25519 | v >= authCmdsSMPVersion -> do
(_, privKey) <- atomically $ C.generateKeyPair g
pure $ Just THandleAuth {peerPubKey = k, privKey}
ca <- head <$> XS.readCertificates "tests/fixtures/ca.crt"
serverCert <- head <$> XS.readCertificates "tests/fixtures/server.crt"
serverKey <- head <$> XF.readKeyFile "tests/fixtures/server.key"
signKey <- either error pure $ C.x509ToPrivate (serverKey, []) >>= C.privKey @C.APrivateSignKey
(serverAuthPub, _) <- atomically $ C.generateKeyPair @'C.X25519 g
let serverCertKey = (X.CertificateChain [serverCert, ca], C.signX509 signKey $ C.toPubKey C.publicToX509 serverAuthPub)
pure $ Just THAuthClient {serverPeerPubKey, serverCertKey, sessSecret = Nothing}
_ -> pure Nothing
randomSENDCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
+6 -8
View File
@@ -70,13 +70,11 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
ntfTestStoreLogFile :: FilePath
ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
testNtfClient :: Transport c => (THandleNTF c -> IO a) -> IO a
testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
testNtfClient client = do
Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> do
g <- C.newRandom
ks <- atomically $ C.generateKeyPair g
runExceptT (ntfClientHandshake h ks testKeyHash supportedClientNTFVRange) >>= \case
runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h ->
runExceptT (ntfClientHandshake h testKeyHash supportedClientNTFVRange) >>= \case
Right th -> client th
Left e -> error $ show e
@@ -139,7 +137,7 @@ withNtfServerOn t port' = withNtfServerThreadOn t port' . const
withNtfServer :: ATransport -> IO a -> IO a
withNtfServer t = withNtfServerOn t ntfTestPort
runNtfTest :: forall c a. Transport c => (THandleNTF c -> IO a) -> IO a
runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
ntfServerTest ::
@@ -150,7 +148,7 @@ ntfServerTest ::
IO (Maybe TransmissionAuth, ByteString, ByteString, NtfResponse)
ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
where
tPut' :: THandleNTF c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
tPut' :: THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
let t' = if implySessId then smpEncode (corrId, queueId, smp) else smpEncode (sessionId, corrId, queueId, smp)
[Right ()] <- tPut h [Right (sig, t')]
@@ -159,7 +157,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
pure (Nothing, corrId, qId, cmd)
ntfTest :: Transport c => TProxy c -> (THandleNTF c -> IO ()) -> Expectation
ntfTest :: Transport c => TProxy c -> (THandleNTF c 'TClient -> IO ()) -> Expectation
ntfTest _ test' = runNtfTest test' `shouldReturn` ()
data APNSMockRequest = APNSMockRequest
+3 -3
View File
@@ -6,8 +6,8 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module NtfServerTests where
@@ -72,13 +72,13 @@ pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command
deriving instance Eq NtfResponse
sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c -> (Maybe TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
sendRecvNtf h@THandle {params} (sgn, corrId, qId, cmd) = do
let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
Right () <- tPut1 h (sgn, tToSend)
tGet1 h
signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c -> C.APrivateAuthKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
signSendRecvNtf h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
Right () <- tPut1 h (authorize tForAuth, tToSend)
+2 -2
View File
@@ -34,7 +34,7 @@ import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Server (runSMPAgentBlocking)
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultSMPClientConfig, defaultNetworkConfig)
import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig, defaultSMPClientConfig)
import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth)
@@ -215,7 +215,7 @@ agentCfg =
certificateFile = "tests/fixtures/server.crt"
}
where
networkConfig = defaultNetworkConfig {tcpConnectTimeout = 3_000_000, tcpTimeout = 2_000_000}
networkConfig = defaultNetworkConfig {tcpConnectTimeout = 1_000_000, tcpTimeout = 2_000_000}
fastRetryInterval :: RetryInterval
fastRetryInterval = defaultReconnectInterval {initialInterval = 50_000}
+18 -20
View File
@@ -67,16 +67,14 @@ xit'' d t = do
ci <- runIO $ lookupEnv "CI"
(if ci == Just "true" then skip "skipped on CI" . it d else it d) t
testSMPClient :: Transport c => (THandleSMP c -> IO a) -> IO a
testSMPClient :: Transport c => (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClient = testSMPClientVR supportedClientSMPRelayVRange
testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c -> IO a) -> IO a
testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
testSMPClientVR vr client = do
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> do
g <- C.newRandom
ks <- atomically $ C.generateKeyPair g
runExceptT (smpClientHandshake h ks testKeyHash vr) >>= \case
runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h ->
runExceptT (smpClientHandshake h Nothing testKeyHash vr) >>= \case
Right th -> client th
Left e -> error $ show e
@@ -150,16 +148,16 @@ withSmpServer t = withSmpServerOn t testPort
withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a
withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const
runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandleSMP c -> IO a) -> IO a
runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c] -> IO a) -> IO a
runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestN = runSmpTestNCfg cfg supportedClientSMPRelayVRange
runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c] -> IO a) -> IO a
runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients []
where
run :: Int -> [THandleSMP c] -> IO a
run :: Int -> [THandleSMP c 'TClient] -> IO a
run 0 hs = test hs
run n hs = testSMPClientVR clntVR $ \h -> run (n - 1) (h : hs)
@@ -171,7 +169,7 @@ smpServerTest ::
IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg)
smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
where
tPut' :: THandleSMP c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
tPut' :: THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
let t' = if implySessId then smpEncode (corrId, queueId, smp) else smpEncode (sessionId, corrId, queueId, smp)
[Right ()] <- tPut h [Right (sig, t')]
@@ -180,33 +178,33 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
pure (Nothing, corrId, qId, cmd)
smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> IO ()) -> Expectation
smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest _ test' = runSmpTest test' `shouldReturn` ()
smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c] -> IO ()) -> Expectation
smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
smpTestN n test' = runSmpTestN n test' `shouldReturn` ()
smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2 = smpTest2Cfg cfg supportedClientSMPRelayVRange
smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` ()
where
_test :: HasCallStack => [THandleSMP c] -> IO ()
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
_test [h1, h2] = test' h1 h2
_test _ = error "expected 2 handles"
smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest3 _ test' = smpTestN 3 _test
where
_test :: HasCallStack => [THandleSMP c] -> IO ()
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
_test [h1, h2, h3] = test' h1 h2 h3
_test _ = error "expected 3 handles"
smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest4 _ test' = smpTestN 4 _test
where
_test :: HasCallStack => [THandleSMP c] -> IO ()
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
_test [h1, h2, h3, h4] = test' h1 h2 h3 h4
_test _ = error "expected 4 handles"
+18 -17
View File
@@ -78,13 +78,13 @@ pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh)
pattern Msg :: MsgId -> MsgBody -> BrokerMsg
pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
sendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c -> (Maybe TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
sendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
sendRecv h@THandle {params} (sgn, corrId, qId, cmd) = do
let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
Right () <- tPut1 h (sgn, tToSend)
tGet1 h
signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c -> C.APrivateAuthKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
signSendRecv h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
Right () <- tPut1 h (authorize tForAuth, tToSend)
@@ -93,17 +93,17 @@ signSendRecv h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
authorize t = case a of
C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t
C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t
C.SX25519 -> (\THandleAuth {peerPubKey} -> TAAuthenticator $ C.cbAuthenticate peerPubKey pk (C.cbNonce corrId) t) <$> thAuth params
C.SX25519 -> (\THAuthClient {serverPeerPubKey = k} -> TAAuthenticator $ C.cbAuthenticate k pk (C.cbNonce corrId) t) <$> thAuth params
#if !MIN_VERSION_base(4,18,0)
_sx448 -> undefined -- ghc8107 fails to the branch excluded by types
#endif
tPut1 :: Transport c => THandle v c -> SentRawTransmission -> IO (Either TransportError ())
tPut1 :: Transport c => THandle v c 'TClient -> SentRawTransmission -> IO (Either TransportError ())
tPut1 h t = do
[r] <- tPut h [Right t]
pure r
tGet1 :: (ProtocolEncoding v err cmd, Transport c) => THandle v c -> IO (SignedTransmission err cmd)
tGet1 :: (ProtocolEncoding v err cmd, Transport c) => THandle v c 'TClient -> IO (SignedTransmission err cmd)
tGet1 h = do
[r] <- liftIO $ tGet h
pure r
@@ -555,12 +555,12 @@ testWithStoreLog at@(ATransport t) =
logSize testStoreLogFile `shouldReturn` 1
removeFile testStoreLogFile
where
runTest :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> ThreadId -> Expectation
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> Expectation
runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
logSize :: FilePath -> IO Int
@@ -653,12 +653,12 @@ testRestoreMessages at@(ATransport t) =
removeFile testStoreMsgsFile
removeFile testServerStatsBackupFile
where
runTest :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> ThreadId -> Expectation
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> Expectation
runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
checkStats :: ServerStatsData -> [RecipientId] -> Int -> Int -> Expectation
@@ -727,15 +727,15 @@ testRestoreExpireMessages at@(ATransport t) =
Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile
_msgExpired `shouldBe` 2
where
runTest :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> ThreadId -> Expectation
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> Expectation
runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
createAndSecureQueue :: Transport c => THandleSMP c -> SndPublicAuthKey -> IO (SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret)
createAndSecureQueue :: Transport c => THandleSMP c 'TClient -> SndPublicAuthKey -> IO (SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret)
createAndSecureQueue h sPub = do
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
@@ -759,8 +759,8 @@ testTiming (ATransport t) =
timingTests :: [(C.AuthAlg, C.AuthAlg, Int)]
timingTests =
[ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519, 200), -- correct key type
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448, 150),
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519, 200),
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448, 150),
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519, 200),
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519, 200),
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd448, 150), -- correct key type
(C.AuthAlg C.SEd448, C.AuthAlg C.SX25519, 200),
@@ -770,7 +770,7 @@ testTiming (ATransport t) =
]
timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
similarTime t1 t2 = abs (t2 / t1 - 1) < 0.2 -- normally the difference between "no queue" and "wrong key" is less than 5%
testSameTiming :: forall c. Transport c => THandleSMP c -> THandleSMP c -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation
testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation
testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do
g <- C.newRandom
(rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g
@@ -791,10 +791,11 @@ testTiming (ATransport t) =
runTimingTest sh badKey sId $ _SEND "hello"
where
runTimingTest :: PartyI p => THandleSMP c -> C.APrivateAuthKey -> ByteString -> Command p -> IO ()
runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> ByteString -> Command p -> IO ()
runTimingTest h badKey qId cmd = do
threadDelay 100000
_ <- timeRepeat n $ do -- "warm up" the server
_ <- timeRepeat n $ do
-- "warm up" the server
Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd)
return ()
threadDelay 100000
+2 -4
View File
@@ -14,7 +14,6 @@ import Simplex.FileTransfer.Client
import Simplex.FileTransfer.Description
import Simplex.FileTransfer.Server (runXFTPServerBlocking)
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration, defaultInactiveClientExpiration, supportedXFTPhandshakes)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (XFTPServer)
import Simplex.Messaging.Transport (ALPN)
import Simplex.Messaging.Transport.Server
@@ -133,8 +132,7 @@ testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClient = testXFTPClientWith testXFTPClientConfig
testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a
testXFTPClientWith cfg client = do
g <- C.newRandom
getXFTPClient g (1, testXFTPServer, Nothing) cfg (\_ -> pure ()) >>= \case
testXFTPClientWith cfg client =
getXFTPClient (1, testXFTPServer, Nothing) cfg (\_ -> pure ()) >>= \case
Right c -> client c
Left e -> error $ show e
+1 -2
View File
@@ -219,8 +219,7 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
testInactiveClientExpiration :: Expectation
testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do
disconnected <- newEmptyTMVarIO
g <- liftIO C.newRandom
c <- ExceptT $ getXFTPClient g (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ())
c <- ExceptT $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ())
pingXFTP c
liftIO $ do
threadDelay 100000