mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-14 22:45:06 +00:00
transport: require ALPN for extended handshakes (#1134)
* transport: require ALPN for extended handshakes * fix 8.10 build * rename --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
93fd424f86
commit
7a07076277
@@ -13,12 +13,9 @@ import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Unlift
|
||||
import Crypto.Random
|
||||
import Data.Default (def)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Word (Word32)
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
@@ -103,7 +100,7 @@ supportedXFTPhandshakes :: [ALPN]
|
||||
supportedXFTPhandshakes = ["xftp/1"]
|
||||
|
||||
newXFTPServerEnv :: XFTPServerConfig -> IO XFTPEnv
|
||||
newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do
|
||||
newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
|
||||
random <- liftIO C.newRandom
|
||||
store <- atomically newFileStore
|
||||
storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile
|
||||
@@ -112,17 +109,7 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
|
||||
forM_ fileSizeQuota $ \quota -> do
|
||||
logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used)
|
||||
when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!"
|
||||
tlsServerParams' <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
|
||||
let TransportServerConfig {alpn} = transportConfig config
|
||||
let tlsServerParams = case alpn of
|
||||
Nothing -> tlsServerParams'
|
||||
Just supported ->
|
||||
tlsServerParams'
|
||||
{ T.serverHooks =
|
||||
def
|
||||
{ T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported)
|
||||
}
|
||||
}
|
||||
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
|
||||
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
|
||||
serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime
|
||||
pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
@@ -49,7 +49,7 @@ runSMPAgentBlocking (ATransport t) cfg@AgentConfig {tcpPort, caCertificateFile,
|
||||
smpAgent :: forall c. Transport c => TProxy c -> ServiceName -> Env -> IO ()
|
||||
smpAgent _ port env = do
|
||||
-- tlsServerParams is not in Env to avoid breaking functional API w/t key and certificate generation
|
||||
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile
|
||||
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile Nothing
|
||||
clientId <- newTVarIO initClientId
|
||||
runTransportServer started port tlsServerParams defaultTransportServerConfig $ \(h :: c) -> do
|
||||
putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion
|
||||
|
||||
@@ -260,6 +260,7 @@ data ProtocolClientConfig v = ProtocolClientConfig
|
||||
defaultTransport :: (ServiceName, ATransport),
|
||||
-- | network configuration
|
||||
networkConfig :: NetworkConfig,
|
||||
clientALPN :: Maybe [ALPN],
|
||||
-- | client-server protocol version range
|
||||
serverVRange :: VersionRange v,
|
||||
-- | agree shared session secret (used in SMP proxy)
|
||||
@@ -267,19 +268,20 @@ data ProtocolClientConfig v = ProtocolClientConfig
|
||||
}
|
||||
|
||||
-- | Default protocol client configuration.
|
||||
defaultClientConfig :: VersionRange v -> ProtocolClientConfig v
|
||||
defaultClientConfig serverVRange =
|
||||
defaultClientConfig :: Maybe [ALPN] -> VersionRange v -> ProtocolClientConfig v
|
||||
defaultClientConfig clientALPN serverVRange =
|
||||
ProtocolClientConfig
|
||||
{ qSize = 64,
|
||||
defaultTransport = ("443", transport @TLS),
|
||||
networkConfig = defaultNetworkConfig,
|
||||
clientALPN,
|
||||
serverVRange,
|
||||
agreeSecret = False
|
||||
}
|
||||
{-# INLINE defaultClientConfig #-}
|
||||
|
||||
defaultSMPClientConfig :: ProtocolClientConfig SMPVersion
|
||||
defaultSMPClientConfig = defaultClientConfig supportedClientSMPRelayVRange
|
||||
defaultSMPClientConfig = defaultClientConfig (Just supportedSMPHandshakes) supportedClientSMPRelayVRange
|
||||
{-# INLINE defaultSMPClientConfig #-}
|
||||
|
||||
data Request err msg = Request
|
||||
@@ -332,7 +334,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, agreeSecret} msgQ disconnected = do
|
||||
getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serverVRange, agreeSecret} msgQ disconnected = do
|
||||
case chooseTransportHost networkConfig (host srv) of
|
||||
Right useHost ->
|
||||
(getCurrentTime >>= atomically . mkProtocolClient useHost >>= runClient useTransport useHost)
|
||||
@@ -370,7 +372,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
runClient :: (ServiceName, ATransport) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
|
||||
runClient (port', ATransport t) useHost c = do
|
||||
cVar <- newEmptyTMVarIO
|
||||
let tcConfig = transportClientConfig networkConfig
|
||||
let tcConfig = (transportClientConfig networkConfig) {alpn = clientALPN}
|
||||
username = proxyUsername transportSession
|
||||
action <-
|
||||
async $
|
||||
|
||||
@@ -10,7 +10,7 @@ import Data.Word (Word16)
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange)
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, supportedClientNTFVRange, supportedNTFHandshakes)
|
||||
import Simplex.Messaging.Protocol (ErrorType)
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
|
||||
@@ -19,7 +19,7 @@ type NtfClient = ProtocolClient NTFVersion ErrorType NtfResponse
|
||||
type NtfClientError = ProtocolClientError ErrorType
|
||||
|
||||
defaultNTFClientConfig :: ProtocolClientConfig NTFVersion
|
||||
defaultNTFClientConfig = defaultClientConfig supportedClientNTFVRange
|
||||
defaultNTFClientConfig = defaultClientConfig (Just supportedNTFHandshakes) supportedClientNTFVRange
|
||||
|
||||
ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519)
|
||||
ntfRegisterToken c pKey newTkn =
|
||||
|
||||
@@ -34,7 +34,7 @@ import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams)
|
||||
import System.IO (IOMode (..))
|
||||
import System.Mem.Weak (Weak)
|
||||
import UnliftIO.STM
|
||||
@@ -84,7 +84,7 @@ data NtfEnv = NtfEnv
|
||||
}
|
||||
|
||||
newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
|
||||
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile} = do
|
||||
newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsConfig, storeLogFile, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
|
||||
random <- liftIO C.newRandom
|
||||
store <- atomically newNtfStore
|
||||
logInfo "restoring subscriptions..."
|
||||
@@ -92,7 +92,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo
|
||||
logInfo "restored subscriptions"
|
||||
subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg random
|
||||
pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig
|
||||
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile
|
||||
tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
|
||||
Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile
|
||||
serverStats <- atomically . newNtfServerStats =<< liftIO getCurrentTime
|
||||
pure NtfEnv {config, subscriber, pushServer, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
@@ -18,7 +18,7 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Server (runNtfServer)
|
||||
import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration)
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig)
|
||||
import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
|
||||
import Simplex.Messaging.Notifications.Transport (supportedNTFHandshakes, supportedServerNTFVRange)
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer)
|
||||
import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
@@ -133,7 +133,8 @@ ntfServerCLI cfgPath logPath =
|
||||
ntfServerVRange = supportedServerNTFVRange,
|
||||
transportConfig =
|
||||
defaultTransportServerConfig
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
|
||||
alpn = Just supportedNTFHandshakes
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@@ -52,9 +52,15 @@ currentServerNTFVersion = VersionNTF 2
|
||||
supportedClientNTFVRange :: VersionRangeNTF
|
||||
supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion
|
||||
|
||||
legacyServerNTFVRange :: VersionRangeNTF
|
||||
legacyServerNTFVRange = mkVersionRange initialNTFVersion initialNTFVersion
|
||||
|
||||
supportedServerNTFVRange :: VersionRangeNTF
|
||||
supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion
|
||||
|
||||
supportedNTFHandshakes :: [ALPN]
|
||||
supportedNTFHandshakes = ["ntf/1"]
|
||||
|
||||
type THandleNTF c p = THandle NTFVersion c p
|
||||
|
||||
data NtfServerHandshake = NtfServerHandshake
|
||||
@@ -104,12 +110,13 @@ ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPa
|
||||
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}
|
||||
let ntfVersionRange = maybe legacyServerNTFVRange (const ntfVRange) $ getSessionALPN c
|
||||
sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange, authPubKey = Just sk}
|
||||
getHandshake th >>= \case
|
||||
NtfClientHandshake {ntfVersion = v, keyHash}
|
||||
| keyHash /= kh ->
|
||||
throwError $ TEHandshake IDENTITY
|
||||
| v `isCompatible` ntfVRange ->
|
||||
| v `isCompatible` ntfVersionRange ->
|
||||
pure $ ntfThHandleServer th v pk
|
||||
| otherwise -> throwError $ TEHandshake VERSION
|
||||
|
||||
|
||||
@@ -33,8 +33,8 @@ import Simplex.Messaging.Server.Stats
|
||||
import Simplex.Messaging.Server.StoreLog
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ATransport, VersionSMP, VersionRangeSMP)
|
||||
import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, loadFingerprint, loadTLSServerParams, newSocketState)
|
||||
import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP)
|
||||
import Simplex.Messaging.Transport.Server (SocketState, TransportServerConfig, alpn, loadFingerprint, loadTLSServerParams, newSocketState)
|
||||
import System.IO (IOMode (..))
|
||||
import System.Mem.Weak (Weak)
|
||||
import UnliftIO.STM
|
||||
@@ -174,13 +174,13 @@ newSubscription subThread = do
|
||||
return Sub {subThread, delivered}
|
||||
|
||||
newEnv :: ServerConfig -> IO Env
|
||||
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile} = do
|
||||
newEnv config@ServerConfig {caCertificateFile, certificateFile, privateKeyFile, storeLogFile, transportConfig} = do
|
||||
server <- atomically newServer
|
||||
queueStore <- atomically newQueueStore
|
||||
msgStore <- atomically newMsgStore
|
||||
random <- liftIO C.newRandom
|
||||
storeLog <- restoreQueues queueStore `mapM` storeLogFile
|
||||
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile
|
||||
tlsServerParams <- loadTLSServerParams caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
|
||||
Fingerprint fp <- loadFingerprint caCertificateFile
|
||||
let serverIdentity = KeyHash fp
|
||||
serverStats <- atomically . newServerStats =<< getCurrentTime
|
||||
|
||||
@@ -25,7 +25,7 @@ import Simplex.Messaging.Server (runSMPServer)
|
||||
import Simplex.Messaging.Server.CLI
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (simplexMQVersion, supportedServerSMPRelayVRange)
|
||||
import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
@@ -211,7 +211,8 @@ smpServerCLI cfgPath logPath =
|
||||
smpServerVRange = supportedServerSMPRelayVRange,
|
||||
transportConfig =
|
||||
defaultTransportServerConfig
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini
|
||||
{ logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini,
|
||||
alpn = Just supportedSMPHandshakes
|
||||
},
|
||||
controlPort = either (const Nothing) (Just . T.unpack) $ lookupValue "TRANSPORT" "control_port" ini
|
||||
}
|
||||
|
||||
@@ -33,9 +33,12 @@ module Simplex.Messaging.Transport
|
||||
VersionSMP,
|
||||
VersionRangeSMP,
|
||||
THandleSMP,
|
||||
supportedSMPHandshakes,
|
||||
supportedClientSMPRelayVRange,
|
||||
supportedServerSMPRelayVRange,
|
||||
legacyServerSMPRelayVRange,
|
||||
currentClientSMPRelayVersion,
|
||||
legacyServerSMPRelayVersion,
|
||||
currentServerSMPRelayVersion,
|
||||
batchCmdsSMPVersion,
|
||||
basicAuthSMPVersion,
|
||||
@@ -152,6 +155,9 @@ authCmdsSMPVersion = VersionSMP 7
|
||||
currentClientSMPRelayVersion :: VersionSMP
|
||||
currentClientSMPRelayVersion = VersionSMP 6
|
||||
|
||||
legacyServerSMPRelayVersion :: VersionSMP
|
||||
legacyServerSMPRelayVersion = VersionSMP 6
|
||||
|
||||
currentServerSMPRelayVersion :: VersionSMP
|
||||
currentServerSMPRelayVersion = VersionSMP 7
|
||||
|
||||
@@ -160,9 +166,15 @@ currentServerSMPRelayVersion = VersionSMP 7
|
||||
supportedClientSMPRelayVRange :: VersionRangeSMP
|
||||
supportedClientSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentClientSMPRelayVersion
|
||||
|
||||
legacyServerSMPRelayVRange :: VersionRangeSMP
|
||||
legacyServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion legacyServerSMPRelayVersion
|
||||
|
||||
supportedServerSMPRelayVRange :: VersionRangeSMP
|
||||
supportedServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion
|
||||
|
||||
supportedSMPHandshakes :: [ALPN]
|
||||
supportedSMPHandshakes = ["smp/1"]
|
||||
|
||||
simplexMQVersion :: String
|
||||
simplexMQVersion = showVersion SMQ.version
|
||||
|
||||
@@ -194,6 +206,9 @@ class Transport c where
|
||||
-- | tls-unique channel binding per RFC5929
|
||||
tlsUnique :: c -> SessionId
|
||||
|
||||
-- | ALPN value negotiated for the session
|
||||
getSessionALPN :: c -> Maybe ALPN
|
||||
|
||||
-- | Close connection
|
||||
closeConnection :: c -> IO ()
|
||||
|
||||
@@ -288,6 +303,7 @@ instance Transport TLS where
|
||||
getServerConnection = getTLS TServer
|
||||
getClientConnection = getTLS TClient
|
||||
getServerCerts = tlsServerCerts
|
||||
getSessionALPN = tlsALPN
|
||||
tlsUnique = tlsUniq
|
||||
closeConnection tls = closeTLS $ tlsContext tls
|
||||
|
||||
@@ -468,12 +484,13 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
|
||||
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
|
||||
sk = C.signX509 serverSignKey $ C.publicToX509 k
|
||||
certChain = getServerCerts c
|
||||
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange, authPubKey = Just (certChain, sk)}
|
||||
smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c
|
||||
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)}
|
||||
getHandshake th >>= \case
|
||||
ClientHandshake {smpVersion = v, keyHash, authPubKey = k'}
|
||||
| keyHash /= kh ->
|
||||
throwE $ TEHandshake IDENTITY
|
||||
| v `isCompatible` smpVRange ->
|
||||
| v `isCompatible` smpVersionRange ->
|
||||
pure $ smpThHandleServer th v pk k'
|
||||
| otherwise -> throwE $ TEHandshake VERSION
|
||||
|
||||
|
||||
@@ -51,7 +51,7 @@ data HTTP2Server = HTTP2Server
|
||||
-- This server is for testing only, it processes all requests in a single queue.
|
||||
getHTTP2Server :: HTTP2ServerConfig -> IO HTTP2Server
|
||||
getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, serverSupported, caCertificateFile, certificateFile, privateKeyFile, transportConfig} = do
|
||||
tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile
|
||||
tlsServerParams <- loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile (alpn transportConfig)
|
||||
started <- newEmptyTMVarIO
|
||||
reqQ <- newTBQueueIO qSize
|
||||
action <- async $
|
||||
|
||||
@@ -28,10 +28,10 @@ import Control.Logger.Simple
|
||||
import Control.Monad
|
||||
import qualified Crypto.Store.X509 as SX
|
||||
import Data.Default (def)
|
||||
import Data.List (find)
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromJust, fromMaybe)
|
||||
import qualified Data.X509 as X
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import qualified Data.X509.Validation as XV
|
||||
@@ -152,12 +152,13 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
|
||||
pure sock
|
||||
setStarted sock = atomically (tryPutTMVar started True) >> pure sock
|
||||
|
||||
loadTLSServerParams :: FilePath -> FilePath -> FilePath -> IO T.ServerParams
|
||||
loadTLSServerParams :: FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams
|
||||
loadTLSServerParams = loadSupportedTLSServerParams supportedParameters
|
||||
|
||||
loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> IO T.ServerParams
|
||||
loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile =
|
||||
fromCredential <$> loadServerCredential
|
||||
loadSupportedTLSServerParams :: T.Supported -> FilePath -> FilePath -> FilePath -> Maybe [ALPN] -> IO T.ServerParams
|
||||
loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile privateKeyFile alpn_ = do
|
||||
tlsServerParams <- fromCredential <$> loadServerCredential
|
||||
pure tlsServerParams {T.serverHooks = maybe def alpnHooks alpn_}
|
||||
where
|
||||
loadServerCredential :: IO T.Credential
|
||||
loadServerCredential =
|
||||
@@ -172,6 +173,7 @@ loadSupportedTLSServerParams serverSupported caCertificateFile certificateFile p
|
||||
T.serverHooks = def,
|
||||
T.serverSupported = serverSupported
|
||||
}
|
||||
alpnHooks supported = def {T.onALPNClientSuggest = Just $ pure . fromMaybe "" . find (`elem` supported)}
|
||||
|
||||
loadFingerprint :: FilePath -> IO Fingerprint
|
||||
loadFingerprint certificateFile = do
|
||||
|
||||
@@ -14,7 +14,8 @@ import Network.WebSockets
|
||||
import Network.WebSockets.Stream (Stream)
|
||||
import qualified Network.WebSockets.Stream as S
|
||||
import Simplex.Messaging.Transport
|
||||
( TProxy,
|
||||
( ALPN,
|
||||
TProxy,
|
||||
Transport (..),
|
||||
TransportConfig (..),
|
||||
TransportError (..),
|
||||
@@ -28,6 +29,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR)
|
||||
data WS = WS
|
||||
{ wsPeer :: TransportPeer,
|
||||
tlsUniq :: ByteString,
|
||||
wsALPN :: Maybe ALPN,
|
||||
wsStream :: Stream,
|
||||
wsConnection :: Connection,
|
||||
wsTransportConfig :: TransportConfig,
|
||||
@@ -61,6 +63,9 @@ instance Transport WS where
|
||||
getServerCerts :: WS -> X.CertificateChain
|
||||
getServerCerts = wsServerCerts
|
||||
|
||||
getSessionALPN :: WS -> Maybe ALPN
|
||||
getSessionALPN = wsALPN
|
||||
|
||||
tlsUnique :: WS -> ByteString
|
||||
tlsUnique = tlsUniq
|
||||
|
||||
@@ -90,7 +95,8 @@ getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS
|
||||
connectWS tlsUniq = do
|
||||
s <- makeTLSContextStream cxt
|
||||
wsConnection <- connectPeer wsPeer s
|
||||
pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts}
|
||||
wsALPN <- T.getNegotiatedProtocol cxt
|
||||
pure $ WS {wsPeer, tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts}
|
||||
connectPeer :: TransportPeer -> Stream -> IO Connection
|
||||
connectPeer TServer = acceptClientRequest
|
||||
connectPeer TClient = sendClientRequest
|
||||
|
||||
@@ -80,7 +80,7 @@ import qualified Simplex.Messaging.Agent.Protocol as A
|
||||
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..))
|
||||
import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew))
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction')
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultSMPClientConfig)
|
||||
import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
@@ -90,7 +90,7 @@ import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolS
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion)
|
||||
import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, basicAuthSMPVersion, batchCmdsSMPVersion, currentServerSMPRelayVersion, supportedSMPHandshakes)
|
||||
import Simplex.Messaging.Util (diffToMicroseconds)
|
||||
import Simplex.Messaging.Version (VersionRange (..))
|
||||
import qualified Simplex.Messaging.Version as V
|
||||
@@ -175,13 +175,16 @@ pattern Rcvd :: AgentMsgId -> ACommand 'Agent 'AEConn
|
||||
pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMsgId, msgRcptStatus = MROk}]
|
||||
|
||||
smpCfgVPrev :: ProtocolClientConfig SMPVersion
|
||||
smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg}
|
||||
smpCfgVPrev = (smpCfg agentCfg) {clientALPN = Nothing, serverVRange = prevRange $ serverVRange $ smpCfg agentCfg}
|
||||
|
||||
smpCfgV7 :: ProtocolClientConfig SMPVersion
|
||||
smpCfgV7 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}
|
||||
|
||||
ntfCfgVPrev :: ProtocolClientConfig NTFVersion
|
||||
ntfCfgVPrev = (ntfCfg agentCfg) {clientALPN = Nothing, serverVRange = V.mkVersionRange (VersionNTF 1) (VersionNTF 1)}
|
||||
|
||||
ntfCfgV2 :: ProtocolClientConfig NTFVersion
|
||||
ntfCfgV2 = (smpCfg agentCfg) {serverVRange = V.mkVersionRange (VersionNTF 1) authBatchCmdsNTFVersion}
|
||||
ntfCfgV2 = (ntfCfg agentCfg) {serverVRange = V.mkVersionRange (VersionNTF 1) authBatchCmdsNTFVersion}
|
||||
|
||||
agentCfgVPrev :: AgentConfig
|
||||
agentCfgVPrev =
|
||||
@@ -190,7 +193,8 @@ agentCfgVPrev =
|
||||
smpAgentVRange = prevRange $ smpAgentVRange agentCfg,
|
||||
smpClientVRange = prevRange $ smpClientVRange agentCfg,
|
||||
e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg,
|
||||
smpCfg = smpCfgVPrev
|
||||
smpCfg = smpCfgVPrev,
|
||||
ntfCfg = ntfCfgVPrev
|
||||
}
|
||||
|
||||
-- agent config for the next client version
|
||||
@@ -2416,7 +2420,8 @@ testCreateQueueAuth srvVersion clnt1 clnt2 = do
|
||||
where
|
||||
getClient clientId (clntAuth, clntVersion) db =
|
||||
let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]}
|
||||
smpCfg = (defaultSMPClientConfig :: ProtocolClientConfig SMPVersion) {serverVRange = V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion}
|
||||
alpn_ = if clntVersion >= authCmdsSMPVersion then Just supportedSMPHandshakes else Nothing
|
||||
smpCfg = defaultClientConfig alpn_ $ V.mkVersionRange (prevVersion basicAuthSMPVersion) clntVersion
|
||||
sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519
|
||||
in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db
|
||||
|
||||
|
||||
+4
-1
@@ -36,6 +36,7 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Notifications.Protocol (NtfResponse)
|
||||
import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
|
||||
import Simplex.Messaging.Notifications.Server.Env
|
||||
import qualified Simplex.Messaging.Notifications.Server.Env as Env
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
|
||||
import Simplex.Messaging.Notifications.Transport
|
||||
@@ -45,6 +46,7 @@ import Simplex.Messaging.Transport.Client
|
||||
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams)
|
||||
import Simplex.Messaging.Transport.HTTP2.Server
|
||||
import Simplex.Messaging.Transport.Server
|
||||
import qualified Simplex.Messaging.Transport.Server as Server
|
||||
import Simplex.Messaging.Version (mkVersionRange)
|
||||
import Test.Hspec
|
||||
import UnliftIO.Async
|
||||
@@ -113,7 +115,8 @@ ntfServerCfgV2 :: NtfServerConfig
|
||||
ntfServerCfgV2 =
|
||||
ntfServerCfg
|
||||
{ ntfServerVRange = mkVersionRange initialNTFVersion authBatchCmdsNTFVersion,
|
||||
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}}
|
||||
smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}},
|
||||
Env.transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedNTFHandshakes}
|
||||
}
|
||||
|
||||
withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a
|
||||
|
||||
+10
-3
@@ -24,8 +24,10 @@ import Simplex.Messaging.Server (runSMPServerBlocking)
|
||||
import Simplex.Messaging.Server.Env.STM
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client
|
||||
import qualified Simplex.Messaging.Transport.Client as Client
|
||||
import Simplex.Messaging.Transport.Server
|
||||
import Simplex.Messaging.Version (mkVersionRange)
|
||||
import qualified Simplex.Messaging.Transport.Server as Server
|
||||
import Simplex.Messaging.Version
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Info (os)
|
||||
import Test.Hspec
|
||||
@@ -73,10 +75,15 @@ testSMPClient = testSMPClientVR supportedClientSMPRelayVRange
|
||||
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 ->
|
||||
let tcConfig = defaultTransportClientConfig {Client.alpn = clientALPN}
|
||||
runTransportClient tcConfig Nothing useHost testPort (Just testKeyHash) $ \h ->
|
||||
runExceptT (smpClientHandshake h Nothing testKeyHash vr) >>= \case
|
||||
Right th -> client th
|
||||
Left e -> error $ show e
|
||||
where
|
||||
clientALPN
|
||||
| authCmdsSMPVersion `isCompatible` vr = Just supportedSMPHandshakes
|
||||
| otherwise = Nothing
|
||||
|
||||
cfg :: ServerConfig
|
||||
cfg =
|
||||
@@ -104,7 +111,7 @@ cfg =
|
||||
privateKeyFile = "tests/fixtures/server.key",
|
||||
certificateFile = "tests/fixtures/server.crt",
|
||||
smpServerVRange = supportedServerSMPRelayVRange,
|
||||
transportConfig = defaultTransportServerConfig,
|
||||
transportConfig = defaultTransportServerConfig {Server.alpn = Just supportedSMPHandshakes},
|
||||
controlPort = Nothing
|
||||
}
|
||||
|
||||
|
||||
Reference in New Issue
Block a user