diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 2606d1bb9..a788e39c2 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs index f86de9afb..1dafc8108 100644 --- a/src/Simplex/FileTransfer/Client/Agent.hs +++ b/src/Simplex/FileTransfer/Client/Agent.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 3320e0a26..b3fa494ed 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index b3bee134f..7b6787a43 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 041069e98..27f1b8b95 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -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} = diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 4fbcae425..27223b12f 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 1c7196495..88afea56b 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -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} diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 2c3d2e4df..58a5e5193 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -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 diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index 2f6ee7e29..a8d16d85d 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -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 = diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index d4a4a4cbe..022403471 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 459f9a0df..3ad510481 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -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 diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 0991cd2a8..959339fad 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -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 diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 67064f1c7..45ec456b2 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -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" } diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 33aae5c60..001d77fa7 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -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 diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 3ca78a8c4..6350baa91 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -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) diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index d47722944..46a199777 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -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 diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index df2db2ae1..ad4d00266 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -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 diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 4e926f1fd..5f38cc639 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -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 diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 494f624fd..19713d8b1 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -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