Skip to content

Commit ffecd4a

Browse files
epoberezkinepoberezkin
authored
parameterize transport by peer type (client/server) (#1545)
* parameterize transport by peer type (client/server) * LogDebug level when test is retried * support "flipped" HTTP2, fix test retry to avoid retrying pending tests * move sync to the end of the tests
1 parent dae649f commit ffecd4a

File tree

29 files changed

+349
-321
lines changed

29 files changed

+349
-321
lines changed

‎src/Simplex/FileTransfer/Transport.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -102,7 +102,7 @@ supportedFileServerVRange :: VersionRangeXFTP
102102
supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
103103

104104
-- XFTP protocol does not use this handshake method
105-
xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
105+
xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
106106
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer = throwE TEVersion
107107

108108
supportedXFTPhandshakes :: [ALPN]

‎src/Simplex/Messaging/Client.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -424,7 +424,7 @@ data ProtocolClientConfig v = ProtocolClientConfig
424424
{ -- | size of TBQueue to use for server commands and responses
425425
qSize :: Natural,
426426
-- | default server port if port is not specified in ProtocolServer
427-
defaultTransport :: (ServiceName, ATransport),
427+
defaultTransport :: (ServiceName, ATransport 'TClient),
428428
-- | network configuration
429429
networkConfig :: NetworkConfig,
430430
clientALPN :: Maybe [ALPN],
@@ -553,7 +553,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
553553
msgQ
554554
}
555555

556-
runClient :: (ServiceName, ATransport) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
556+
runClient :: (ServiceName, ATransport 'TClient) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
557557
runClient (port', ATransport t) useHost c = do
558558
cVar <- newEmptyTMVarIO
559559
let tcConfig = (transportClientConfig networkConfig useHost useSNI) {alpn = clientALPN}
@@ -567,7 +567,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
567567
Just (Left e) -> pure $ Left e
568568
Nothing -> killThread tId $> Left PCENetworkError
569569

570-
useTransport :: (ServiceName, ATransport)
570+
useTransport :: (ServiceName, ATransport 'TClient)
571571
useTransport = case port srv of
572572
"" -> case protocolTypeI @(ProtoType msg) of
573573
SPSMP | smpWebPort -> ("443", transport @TLS)
@@ -581,7 +581,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
581581
_ -> False
582582
SWPOff -> False
583583

584-
client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO ()
584+
client :: forall c. Transport c => TProxy c 'TClient -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c 'TClient -> IO ()
585585
client _ c cVar h = do
586586
ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing
587587
runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer) >>= \case

‎src/Simplex/Messaging/Notifications/Server.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -71,7 +71,7 @@ import Simplex.Messaging.Server.QueueStore (getSystemDate)
7171
import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, periodStatDataCounts, updatePeriodStats)
7272
import Simplex.Messaging.Session
7373
import Simplex.Messaging.TMap (TMap)
74-
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
74+
import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
7575
import Simplex.Messaging.Transport.Buffer (trimCR)
7676
import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer)
7777
import Simplex.Messaging.Util
@@ -120,15 +120,15 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
120120
)
121121
`finally` stopServer
122122
where
123-
runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
123+
runServer :: (ServiceName, ASrvTransport, AddHTTP) -> M ()
124124
runServer (tcpPort, ATransport t, _addHTTP) = do
125125
srvCreds <- asks tlsServerCreds
126126
serverSignKey <- either fail pure $ fromTLSCredentials srvCreds
127127
env <- ask
128128
liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds (Just supportedNTFHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
129129
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
130130

131-
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
131+
runClient :: Transport c => C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M ()
132132
runClient signKey _ h = do
133133
kh <- asks serverIdentity
134134
ks <- atomically . C.generateKeyPair =<< asks random

‎src/Simplex/Messaging/Notifications/Server/Env.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -39,14 +39,14 @@ import Simplex.Messaging.Server.StoreLog (closeStoreLog)
3939
import Simplex.Messaging.Session
4040
import Simplex.Messaging.TMap (TMap)
4141
import qualified Simplex.Messaging.TMap as TM
42-
import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
42+
import Simplex.Messaging.Transport (ASrvTransport, THandleParams, TransportPeer (..))
4343
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
4444
import System.Exit (exitFailure)
4545
import System.Mem.Weak (Weak)
4646
import UnliftIO.STM
4747

4848
data NtfServerConfig = NtfServerConfig
49-
{ transports :: [(ServiceName, ATransport, AddHTTP)],
49+
{ transports :: [(ServiceName, ASrvTransport, AddHTTP)],
5050
controlPort :: Maybe ServiceName,
5151
controlPortUserAuth :: Maybe BasicAuth,
5252
controlPortAdminAuth :: Maybe BasicAuth,

‎src/Simplex/Messaging/Notifications/Server/Main.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -46,7 +46,7 @@ import Simplex.Messaging.Server.Main (strParse)
4646
import Simplex.Messaging.Server.Main.Init (iniDbOpts)
4747
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
4848
import Simplex.Messaging.Server.StoreLog (closeStoreLog)
49-
import Simplex.Messaging.Transport (ATransport, simplexMQVersion)
49+
import Simplex.Messaging.Transport (ASrvTransport, simplexMQVersion)
5050
import Simplex.Messaging.Transport.Client (TransportHost (..))
5151
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
5252
import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow)
@@ -286,7 +286,7 @@ ntfServerCLI cfgPath logPath =
286286
putStrLn "Configure notification server storage."
287287
exitFailure
288288

289-
printNtfServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
289+
printNtfServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
290290
printNtfServerConfig transports PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}, dbStoreLogPath} = do
291291
B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
292292
printServerConfig "NTF" transports dbStoreLogPath

‎src/Simplex/Messaging/Notifications/Transport.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -110,7 +110,7 @@ instance Encoding NtfClientHandshake where
110110
pure NtfClientHandshake {ntfVersion, keyHash}
111111

112112
-- | Notifcations server transport handshake.
113-
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
113+
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c 'TServer -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
114114
ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
115115
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
116116
let sk = C.signX509 serverSignKey $ C.publicToX509 k
@@ -126,7 +126,7 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
126126
Nothing -> throwE TEVersion
127127

128128
-- | Notifcations server client transport handshake.
129-
ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
129+
ntfClientHandshake :: forall c. Transport c => c 'TClient -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
130130
ntfClientHandshake c keyHash ntfVRange _proxyServer = do
131131
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
132132
NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
@@ -137,7 +137,7 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer = do
137137
ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
138138
serverKey <- getServerVerifyKey c
139139
pubKey <- C.verifyX509 serverKey signedKey
140-
(,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
140+
(,(getPeerCertChain c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
141141
let v = maxVersion vr
142142
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
143143
pure $ ntfThHandleClient th v vr ck_
@@ -160,7 +160,7 @@ ntfThHandle_ th@THandle {params} v vr thAuth =
160160
params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v3, batch = v3}
161161
in (th :: THandleNTF c p) {params = params'}
162162

163-
ntfTHandle :: Transport c => c -> THandleNTF c p
163+
ntfTHandle :: Transport c => c p -> THandleNTF c p
164164
ntfTHandle c = THandle {connection = c, params}
165165
where
166166
v = VersionNTF 0

‎src/Simplex/Messaging/Protocol.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -305,7 +305,7 @@ data SParty :: Party -> Type where
305305
SRecipient :: SParty Recipient
306306
SSender :: SParty Sender
307307
SNotifier :: SParty Notifier
308-
SSenderLink :: SParty LinkClient
308+
SSenderLink :: SParty LinkClient
309309
SProxiedClient :: SParty ProxiedClient
310310

311311
instance TestEquality SParty where
@@ -1466,7 +1466,7 @@ transmissionP THandleParams {sessionId, implySessId} = do
14661466
class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
14671467
type ProtoCommand msg = cmd | cmd -> msg
14681468
type ProtoType msg = (sch :: ProtocolType) | sch -> msg
1469-
protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> ExceptT TransportError IO (THandle v c 'TClient)
1469+
protocolClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> ExceptT TransportError IO (THandle v c 'TClient)
14701470
protocolPing :: ProtoCommand msg
14711471
protocolError :: msg -> Maybe err
14721472

‎src/Simplex/Messaging/Server.hs‎

Lines changed: 11 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -79,6 +79,7 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime)
7979
import Data.Time.Format.ISO8601 (iso8601Show)
8080
import Data.Type.Equality
8181
import Data.Typeable (cast)
82+
import qualified Data.X509 as X
8283
import GHC.Conc.Signal
8384
import GHC.IORef (atomicSwapIORef)
8485
import GHC.Stats (getRTSStats)
@@ -177,28 +178,28 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
177178
)
178179
`finally` stopServer s
179180
where
180-
runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
181+
runServer :: (ServiceName, ASrvTransport, AddHTTP) -> M ()
181182
runServer (tcpPort, ATransport t, addHTTP) = do
182-
smpCreds <- asks tlsServerCreds
183+
smpCreds@(srvCert, srvKey) <- asks tlsServerCreds
183184
httpCreds_ <- asks httpServerCreds
184185
ss <- liftIO newSocketState
185186
asks sockets >>= atomically . (`modifyTVar'` ((tcpPort, ss) :))
186-
serverSignKey <- either fail pure $ fromTLSCredentials smpCreds
187+
srvSignKey <- either fail pure $ fromTLSPrivKey srvKey
187188
env <- ask
188189
liftIO $ case (httpCreds_, attachHTTP_) of
189190
(Just httpCreds, Just attachHTTP) | addHTTP ->
190191
runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS chooseCreds (Just combinedALPNs) tCfg $ \s h ->
191192
case cast h of
192-
Just TLS {tlsContext} | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext
193-
_ -> runClient serverSignKey t h `runReaderT` env
193+
Just (TLS {tlsContext} :: TLS 'TServer) | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext
194+
_ -> runClient srvCert srvSignKey t h `runReaderT` env
194195
where
195196
chooseCreds = maybe smpCreds (\_host -> httpCreds)
196197
combinedALPNs = supportedSMPHandshakes <> httpALPN
197198
httpALPN :: [ALPN]
198199
httpALPN = ["h2", "http/1.1"]
199200
_ ->
200-
runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
201-
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
201+
runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
202+
fromTLSPrivKey pk = C.x509ToPrivate (pk, []) >>= C.privKey
202203

203204
sigIntHandlerThread :: M ()
204205
sigIntHandlerThread = do
@@ -589,13 +590,13 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
589590
subClientsCount <- IS.size <$> readTVarIO subClients
590591
pure RTSubscriberMetrics {subsCount, subClientsCount}
591592

592-
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
593-
runClient signKey tp h = do
593+
runClient :: Transport c => X.CertificateChain -> C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M ()
594+
runClient srvCert srvSignKey tp h = do
594595
kh <- asks serverIdentity
595596
ks <- atomically . C.generateKeyPair =<< asks random
596597
ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
597598
labelMyThread $ "smp handshake for " <> transportName tp
598-
liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake signKey h ks kh smpServerVRange) >>= \case
599+
liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange) >>= \case
599600
Just (Right th) -> runClientTransport th
600601
_ -> pure ()
601602

‎src/Simplex/Messaging/Server/CLI.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,7 @@ import Simplex.Messaging.Encoding.String
3434
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
3535
import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StartOptions (..), StorePaths (..))
3636
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
37-
import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
37+
import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..))
3838
import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
3939
import Simplex.Messaging.Transport.WebSockets (WS)
4040
import Simplex.Messaging.Util (eitherToMaybe, whenM)
@@ -363,7 +363,7 @@ checkSavedFingerprint cfgPath x509cfg = do
363363
where
364364
c = combine cfgPath . ($ x509cfg)
365365

366-
iniTransports :: Ini -> [(ServiceName, ATransport, AddHTTP)]
366+
iniTransports :: Ini -> [(ServiceName, ASrvTransport, AddHTTP)]
367367
iniTransports ini =
368368
let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
369369
ws = strictIni "TRANSPORT" "websockets" ini
@@ -373,7 +373,7 @@ iniTransports ini =
373373
| otherwise = ports ws \\ smpPorts
374374
in ts (transport @TLS) smpPorts <> ts (transport @WS) wsPorts
375375
where
376-
ts :: ATransport -> [ServiceName] -> [(ServiceName, ATransport, AddHTTP)]
376+
ts :: ASrvTransport -> [ServiceName] -> [(ServiceName, ASrvTransport, AddHTTP)]
377377
ts t = map (\port -> (port, t, webPort == Just port))
378378
webPort = T.unpack <$> eitherToMaybe (lookupValue "WEB" "https" ini)
379379
ports = map T.unpack . T.splitOn ","
@@ -387,14 +387,14 @@ iniDBOptions ini _default@DBOpts {connstr, schema, poolSize} =
387387
createSchema = False
388388
}
389389

390-
printServerConfig :: String -> [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
390+
printServerConfig :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> Maybe FilePath -> IO ()
391391
printServerConfig protocol transports logFile = do
392392
putStrLn $ case logFile of
393393
Just f -> "Store log: " <> f
394394
_ -> "Store log disabled."
395395
printServerTransports protocol transports
396396

397-
printServerTransports :: String -> [(ServiceName, ATransport, AddHTTP)] -> IO ()
397+
printServerTransports :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> IO ()
398398
printServerTransports protocol ts = do
399399
forM_ ts $ \(p, ATransport t, addHTTP) -> do
400400
let descr = p <> " (" <> transportName t <> ")..."
@@ -405,7 +405,7 @@ printServerTransports protocol ts = do
405405
"\nWARNING: the clients will use port 443 by default soon.\n\
406406
\Set `port` in smp-server.ini section [TRANSPORT] to `5223,443`\n"
407407

408-
printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO ()
408+
printSMPServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> AServerStoreCfg -> IO ()
409409
printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of
410410
SSCMemory sp_ -> printServerConfig "SMP" transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
411411
SSCMemoryJournal {storeLogFile} -> printServerConfig "SMP" transports $ Just storeLogFile

‎src/Simplex/Messaging/Server/Env/STM.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -119,7 +119,7 @@ import Simplex.Messaging.Server.StoreLog
119119
import Simplex.Messaging.Server.StoreLog.ReadWrite
120120
import Simplex.Messaging.TMap (TMap)
121121
import qualified Simplex.Messaging.TMap as TM
122-
import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP)
122+
import Simplex.Messaging.Transport (ASrvTransport, VersionRangeSMP, VersionSMP)
123123
import Simplex.Messaging.Transport.Server
124124
import Simplex.Messaging.Util (ifM, whenM, ($>>=))
125125
import System.Directory (doesFileExist)
@@ -129,7 +129,7 @@ import System.Mem.Weak (Weak)
129129
import UnliftIO.STM
130130

131131
data ServerConfig = ServerConfig
132-
{ transports :: [(ServiceName, ATransport, AddHTTP)],
132+
{ transports :: [(ServiceName, ASrvTransport, AddHTTP)],
133133
smpHandshakeTimeout :: Int,
134134
tbqSize :: Natural,
135135
msgQueueQuota :: Int,

0 commit comments

Comments
 (0)