mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-15 09:35:24 +00:00
Merge branch 'master' into proxy
This commit is contained in:
Evgeny Poberezkin
@@ -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,13 +120,12 @@ getXFTPClient g transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN
|
||||
atomically $ writeTVar clientVar $ Just c
|
||||
pure c
|
||||
|
||||
xftpClientHandshakeV1 :: TVar ChaChaDRG -> VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient)
|
||||
xftpClientHandshakeV1 g serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do
|
||||
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 THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, clientPrivKey = 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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -141,11 +141,11 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
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 = THAuthServer {clientPeerPubKey = authPubKey, serverPrivKey = pk}
|
||||
let auth = THAuthServer {serverPrivKey = pk, sessSecret' = Nothing}
|
||||
atomically $ TM.insert sessionId (HandshakeAccepted auth xftpVersion) sessions
|
||||
liftIO . sendResponse $ H.responseNoBody N.ok200 []
|
||||
pure Nothing
|
||||
|
||||
@@ -10,6 +10,7 @@
|
||||
|
||||
module Simplex.FileTransfer.Transport
|
||||
( supportedFileServerVRange,
|
||||
authCmdsXFTPVersion,
|
||||
xftpClientHandshakeStub,
|
||||
XFTPClientHandshake (..),
|
||||
-- xftpClientHandshake,
|
||||
@@ -83,14 +84,17 @@ 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 'TClient)
|
||||
-- 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
|
||||
@@ -104,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} =
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -136,7 +136,6 @@ data PClient v err msg = PClient
|
||||
transportSession :: TransportSession msg,
|
||||
transportHost :: TransportHost,
|
||||
tcpTimeout :: Int,
|
||||
batchDelay :: Maybe Int,
|
||||
pingErrorCount :: TVar Int,
|
||||
clientCorrId :: TVar ChaChaDRG,
|
||||
sentCommands :: TMap CorrId (Request err msg),
|
||||
@@ -172,7 +171,6 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
transportSession = (1, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001", Nothing),
|
||||
transportHost = "localhost",
|
||||
tcpTimeout = 15_000_000,
|
||||
batchDelay = Nothing,
|
||||
pingErrorCount,
|
||||
clientCorrId,
|
||||
sentCommands,
|
||||
@@ -259,8 +257,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.
|
||||
@@ -271,7 +269,7 @@ defaultClientConfig serverVRange =
|
||||
defaultTransport = ("443", transport @TLS),
|
||||
networkConfig = defaultNetworkConfig,
|
||||
serverVRange,
|
||||
batchDelay = Nothing
|
||||
agreeSecret = False
|
||||
}
|
||||
{-# INLINE defaultClientConfig #-}
|
||||
|
||||
@@ -328,7 +326,7 @@ 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)
|
||||
@@ -350,7 +348,6 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
transportSession,
|
||||
transportHost,
|
||||
tcpTimeout,
|
||||
batchDelay,
|
||||
pingErrorCount,
|
||||
clientCorrId,
|
||||
sentCommands,
|
||||
@@ -382,7 +379,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
|
||||
@@ -732,7 +729,7 @@ forwardSMPMessage c@ProtocolClient {thParams, client_ = PClient {clientCorrId =
|
||||
-- prepare params
|
||||
sessSecret <- case thAuth thParams of
|
||||
Nothing -> throwError $ PCEProtocolError INTERNAL -- different error - proxy didn't pass key?
|
||||
Just THAuthClient {serverPeerPubKey, clientPrivKey} -> pure $ C.dh' serverPeerPubKey clientPrivKey
|
||||
Just THAuthClient {sessSecret} -> maybe (throwError $ PCEProtocolError INTERNAL) pure sessSecret
|
||||
nonce <- liftIO . atomically $ C.randomCbNonce g
|
||||
-- wrap
|
||||
let fwdT = FwdTransmission {fwdCorrId, fwdKey, fwdTransmission}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -68,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
|
||||
@@ -95,21 +93,11 @@ 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 'TServer)
|
||||
@@ -118,16 +106,16 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
|
||||
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 $ ntfThHandleServer 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 'TClient)
|
||||
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
|
||||
@@ -138,18 +126,18 @@ ntfClientHandshake c (k, pk) keyHash ntfVRange = do
|
||||
serverKey <- getServerVerifyKey c
|
||||
pubKey <- C.verifyX509 serverKey signedKey
|
||||
(,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
|
||||
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = Just k}
|
||||
pure $ ntfThHandleClient th v pk ck_
|
||||
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
|
||||
pure $ ntfThHandleClient th v ck_
|
||||
Nothing -> throwError $ TEHandshake VERSION
|
||||
|
||||
ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleNTF c 'TServer
|
||||
ntfThHandleServer th v pk k_ =
|
||||
let thAuth = (\k -> THAuthServer {clientPeerPubKey = k, serverPrivKey = pk}) <$> k_
|
||||
in ntfThHandle_ th v thAuth
|
||||
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)
|
||||
|
||||
ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient
|
||||
ntfThHandleClient th v pk ck_ =
|
||||
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, clientPrivKey = pk}) <$> ck_
|
||||
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
|
||||
|
||||
@@ -1224,7 +1224,7 @@ transmissionP THandleParams {sessionId, implySessId} = do
|
||||
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 'TClient)
|
||||
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
|
||||
|
||||
|
||||
@@ -917,10 +917,9 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
|
||||
processForwardedCommand :: EncFwdTransmission -> M BrokerMsg
|
||||
processForwardedCommand (EncFwdTransmission s) = fmap (either id id) . runExceptT $ do
|
||||
-- TODO error
|
||||
THAuthServer {clientPeerPubKey, serverPrivKey} <- maybe (throwError $ ERR INTERNAL) pure thAuth
|
||||
-- TODO compute during handshake?
|
||||
let sessSecret = C.dh' clientPeerPubKey serverPrivKey
|
||||
proxyNonce = C.cbNonce $ bs corrId
|
||||
THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwError $ ERR INTERNAL) pure thAuth
|
||||
sessSecret <- maybe (throwError $ ERR INTERNAL) pure sessSecret'
|
||||
let proxyNonce = C.cbNonce $ bs corrId
|
||||
-- TODO error
|
||||
s' <- liftEitherWith internalErr $ C.cbDecrypt sessSecret proxyNonce s
|
||||
-- TODO error
|
||||
@@ -931,7 +930,7 @@ client thParams' clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ, sessi
|
||||
b <- liftEitherWith internalErr $ C.cbDecrypt clientSecret clientNonce et
|
||||
-- only allowing single forwarded transactions
|
||||
let t' = tDecodeParseValidate thParams' $ L.head $ tParse thParams' b
|
||||
clntThAuth = Just $ THAuthServer {clientPeerPubKey = fwdKey, serverPrivKey}
|
||||
clntThAuth = Just $ THAuthServer {serverPrivKey, sessSecret' = Just clientSecret}
|
||||
-- TODO error
|
||||
r <-
|
||||
lift (rejectOrVerify clntThAuth t') >>= \case
|
||||
|
||||
@@ -217,7 +217,7 @@ smpServerCLI cfgPath logPath =
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
|
||||
},
|
||||
controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini,
|
||||
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion}},
|
||||
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion, agreeSecret = True}},
|
||||
allowSMPProxy = True -- TODO: "get from INI"
|
||||
}
|
||||
|
||||
|
||||
@@ -79,7 +79,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)
|
||||
@@ -345,14 +345,14 @@ data THandleParams v p = THandleParams
|
||||
|
||||
data THandleAuth (p :: TransportPeer) where
|
||||
THAuthClient ::
|
||||
{ serverPeerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key
|
||||
serverCertKey :: (X.CertificateChain, X.SignedExact X.PubKey), -- the key here is clientPrivKey signed with server certificate
|
||||
clientPrivKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server)
|
||||
{ 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 ::
|
||||
{ clientPeerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key
|
||||
serverPrivKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server)
|
||||
{ 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
|
||||
|
||||
@@ -409,7 +409,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
|
||||
@@ -490,8 +490,8 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
|
||||
-- | 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 'TClient)
|
||||
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
|
||||
@@ -506,18 +506,18 @@ smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do
|
||||
serverKey <- getServerVerifyKey c
|
||||
pubKey <- C.verifyX509 serverKey exact
|
||||
(,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
|
||||
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = Just k}
|
||||
pure $ smpThHandleClient th v pk ck_
|
||||
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_}
|
||||
pure $ smpThHandleClient th v (snd <$> ks_) ck_
|
||||
Nothing -> throwE $ TEHandshake VERSION
|
||||
|
||||
smpThHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer
|
||||
smpThHandleServer th v pk k_ =
|
||||
let thAuth = (\k -> THAuthServer {clientPeerPubKey = k, serverPrivKey = pk}) <$> k_
|
||||
in smpThHandle_ th v thAuth
|
||||
let thAuth = THAuthServer {serverPrivKey = pk, sessSecret' = (`C.dh'` pk) <$> k_}
|
||||
in smpThHandle_ th v (Just thAuth)
|
||||
|
||||
smpThHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> 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, clientPrivKey = pk}) <$> ck_
|
||||
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
|
||||
|
||||
@@ -333,14 +333,13 @@ testTHandleParams v sessionId =
|
||||
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
|
||||
(_, clientPrivKey) <- atomically $ C.generateKeyPair @'C.X25519 g
|
||||
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, clientPrivKey}
|
||||
pure $ Just THAuthClient {serverPeerPubKey, serverCertKey, sessSecret = Nothing}
|
||||
_ -> pure Nothing
|
||||
|
||||
randomSENDCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
|
||||
|
||||
+2
-4
@@ -73,10 +73,8 @@ ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
|
||||
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
|
||||
|
||||
|
||||
+3
-5
@@ -78,10 +78,8 @@ testSMPClientVR vr client = do
|
||||
|
||||
testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
|
||||
testSMPClient_ host port vr client = do
|
||||
runTransportClient defaultTransportClientConfig Nothing host port (Just testKeyHash) $ \h -> do
|
||||
g <- C.newRandom
|
||||
ks <- atomically $ C.generateKeyPair g
|
||||
runExceptT (smpClientHandshake h ks testKeyHash vr) >>= \case
|
||||
runTransportClient defaultTransportClientConfig Nothing host port (Just testKeyHash) $ \h ->
|
||||
runExceptT (smpClientHandshake h Nothing testKeyHash vr) >>= \case
|
||||
Right th -> client th
|
||||
Left e -> error $ show e
|
||||
|
||||
@@ -125,7 +123,7 @@ proxyCfg =
|
||||
cfgV7
|
||||
{ allowSMPProxy = True,
|
||||
smpServerVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion,
|
||||
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion}}
|
||||
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion, agreeSecret = True}}
|
||||
}
|
||||
|
||||
withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
|
||||
+2
-4
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user