dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-03-30 14:16:00 +00:00
Code Issues Packages Projects Releases Wiki Activity

parameterize transport by peer type (client/server) (#1545)

Browse Source 
* 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
This commit is contained in:
Evgeny
2025-05-24 14:34:22 +01:00
committed by GitHub
parent dae649fb87
commit ffecd4a17a
29 changed files with 349 additions and 321 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/Simplex/FileTransfer/Transport.hs
View File

@@ -102,7 +102,7 @@ supportedFileServerVRange :: VersionRangeXFTP
supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
-- XFTP protocol does not use this handshake method
xftpClientHandshakeStub :: c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer = throwE TEVersion
supportedXFTPhandshakes :: [ALPN]

8
src/Simplex/Messaging/Client.hs
View File

@@ -424,7 +424,7 @@ data ProtocolClientConfig v = ProtocolClientConfig
{ -- | size of TBQueue to use for server commands and responses
qSize :: Natural,
-- | default server port if port is not specified in ProtocolServer
defaultTransport :: (ServiceName, ATransport),
defaultTransport :: (ServiceName, ATransport 'TClient),
-- | network configuration
networkConfig :: NetworkConfig,
clientALPN :: Maybe [ALPN],
@@ -553,7 +553,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
msgQ
}
runClient :: (ServiceName, ATransport) -> TransportHost -> PClient v err msg -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
runClient :: (ServiceName, ATransport 'TClient) -> 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 useHost useSNI) {alpn = clientALPN}
@@ -567,7 +567,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
Just (Left e) -> pure $ Left e
Nothing -> killThread tId $> Left PCENetworkError
useTransport :: (ServiceName, ATransport)
useTransport :: (ServiceName, ATransport 'TClient)
useTransport = case port srv of
"" -> case protocolTypeI @(ProtoType msg) of
SPSMP | smpWebPort -> ("443", transport @TLS)
@@ -581,7 +581,7 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
_ -> False
SWPOff -> False
client :: forall c. Transport c => TProxy c -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c -> IO ()
client :: forall c. Transport c => TProxy c 'TClient -> PClient v err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient v err msg)) -> c 'TClient -> IO ()
client _ c cVar h = do
ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing
runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer) >>= \case

6
src/Simplex/Messaging/Notifications/Server.hs
View File

@@ -71,7 +71,7 @@ import Simplex.Messaging.Server.QueueStore (getSystemDate)
import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, periodStatDataCounts, updatePeriodStats)
import Simplex.Messaging.Session
import Simplex.Messaging.TMap (TMap)
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
import Simplex.Messaging.Transport.Buffer (trimCR)
import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer)
import Simplex.Messaging.Util
@@ -120,7 +120,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
)
`finally` stopServer
where
runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
runServer :: (ServiceName, ASrvTransport, AddHTTP) -> M ()
runServer (tcpPort, ATransport t, _addHTTP) = do
srvCreds <- asks tlsServerCreds
serverSignKey <- either fail pure $ fromTLSCredentials srvCreds
@@ -128,7 +128,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds (Just supportedNTFHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
runClient :: Transport c => C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M ()
runClient signKey _ h = do
kh <- asks serverIdentity
ks <- atomically . C.generateKeyPair =<< asks random

4
src/Simplex/Messaging/Notifications/Server/Env.hs
View File

@@ -39,14 +39,14 @@ import Simplex.Messaging.Server.StoreLog (closeStoreLog)
import Simplex.Messaging.Session
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
import Simplex.Messaging.Transport (ASrvTransport, THandleParams, TransportPeer (..))
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials, TransportServerConfig, loadFingerprint, loadServerCredential)
import System.Exit (exitFailure)
import System.Mem.Weak (Weak)
import UnliftIO.STM
data NtfServerConfig = NtfServerConfig
{ transports :: [(ServiceName, ATransport, AddHTTP)],
{ transports :: [(ServiceName, ASrvTransport, AddHTTP)],
controlPort :: Maybe ServiceName,
controlPortUserAuth :: Maybe BasicAuth,
controlPortAdminAuth :: Maybe BasicAuth,

4
src/Simplex/Messaging/Notifications/Server/Main.hs
View File

@@ -46,7 +46,7 @@ import Simplex.Messaging.Server.Main (strParse)
import Simplex.Messaging.Server.Main.Init (iniDbOpts)
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
import Simplex.Messaging.Server.StoreLog (closeStoreLog)
import Simplex.Messaging.Transport (ATransport, simplexMQVersion)
import Simplex.Messaging.Transport (ASrvTransport, simplexMQVersion)
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Server (AddHTTP, ServerCredentials (..), TransportServerConfig (..), defaultTransportServerConfig)
import Simplex.Messaging.Util (eitherToMaybe, ifM, tshow)
@@ -286,7 +286,7 @@ ntfServerCLI cfgPath logPath =
putStrLn "Configure notification server storage."
exitFailure
printNtfServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
printNtfServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> PostgresStoreCfg -> IO ()
printNtfServerConfig transports PostgresStoreCfg {dbOpts = DBOpts {connstr, schema}, dbStoreLogPath} = do
B.putStrLn $ "PostgreSQL database: " <> connstr <> ", schema: " <> schema
printServerConfig "NTF" transports dbStoreLogPath

8
src/Simplex/Messaging/Notifications/Transport.hs
View File

@@ -110,7 +110,7 @@ instance Encoding NtfClientHandshake where
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)
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c 'TServer -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
let sk = C.signX509 serverSignKey $ C.publicToX509 k
@@ -126,7 +126,7 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
Nothing -> throwE TEVersion
-- | Notifcations server client transport handshake.
ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
ntfClientHandshake :: forall c. Transport c => c 'TClient -> C.KeyHash -> VersionRangeNTF -> Bool -> ExceptT TransportError IO (THandleNTF c 'TClient)
ntfClientHandshake c keyHash ntfVRange _proxyServer = do
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
@@ -137,7 +137,7 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer = do
ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
serverKey <- getServerVerifyKey c
pubKey <- C.verifyX509 serverKey signedKey
(,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
(,(getPeerCertChain c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
let v = maxVersion vr
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
pure $ ntfThHandleClient th v vr ck_
@@ -160,7 +160,7 @@ ntfThHandle_ th@THandle {params} v vr thAuth =
params' = params {thVersion = v, thServerVRange = vr, thAuth, implySessId = v3, batch = v3}
in (th :: THandleNTF c p) {params = params'}
ntfTHandle :: Transport c => c -> THandleNTF c p
ntfTHandle :: Transport c => c p -> THandleNTF c p
ntfTHandle c = THandle {connection = c, params}
where
v = VersionNTF 0

4
src/Simplex/Messaging/Protocol.hs
View File

@@ -305,7 +305,7 @@ data SParty :: Party -> Type where
SRecipient :: SParty Recipient
SSender :: SParty Sender
SNotifier :: SParty Notifier
SSenderLink :: SParty LinkClient
SSenderLink :: SParty LinkClient
SProxiedClient :: SParty ProxiedClient
instance TestEquality SParty where
@@ -1466,7 +1466,7 @@ transmissionP THandleParams {sessionId, implySessId} = do
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
type ProtoCommand msg = cmd | cmd -> msg
type ProtoType msg = (sch :: ProtocolType) | sch -> msg
protocolClientHandshake :: forall c. Transport c => c -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> ExceptT TransportError IO (THandle v c 'TClient)
protocolClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> ExceptT TransportError IO (THandle v c 'TClient)
protocolPing :: ProtoCommand msg
protocolError :: msg -> Maybe err

21
src/Simplex/Messaging/Server.hs
View File

@@ -79,6 +79,7 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import Data.Type.Equality
import Data.Typeable (cast)
import qualified Data.X509 as X
import GHC.Conc.Signal
import GHC.IORef (atomicSwapIORef)
import GHC.Stats (getRTSStats)
@@ -177,28 +178,28 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
)
`finally` stopServer s
where
runServer :: (ServiceName, ATransport, AddHTTP) -> M ()
runServer :: (ServiceName, ASrvTransport, AddHTTP) -> M ()
runServer (tcpPort, ATransport t, addHTTP) = do
smpCreds <- asks tlsServerCreds
smpCreds@(srvCert, srvKey) <- asks tlsServerCreds
httpCreds_ <- asks httpServerCreds
ss <- liftIO newSocketState
asks sockets >>= atomically . (`modifyTVar'` ((tcpPort, ss) :))
serverSignKey <- either fail pure $ fromTLSCredentials smpCreds
srvSignKey <- either fail pure $ fromTLSPrivKey srvKey
env <- ask
liftIO $ case (httpCreds_, attachHTTP_) of
(Just httpCreds, Just attachHTTP) | addHTTP ->
runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS chooseCreds (Just combinedALPNs) tCfg $ \s h ->
case cast h of
Just TLS {tlsContext} | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext
_ -> runClient serverSignKey t h `runReaderT` env
Just (TLS {tlsContext} :: TLS 'TServer) | maybe False (`elem` httpALPN) (getSessionALPN h) -> labelMyThread "https client" >> attachHTTP s tlsContext
_ -> runClient srvCert srvSignKey t h `runReaderT` env
where
chooseCreds = maybe smpCreds (\_host -> httpCreds)
combinedALPNs = supportedSMPHandshakes <> httpALPN
httpALPN :: [ALPN]
httpALPN = ["h2", "http/1.1"]
_ ->
runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey
runTransportServerState ss started tcpPort defaultSupportedParams smpCreds (Just supportedSMPHandshakes) tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
fromTLSPrivKey pk = C.x509ToPrivate (pk, []) >>= C.privKey
sigIntHandlerThread :: M ()
sigIntHandlerThread = do
@@ -589,13 +590,13 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
subClientsCount <- IS.size <$> readTVarIO subClients
pure RTSubscriberMetrics {subsCount, subClientsCount}
runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M ()
runClient signKey tp h = do
runClient :: Transport c => X.CertificateChain -> C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M ()
runClient srvCert srvSignKey tp h = do
kh <- asks serverIdentity
ks <- atomically . C.generateKeyPair =<< asks random
ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
labelMyThread $ "smp handshake for " <> transportName tp
liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake signKey h ks kh smpServerVRange) >>= \case
liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange) >>= \case
Just (Right th) -> runClientTransport th
_ -> pure ()

12
src/Simplex/Messaging/Server/CLI.hs
View File

@@ -34,7 +34,7 @@ import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), ServerStoreCfg (..), StartOptions (..), StorePaths (..))
import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..))
import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..))
import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
import Simplex.Messaging.Transport.WebSockets (WS)
import Simplex.Messaging.Util (eitherToMaybe, whenM)
@@ -363,7 +363,7 @@ checkSavedFingerprint cfgPath x509cfg = do
where
c = combine cfgPath . ($ x509cfg)
iniTransports :: Ini -> [(ServiceName, ATransport, AddHTTP)]
iniTransports :: Ini -> [(ServiceName, ASrvTransport, AddHTTP)]
iniTransports ini =
let smpPorts = ports $ strictIni "TRANSPORT" "port" ini
ws = strictIni "TRANSPORT" "websockets" ini
@@ -373,7 +373,7 @@ iniTransports ini =
| otherwise = ports ws \\ smpPorts
in ts (transport @TLS) smpPorts <> ts (transport @WS) wsPorts
where
ts :: ATransport -> [ServiceName] -> [(ServiceName, ATransport, AddHTTP)]
ts :: ASrvTransport -> [ServiceName] -> [(ServiceName, ASrvTransport, AddHTTP)]
ts t = map (\port -> (port, t, webPort == Just port))
webPort = T.unpack <$> eitherToMaybe (lookupValue "WEB" "https" ini)
ports = map T.unpack . T.splitOn ","
@@ -387,14 +387,14 @@ iniDBOptions ini _default@DBOpts {connstr, schema, poolSize} =
createSchema = False
}
printServerConfig :: String -> [(ServiceName, ATransport, AddHTTP)] -> Maybe FilePath -> IO ()
printServerConfig :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> Maybe FilePath -> IO ()
printServerConfig protocol transports logFile = do
putStrLn $ case logFile of
Just f -> "Store log: " <> f
_ -> "Store log disabled."
printServerTransports protocol transports
printServerTransports :: String -> [(ServiceName, ATransport, AddHTTP)] -> IO ()
printServerTransports :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> IO ()
printServerTransports protocol ts = do
forM_ ts $ \(p, ATransport t, addHTTP) -> do
let descr = p <> " (" <> transportName t <> ")..."
@@ -405,7 +405,7 @@ printServerTransports protocol ts = do
"\nWARNING: the clients will use port 443 by default soon.\n\
\Set `port` in smp-server.ini section [TRANSPORT] to `5223,443`\n"
printSMPServerConfig :: [(ServiceName, ATransport, AddHTTP)] -> AServerStoreCfg -> IO ()
printSMPServerConfig :: [(ServiceName, ASrvTransport, AddHTTP)] -> AServerStoreCfg -> IO ()
printSMPServerConfig transports (ASSCfg _ _ cfg) = case cfg of
SSCMemory sp_ -> printServerConfig "SMP" transports $ (\StorePaths {storeLogFile} -> storeLogFile) <$> sp_
SSCMemoryJournal {storeLogFile} -> printServerConfig "SMP" transports $ Just storeLogFile

4
src/Simplex/Messaging/Server/Env/STM.hs
View File

@@ -119,7 +119,7 @@ import Simplex.Messaging.Server.StoreLog
import Simplex.Messaging.Server.StoreLog.ReadWrite
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ATransport, VersionRangeSMP, VersionSMP)
import Simplex.Messaging.Transport (ASrvTransport, VersionRangeSMP, VersionSMP)
import Simplex.Messaging.Transport.Server
import Simplex.Messaging.Util (ifM, whenM, ($>>=))
import System.Directory (doesFileExist)
@@ -129,7 +129,7 @@ import System.Mem.Weak (Weak)
import UnliftIO.STM
data ServerConfig = ServerConfig
{ transports :: [(ServiceName, ATransport, AddHTTP)],
{ transports :: [(ServiceName, ASrvTransport, AddHTTP)],
smpHandshakeTimeout :: Int,
tbqSize :: Natural,
msgQueueQuota :: Int,

116
src/Simplex/Messaging/Transport.hs
View File

@@ -61,7 +61,10 @@ module Simplex.Messaging.Transport
Transport (..),
TProxy (..),
ATransport (..),
ASrvTransport,
TransportPeer (..),
STransportPeer (..),
TransportPeerI (..),
getServerVerifyKey,
-- * TLS Transport
@@ -107,6 +110,7 @@ import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Default (def)
import Data.Functor (($>))
import Data.Kind (Type)
import Data.Tuple (swap)
import Data.Typeable (Typeable)
import Data.Version (showVersion)
@@ -241,68 +245,75 @@ data TransportConfig = TransportConfig
transportTimeout :: Maybe Int
}
class Typeable c => Transport c where
transport :: ATransport
transport = ATransport (TProxy @c)
class Typeable c => Transport (c :: TransportPeer -> Type) where
transport :: forall p. ATransport p
transport = ATransport (TProxy @c @p)
transportName :: TProxy c -> String
transportName :: TProxy c p -> String
transportPeer :: c -> TransportPeer
transportConfig :: c p -> TransportConfig
transportConfig :: c -> TransportConfig
-- | Upgrade TLS context to connection
getTransportConnection :: TransportPeerI p => TransportConfig -> X.CertificateChain -> T.Context -> IO (c p)
-- | Upgrade server TLS context to connection (used in the server)
getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c
-- | Upgrade client TLS context to connection (used in the client)
getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c
getServerCerts :: c -> X.CertificateChain
-- | TLS certificate chain, server's in the client, client's in the server (empty chain)
getPeerCertChain :: c p -> X.CertificateChain
-- | tls-unique channel binding per RFC5929
tlsUnique :: c -> SessionId
tlsUnique :: c p -> SessionId
-- | ALPN value negotiated for the session
getSessionALPN :: c -> Maybe ALPN
getSessionALPN :: c p -> Maybe ALPN
-- | Close connection
closeConnection :: c -> IO ()
closeConnection :: c p -> IO ()
-- | Read fixed number of bytes from connection
cGet :: c -> Int -> IO ByteString
cGet :: c p -> Int -> IO ByteString
-- | Write bytes to connection
cPut :: c -> ByteString -> IO ()
cPut :: c p -> ByteString -> IO ()
-- | Receive ByteString from connection, allowing LF or CRLF termination.
getLn :: c -> IO ByteString
getLn :: c p -> IO ByteString
-- | Send ByteString to connection terminating it with CRLF.
putLn :: c -> ByteString -> IO ()
putLn :: c p -> ByteString -> IO ()
putLn c = cPut c . (<> "\r\n")
data TransportPeer = TClient | TServer
deriving (Eq, Show)
data TProxy c = TProxy
data STransportPeer (p :: TransportPeer) where
STClient :: STransportPeer 'TClient
STServer :: STransportPeer 'TServer
data ATransport = forall c. Transport c => ATransport (TProxy c)
class TransportPeerI p where sTransportPeer :: STransportPeer p
getServerVerifyKey :: Transport c => c -> Either String C.APublicVerifyKey
instance TransportPeerI 'TClient where sTransportPeer = STClient
instance TransportPeerI 'TServer where sTransportPeer = STServer
data TProxy (c :: TransportPeer -> Type) (p :: TransportPeer) = TProxy
data ATransport p = forall c. Transport c => ATransport (TProxy c p)
type ASrvTransport = ATransport 'TServer
getServerVerifyKey :: Transport c => c 'TClient -> Either String C.APublicVerifyKey
getServerVerifyKey c =
case getServerCerts c of
case getPeerCertChain c of
X.CertificateChain (server : _ca) -> C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned server, []) >>= C.pubKey
_ -> Left "no certificate chain"
-- * TLS Transport
data TLS = TLS
data TLS (p :: TransportPeer) = TLS
{ tlsContext :: T.Context,
tlsPeer :: TransportPeer,
tlsUniq :: ByteString,
tlsBuffer :: TBuffer,
tlsALPN :: Maybe ALPN,
tlsServerCerts :: X.CertificateChain,
tlsPeerCert :: X.CertificateChain,
tlsTransportConfig :: TransportConfig
}
@@ -317,21 +328,22 @@ connectTLS host_ TransportConfig {logTLSErrors} params sock =
logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e
host = maybe "" (\h -> " (" <> h <> ")") host_
getTLS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO TLS
getTLS tlsPeer cfg tlsServerCerts cxt = withTlsUnique tlsPeer cxt newTLS
getTLS :: forall p. TransportPeerI p => TransportConfig -> X.CertificateChain -> T.Context -> IO (TLS p)
getTLS cfg tlsPeerCert cxt = withTlsUnique @TLS @p cxt newTLS
where
newTLS tlsUniq = do
tlsBuffer <- newTBuffer
tlsALPN <- T.getNegotiatedProtocol cxt
pure TLS {tlsContext = cxt, tlsALPN, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer}
pure TLS {tlsContext = cxt, tlsALPN, tlsTransportConfig = cfg, tlsPeerCert, tlsUniq, tlsBuffer}
withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c
withTlsUnique peer cxt f =
cxtFinished peer cxt
withTlsUnique :: forall c p. TransportPeerI p => T.Context -> (ByteString -> IO (c p)) -> IO (c p)
withTlsUnique cxt f =
cxtFinished cxt
>>= maybe (closeTLS cxt >> ioe_EOF) f
where
cxtFinished TServer = T.getPeerFinished
cxtFinished TClient = T.getFinished
cxtFinished = case sTransportPeer @p of
STServer -> T.getPeerFinished
STClient -> T.getFinished
closeTLS :: T.Context -> IO ()
closeTLS ctx =
@@ -375,26 +387,31 @@ defaultSupportedParamsHTTPS =
instance Transport TLS where
transportName _ = "TLS"
transportPeer = tlsPeer
{-# INLINE transportName #-}
transportConfig = tlsTransportConfig
getServerConnection = getTLS TServer
getClientConnection = getTLS TClient
getServerCerts = tlsServerCerts
{-# INLINE transportConfig #-}
getTransportConnection = getTLS
{-# INLINE getTransportConnection #-}
getPeerCertChain = tlsPeerCert
{-# INLINE getPeerCertChain #-}
getSessionALPN = tlsALPN
{-# INLINE getSessionALPN #-}
tlsUnique = tlsUniq
{-# INLINE tlsUnique #-}
closeConnection tls = closeTLS $ tlsContext tls
{-# INLINE closeConnection #-}
-- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData
-- this function may return less than requested number of bytes
cGet :: TLS -> Int -> IO ByteString
cGet :: TLS p -> Int -> IO ByteString
cGet TLS {tlsContext, tlsBuffer, tlsTransportConfig = TransportConfig {transportTimeout = t_}} n =
getBuffered tlsBuffer n t_ (T.recvData tlsContext)
cPut :: TLS -> ByteString -> IO ()
cPut :: TLS p -> ByteString -> IO ()
cPut TLS {tlsContext, tlsTransportConfig = TransportConfig {transportTimeout = t_}} =
withTimedErr t_ . T.sendData tlsContext . LB.fromStrict
getLn :: TLS -> IO ByteString
getLn :: TLS p -> IO ByteString
getLn TLS {tlsContext, tlsBuffer} = do
getLnBuffered tlsBuffer (T.recvData tlsContext) `E.catches` [E.Handler handleTlsEOF, E.Handler handleEOF]
where
@@ -407,7 +424,7 @@ instance Transport TLS where
-- | The handle for SMP encrypted transport connection over Transport.
data THandle v c p = THandle
{ connection :: c,
{ connection :: c p,
params :: THandleParams v p
}
@@ -587,13 +604,12 @@ tGetBlock THandle {connection = c, params = THandleParams {blockSize, encryptBlo
-- | Server SMP transport handshake.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TServer)
smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
smpServerHandshake :: forall c. Transport c => X.CertificateChain -> C.APrivateSignKey -> c 'TServer -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TServer)
smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVRange = do
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
sk = C.signX509 serverSignKey $ C.publicToX509 k
certChain = getServerCerts c
sk = C.signX509 srvSignKey $ C.publicToX509 k
smpVersionRange = maybe legacyServerSMPRelayVRange (const smpVRange) $ getSessionALPN c
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (certChain, sk)}
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange, authPubKey = Just (srvCert, sk)}
getHandshake th >>= \case
ClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer}
| keyHash /= kh ->
@@ -606,7 +622,7 @@ 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 -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> ExceptT TransportError IO (THandleSMP c 'TClient)
smpClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> ExceptT TransportError IO (THandleSMP c 'TClient)
smpClientHandshake c ks_ keyHash@(C.KeyHash kh) vRange proxyServer = do
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
@@ -689,7 +705,7 @@ sendHandshake th = ExceptT . tPutBlock th . smpEncode
getHandshake :: (Transport c, Encoding smp) => THandle v c p -> ExceptT TransportError IO smp
getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP =<<) <$> tGetBlock th
smpTHandle :: Transport c => c -> THandleSMP c p
smpTHandle :: Transport c => c p -> THandleSMP c p
smpTHandle c = THandle {connection = c, params}
where
v = VersionSMP 0

7
src/Simplex/Messaging/Transport/Client.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
@@ -142,10 +143,10 @@ clientTransportConfig TransportClientConfig {logTLSErrors} =
TransportConfig {logTLSErrors, transportTimeout = Nothing}
-- | Connect to passed TCP host:port and pass handle to the client.
runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
runTransportClient :: Transport c => TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c 'TClient -> IO a) -> IO a
runTransportClient = runTLSTransportClient defaultSupportedParams Nothing
runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> IO a) -> IO a
runTLSTransportClient :: Transport c => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c 'TClient -> IO a) -> IO a
runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials, alpn, useSNI} socksCreds host port keyHash client = do
serverCert <- newEmptyTMVarIO
let hostName = B.unpack $ strEncode host
@@ -165,7 +166,7 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy,
logError "onServerCertificate didn't fire or failed to get cert chain"
closeTLS tls >> error "onServerCertificate failed"
Just c -> pure c
getClientConnection tCfg chain tls
getTransportConnection tCfg chain tls
client c `E.finally` closeConnection c
where
hostAddr = \case

4
src/Simplex/Messaging/Transport/HTTP2.hs
View File

@@ -22,10 +22,10 @@ import qualified System.TimeManager as TI
defaultHTTP2BufferSize :: BufferSize
defaultHTTP2BufferSize = 32768
withHTTP2 :: BufferSize -> (Config -> IO a) -> IO () -> TLS -> IO a
withHTTP2 :: BufferSize -> (Config -> IO a) -> IO () -> TLS p -> IO a
withHTTP2 sz run fin c = E.bracket (allocHTTP2Config c sz) (\cfg -> freeSimpleConfig cfg `E.finally` fin) run
allocHTTP2Config :: TLS -> BufferSize -> IO Config
allocHTTP2Config :: TLS p -> BufferSize -> IO Config
allocHTTP2Config c sz = do
buf <- mallocBytes sz
tm <- TI.initialize $ 30 * 1000000

29
src/Simplex/Messaging/Transport/HTTP2/Client.hs
View File

@@ -1,9 +1,12 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Messaging.Transport.HTTP2.Client where
@@ -24,7 +27,7 @@ import qualified Network.TLS as T
import Numeric.Natural (Natural)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Transport (ALPN, SessionId, TLS (tlsALPN), getServerCerts, getServerVerifyKey, tlsUniq)
import Simplex.Messaging.Transport (ALPN, STransportPeer (..), SessionId, TLS (tlsALPN, tlsPeerCert, tlsUniq), TransportPeer (..), TransportPeerI (..), getServerVerifyKey)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTcpConnectTimeout, runTLSTransportClient)
import Simplex.Messaging.Transport.HTTP2
import Simplex.Messaging.Util (eitherToMaybe)
@@ -97,13 +100,14 @@ getVerifiedHTTP2Client socksCreds host port keyHash caStore config disconnected
where
setup = runHTTP2Client (suportedTLSParams config) caStore (transportConfig config) (bufferSize config) socksCreds host port keyHash
attachHTTP2Client :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> Int -> TLS -> IO (Either HTTP2ClientError HTTP2Client)
-- HTTP2 client can be run on both client and server TLS connections.
attachHTTP2Client :: forall p. TransportPeerI p => HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> Int -> TLS p -> IO (Either HTTP2ClientError HTTP2Client)
attachHTTP2Client config host port disconnected bufferSize tls = getVerifiedHTTP2ClientWith config host port disconnected setup
where
setup :: (TLS -> H.Client HTTP2Response) -> IO HTTP2Response
setup :: (TLS p -> H.Client HTTP2Response) -> IO HTTP2Response
setup = runHTTP2ClientWith bufferSize host ($ tls)
getVerifiedHTTP2ClientWith :: HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((TLS -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2ClientWith :: forall p. TransportPeerI p => HTTP2ClientConfig -> TransportHost -> ServiceName -> IO () -> ((TLS p -> H.Client HTTP2Response) -> IO HTTP2Response) -> IO (Either HTTP2ClientError HTTP2Client)
getVerifiedHTTP2ClientWith config host port disconnected setup =
(mkHTTPS2Client >>= runClient)
`E.catch` \(e :: IOException) -> pure . Left $ HCIOError e
@@ -124,15 +128,17 @@ getVerifiedHTTP2ClientWith config host port disconnected setup =
Just (Left e) -> pure $ Left e
Nothing -> cancel action $> Left HCNetworkError
client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> TLS -> H.Client HTTP2Response
client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> TLS p -> H.Client HTTP2Response
client c cVar tls sendReq = do
sessionTs <- getCurrentTime
let c' =
HTTP2Client
{ action = Nothing,
client_ = c,
serverKey = eitherToMaybe $ getServerVerifyKey tls,
serverCerts = getServerCerts tls,
serverKey = case sTransportPeer @p of
STClient -> eitherToMaybe $ getServerVerifyKey tls
STServer -> Nothing,
serverCerts = tlsPeerCert tls,
sendReq,
sessionTs,
sessionId = tlsUniq tls,
@@ -179,14 +185,15 @@ sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq
http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int
http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +)
runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS -> H.Client a) -> IO a
runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe SocksCredentials -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (TLS 'TClient -> H.Client a) -> IO a
runHTTP2Client tlsParams caStore tcConfig bufferSize socksCreds host port keyHash = runHTTP2ClientWith bufferSize host setup
where
setup :: (TLS -> IO a) -> IO a
setup :: (TLS 'TClient -> IO a) -> IO a
setup = runTLSTransportClient tlsParams caStore tcConfig socksCreds host port keyHash
runHTTP2ClientWith :: forall a. BufferSize -> TransportHost -> ((TLS -> IO a) -> IO a) -> (TLS -> H.Client a) -> IO a
-- HTTP2 client can be run on both client and server TLS connections.
runHTTP2ClientWith :: forall a p. BufferSize -> TransportHost -> ((TLS p -> IO a) -> IO a) -> (TLS p -> H.Client a) -> IO a
runHTTP2ClientWith bufferSize host setup client = setup $ \tls -> withHTTP2 bufferSize (run tls) (pure ()) tls
where
run :: TLS -> H.Config -> IO a
run :: TLS p -> H.Config -> IO a
run tls cfg = H.run (ClientConfig "https" (strEncode host) 20) cfg $ client tls

6
src/Simplex/Messaging/Transport/HTTP2/Server.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Messaging.Transport.HTTP2.Server where
@@ -67,10 +68,11 @@ runHTTP2Server started port bufferSize srvSupported srvCreds alpn_ transportConf
where
setup = runTransportServer started port srvSupported srvCreds alpn_ transportConfig
runHTTP2ServerWith :: BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
-- HTTP2 server can be run on both client and server TLS connections.
runHTTP2ServerWith :: BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a
runHTTP2ServerWith = runHTTP2ServerWith_ Nothing (\_sessId -> pure ())
runHTTP2ServerWith_ :: Maybe ExpirationConfig -> (SessionId -> IO ()) -> BufferSize -> ((TLS -> IO ()) -> a) -> HTTP2ServerFunc -> a
runHTTP2ServerWith_ :: Maybe ExpirationConfig -> (SessionId -> IO ()) -> BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a
runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup http2Server = setup $ \tls -> do
activeAt <- newTVarIO =<< getSystemTime
tid_ <- mapM (forkIO . expireInactiveClient tls activeAt) expCfg_

17
src/Simplex/Messaging/Transport/Server.hs
View File

@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -87,31 +88,31 @@ serverTransportConfig TransportServerConfig {logTLSErrors} =
-- | Run transport server (plain TCP or WebSockets) on passed TCP port and signal when server started and stopped via passed TMVar.
--
-- All accepted connections are passed to the passed function.
runTransportServer :: forall c. Transport c => TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c -> IO ()) -> IO ()
runTransportServer :: forall c. Transport c => TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO ()
runTransportServer started port srvSupported srvCreds alpn_ cfg server = do
ss <- newSocketState
runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server
runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c -> IO ()) -> IO ()
runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> T.Credential -> Maybe [ALPN] -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO ()
runTransportServerState ss started port srvSupported srvCreds alpn_ cfg server = runTransportServerState_ ss started port srvSupported (const srvCreds) alpn_ cfg (const server)
runTransportServerState_ :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> c -> IO ()) -> IO ()
runTransportServerState_ ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c))
runTransportServerState_ :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO ()
runTransportServerState_ ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c 'TServer))
-- | Run a transport server with provided connection setup and handler.
runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.Credential -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
runTransportServerSocket :: Transport c => TMVar Bool -> IO Socket -> String -> T.Credential -> T.ServerParams -> TransportServerConfig -> (c 'TServer -> IO ()) -> IO ()
runTransportServerSocket started getSocket threadLabel srvCreds srvParams cfg server = do
ss <- newSocketState
runTransportServerSocketState_ ss started getSocket threadLabel (const srvCreds) srvParams cfg (const server)
runTransportServerSocketState :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> a -> IO ()) -> IO ()
runTransportServerSocketState :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> T.Supported -> (Maybe HostName -> T.Credential) -> Maybe [ALPN] -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO ()
runTransportServerSocketState ss started getSocket threadLabel srvSupported srvCreds alpn_ =
runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams
where
srvParams = supportedTLSServerParams_ srvSupported srvCreds alpn_
-- | Run a transport server with provided connection setup and handler.
runTransportServerSocketState_ :: Transport a => SocketState -> TMVar Bool -> IO Socket -> String -> (Maybe HostName -> (X.CertificateChain, X.PrivKey)) -> T.ServerParams -> TransportServerConfig -> (Socket -> a -> IO ()) -> IO ()
runTransportServerSocketState_ :: Transport c => SocketState -> TMVar Bool -> IO Socket -> String -> (Maybe HostName -> (X.CertificateChain, X.PrivKey)) -> T.ServerParams -> TransportServerConfig -> (Socket -> c 'TServer -> IO ()) -> IO ()
runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvParams cfg server = do
labelMyThread $ "transport server for " <> threadLabel
runTCPServerSocket ss started getSocket $ \conn ->
@@ -121,7 +122,7 @@ runTransportServerSocketState_ ss started getSocket threadLabel srvCreds srvPara
setup conn = timeout (tlsSetupTimeout cfg) $ do
labelMyThread $ threadLabel <> "/setup"
tls <- connectTLS Nothing tCfg srvParams conn
getServerConnection tCfg (fst $ srvCreds Nothing) tls
getTransportConnection tCfg (fst $ srvCreds Nothing) tls
-- | Run TCP server without TLS
runLocalTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()

66
src/Simplex/Messaging/Transport/WebSockets.hs
View File

@@ -1,6 +1,11 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Messaging.Transport.WebSockets (WS (..)) where
@@ -15,11 +20,12 @@ import Network.WebSockets.Stream (Stream)
import qualified Network.WebSockets.Stream as S
import Simplex.Messaging.Transport
( ALPN,
TProxy,
Transport (..),
TransportConfig (..),
TransportError (..),
TransportPeer (..),
STransportPeer (..),
TransportPeerI (..),
closeTLS,
smpBlockSize,
withTlsUnique,
@@ -27,14 +33,13 @@ import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Buffer (trimCR)
import System.IO.Error (isEOFError)
data WS = WS
{ wsPeer :: TransportPeer,
tlsUniq :: ByteString,
data WS (p :: TransportPeer) = WS
{ tlsUniq :: ByteString,
wsALPN :: Maybe ALPN,
wsStream :: Stream,
wsConnection :: Connection,
wsTransportConfig :: TransportConfig,
wsServerCerts :: X.CertificateChain
wsPeerCert :: X.CertificateChain
}
websocketsOpts :: ConnectionOptions
@@ -46,61 +51,50 @@ websocketsOpts =
}
instance Transport WS where
transportName :: TProxy WS -> String
transportName _ = "WebSockets"
transportPeer :: WS -> TransportPeer
transportPeer = wsPeer
transportConfig :: WS -> TransportConfig
{-# INLINE transportName #-}
transportConfig = wsTransportConfig
getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
getServerConnection = getWS TServer
getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS
getClientConnection = getWS TClient
getServerCerts :: WS -> X.CertificateChain
getServerCerts = wsServerCerts
getSessionALPN :: WS -> Maybe ALPN
{-# INLINE transportConfig #-}
getTransportConnection = getWS
{-# INLINE getTransportConnection #-}
getPeerCertChain = wsPeerCert
{-# INLINE getPeerCertChain #-}
getSessionALPN = wsALPN
tlsUnique :: WS -> ByteString
{-# INLINE getSessionALPN #-}
tlsUnique = tlsUniq
closeConnection :: WS -> IO ()
{-# INLINE tlsUnique #-}
closeConnection = S.close . wsStream
{-# INLINE closeConnection #-}
cGet :: WS -> Int -> IO ByteString
cGet :: WS p -> Int -> IO ByteString
cGet c n = do
s <- receiveData (wsConnection c)
if B.length s == n
then pure s
else E.throwIO TEBadBlock
cPut :: WS -> ByteString -> IO ()
cPut :: WS p -> ByteString -> IO ()
cPut = sendBinaryData . wsConnection
getLn :: WS -> IO ByteString
getLn :: WS p -> IO ByteString
getLn c = do
s <- trimCR <$> receiveData (wsConnection c)
if B.null s || B.last s /= '\n'
then E.throwIO TEBadBlock
else pure $ B.init s
getWS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO WS
getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS
getWS :: forall p. TransportPeerI p => TransportConfig -> X.CertificateChain -> T.Context -> IO (WS p)
getWS cfg wsPeerCert cxt = withTlsUnique @WS @p cxt connectWS
where
connectWS tlsUniq = do
s <- makeTLSContextStream cxt
wsConnection <- connectPeer wsPeer s
wsConnection <- connectPeer s
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
pure $ WS {tlsUniq, wsALPN, wsStream = s, wsConnection, wsTransportConfig = cfg, wsPeerCert}
connectPeer :: Stream -> IO Connection
connectPeer = case sTransportPeer @p of
STServer -> acceptClientRequest
STClient -> sendClientRequest
acceptClientRequest s = makePendingConnectionFromStream s websocketsOpts >>= acceptRequest
sendClientRequest s = newClientConnection s "" "/" websocketsOpts []

14
src/Simplex/RemoteControl/Client.hs
View File

@@ -62,7 +62,7 @@ import Simplex.Messaging.Crypto.SNTRUP761
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String (StrEncoding (..))
import Simplex.Messaging.Transport (TSbChainKeys (..), TLS (..), cGet, cPut)
import Simplex.Messaging.Transport (TSbChainKeys (..), TLS (..), TransportPeer (..), cGet, cPut)
import Simplex.Messaging.Transport.Buffer (peekBuffered)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTransportClient)
import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
@@ -101,7 +101,7 @@ data RCHClient_ = RCHClient_
endSession :: TMVar ()
}
type RCHostConnection = (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
type RCHostConnection = (NonEmpty RCCtrlAddress, RCSignedInvitation, RCHostClient, RCStepTMVar (SessionCode, TLS 'TServer, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)))
connectRCHost :: TVar ChaChaDRG -> RCHostPairing -> J.Value -> Bool -> Maybe RCCtrlAddress -> Maybe Word16 -> ExceptT RCErrorType IO RCHostConnection
connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ctrlAppInfo multicast rcAddrPrefs_ port_ = do
@@ -131,7 +131,7 @@ connectRCHost drg pairing@RCHostPairing {caKey, caCert, idPrivKey, knownHost} ct
endSession <- newEmptyTMVarIO
hostCAHash <- newEmptyTMVarIO
pure RCHClient_ {startedPort, announcer, hostCAHash, endSession}
runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> IO (Async ())
runClient :: RCHClient_ -> RCStepTMVar (SessionCode, TLS 'TServer, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> RCHostKeys -> IO (Async ())
runClient RCHClient_ {startedPort, announcer, hostCAHash, endSession} r hostKeys = do
tlsCreds <- genTLSCredentials drg caKey caCert
startTLSServer port_ startedPort tlsCreds (tlsHooks r knownHost hostCAHash) $ \tls ->
@@ -249,7 +249,7 @@ data RCCClient_ = RCCClient_
endSession :: TMVar ()
}
type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
type RCCtrlConnection = (RCCtrlClient, RCStepTMVar (SessionCode, TLS 'TClient, RCStepTMVar (RCCtrlSession, RCCtrlPairing)))
-- app should determine whether it is a new or known pairing based on CA fingerprint in the invitation
connectRCCtrl :: TVar ChaChaDRG -> RCVerifiedInvitation -> Maybe RCCtrlPairing -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection
@@ -280,7 +280,7 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca,
confirmSession <- newEmptyTMVarIO
endSession <- newEmptyTMVarIO
pure RCCClient_ {confirmSession, endSession}
runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO ()
runClient :: RCCClient_ -> RCStepTMVar (SessionCode, TLS 'TClient, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> ExceptT RCErrorType IO ()
runClient RCCClient_ {confirmSession, endSession} r = do
clientCredentials <- liftIO $ Just <$> genTLSCredentials drg caKey caCert
let clientConfig = defaultTransportClientConfig {clientCredentials}
@@ -315,12 +315,12 @@ catchRCError = catchAllErrors $ \e -> case fromException e of
putRCError :: ExceptT RCErrorType IO a -> TMVar (Either RCErrorType b) -> ExceptT RCErrorType IO a
a `putRCError` r = a `catchRCError` \e -> atomically (tryPutTMVar r $ Left e) >> throwE e
sendRCPacket :: Encoding a => TLS -> a -> ExceptT RCErrorType IO ()
sendRCPacket :: Encoding a => TLS p -> a -> ExceptT RCErrorType IO ()
sendRCPacket tls pkt = do
b <- liftEitherWith (const RCEBlockSize) $ C.pad (smpEncode pkt) xrcpBlockSize
liftIO $ cPut tls b
receiveRCPacket :: Encoding a => TLS -> ExceptT RCErrorType IO a
receiveRCPacket :: Encoding a => TLS p -> ExceptT RCErrorType IO a
receiveRCPacket tls = do
b <- liftIO $ cGet tls xrcpBlockSize
when (B.length b /= xrcpBlockSize) $ throwE RCEBlockSize

4
src/Simplex/RemoteControl/Discovery.hs
View File

@@ -23,7 +23,7 @@ import Network.Info (IPv4 (..), NetworkInterface (..), getNetworkInterfaces)
import qualified Network.Socket as N
import qualified Network.TLS as TLS
import qualified Network.UDP as UDP
import Simplex.Messaging.Transport (defaultSupportedParams)
import Simplex.Messaging.Transport (TransportPeer (..), defaultSupportedParams)
import qualified Simplex.Messaging.Transport as Transport
import Simplex.Messaging.Transport.Client (TransportHost (..))
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
@@ -68,7 +68,7 @@ preferAddress RCCtrlAddress {address, interface} addrs =
matchAddr RCCtrlAddress {address = a} = a == address
matchIface RCCtrlAddress {interface = i} = i == interface
startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credential -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> IO (Async ())
startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credential -> TLS.ServerHooks -> (Transport.TLS 'TServer -> IO ()) -> IO (Async ())
startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ do
started <- newEmptyTMVarIO
bracketOnError (startTCPServer started Nothing $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket ->

11
src/Simplex/RemoteControl/Types.hs
View File

@@ -18,12 +18,13 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word16)
import qualified Data.X509 as X
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.SNTRUP761.Bindings
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON)
import Simplex.Messaging.Transport (TLS, TSbChainKeys)
import Simplex.Messaging.Transport (TLS, TSbChainKeys, TransportPeer (..))
import Simplex.Messaging.Transport.Client (TransportHost)
import Simplex.Messaging.Util (safeDecodeUtf8)
import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
@@ -140,7 +141,7 @@ $(JQ.deriveJSON defaultJSON {J.nullaryToObject = True} ''RCCtrlHello)
-- | Long-term part of controller (desktop) connection to host (mobile)
data RCHostPairing = RCHostPairing
{ caKey :: C.APrivateSignKey,
caCert :: C.SignedCertificate,
caCert :: X.SignedCertificate,
idPrivKey :: C.PrivateKeyEd25519,
knownHost :: Maybe KnownHostPairing
}
@@ -159,7 +160,7 @@ data RCCtrlAddress = RCCtrlAddress
-- | Long-term part of host (mobile) connection to controller (desktop)
data RCCtrlPairing = RCCtrlPairing
{ caKey :: C.APrivateSignKey,
caCert :: C.SignedCertificate,
caCert :: X.SignedCertificate,
ctrlFingerprint :: C.KeyHash, -- long-term identity of connected remote controller
idPubKey :: C.PublicKeyEd25519,
dhPrivKey :: C.PrivateKeyX25519,
@@ -173,7 +174,7 @@ data RCHostKeys = RCHostKeys
-- Connected session with Host
data RCHostSession = RCHostSession
{ tls :: TLS,
{ tls :: TLS 'TServer,
sessionKeys :: HostSessKeys
}
@@ -186,7 +187,7 @@ data HostSessKeys = HostSessKeys
-- Host: RCCtrlPairing + RCInvitation => (RCCtrlSession, RCCtrlPairing)
data RCCtrlSession = RCCtrlSession
{ tls :: TLS,
{ tls :: TLS 'TClient,
sessionKeys :: CtrlSessKeys
}

4
tests/AgentTests.hs
View File

@@ -15,7 +15,7 @@ import AgentTests.MigrationTests (migrationTests)
import AgentTests.ServerChoice (serverChoiceTests)
import AgentTests.ShortLinkTests (shortLinkTests)
import Simplex.Messaging.Server.Env.STM (AStoreType (..))
import Simplex.Messaging.Transport (ATransport (..))
import Simplex.Messaging.Transport (ASrvTransport)
import Test.Hspec hiding (fit, it)
#if defined(dbPostgres)
@@ -38,7 +38,7 @@ agentCoreTests = do
describe "Double ratchet tests" doubleRatchetTests
describe "Short link tests" shortLinkTests
agentTests :: (ATransport, AStoreType) -> Spec
agentTests :: (ASrvTransport, AStoreType) -> Spec
agentTests ps = do
#if defined(dbPostgres)
after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do

111
tests/AgentTests/FunctionalAPITests.hs
View File

@@ -102,7 +102,7 @@ import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..),
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange)
import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange)
import Simplex.Messaging.Util (bshow, diffToMicroseconds)
import Simplex.Messaging.Version (VersionRange (..))
import qualified Simplex.Messaging.Version as V
@@ -267,7 +267,7 @@ sendMessage c connId msgFlags msgBody = do
liftIO $ pqEnc `shouldBe` PQEncOn
pure msgId
functionalAPITests :: (ATransport, AStoreType) -> Spec
functionalAPITests :: (ASrvTransport, AStoreType) -> Spec
functionalAPITests ps = do
describe "Establishing duplex connection" $ do
testMatrix2 ps runAgentClientTest
@@ -486,7 +486,7 @@ functionalAPITests ps = do
it "server should respond with queue and subscription information" $
withSmpServer ps testServerQueueInfo
testBasicAuth :: (ATransport, AStoreType) -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int
testBasicAuth :: (ASrvTransport, AStoreType) -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int
testBasicAuth (t, msType) allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do
let testCfg = (cfgMS msType) {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion}
canCreate1 = canCreateQueue allowNewQueues srv clnt1
@@ -503,7 +503,7 @@ canCreateQueue :: Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, Ver
canCreateQueue allowNew (srvAuth, _) (clntAuth, _) =
allowNew && (isNothing srvAuth || srvAuth == clntAuth)
testMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testMatrix2 ps runTest = do
it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True
it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3 $ runTest PQSupportOn False True
@@ -512,7 +512,7 @@ testMatrix2 ps runTest = do
it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfg 1 $ runTest PQSupportOff False False
it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrev 1 $ runTest PQSupportOff False False
testMatrix2Stress :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testMatrix2Stress :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testMatrix2Stress ps runTest = do
it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aCfg aCfg initAgentServersProxy 1 $ runTest PQSupportOn True True
it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aProxyCfgV8 aProxyCfgV8 initAgentServersProxy 1 $ runTest PQSupportOn False True
@@ -525,14 +525,14 @@ testMatrix2Stress ps runTest = do
aProxyCfgV8 = agentProxyCfgV8 {messageRetryInterval = fastMessageRetryInterval}
aCfgVPrev = agentCfgVPrev {messageRetryInterval = fastMessageRetryInterval}
testBasicMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testBasicMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (SndQueueSecured -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testBasicMatrix2 ps runTest = do
it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest True
it "prev" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfgVPrevPQ 1 $ runTest False
it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfg 1 $ runTest False
it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrevPQ 1 $ runTest False
testRatchetMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testRatchetMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec
testRatchetMatrix2 ps runTest = do
it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True
it "v8, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentProxyCfgV8 agentProxyCfgV8 initAgentServersProxy 3 $ runTest PQSupportOn False True
@@ -541,17 +541,17 @@ testRatchetMatrix2 ps runTest = do
it "ratchets prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False
it "ratchets current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False
testServerMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (InitialAgentServers -> IO ()) -> Spec
testServerMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (InitialAgentServers -> IO ()) -> Spec
testServerMatrix2 ps runTest = do
it "1 server" $ withSmpServer ps $ runTest initAgentServers
it "2 servers" $ withSmpServers2 ps $ runTest initAgentServers2
testProxyMatrix :: HasCallStack => (ATransport, AStoreType) -> (Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
testProxyMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
testProxyMatrix ps runTest = do
it "2 servers, directly" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False
it "2 servers, via proxy" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True
testProxyMatrixWithPrev :: HasCallStack => (ATransport, AStoreType) -> (Bool -> Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
testProxyMatrixWithPrev :: HasCallStack => (ASrvTransport, AStoreType) -> (Bool -> Bool -> AgentClient -> AgentClient -> IO ()) -> Spec
testProxyMatrixWithPrev ps@(t, msType@(ASType qs _ms)) runTest = do
it "2 servers, directly, curr clients, prev servers" $ withSmpServers2Prev $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False True
it "2 servers, via proxy, curr clients, prev servers" $ withSmpServersProxy2Prev $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True True
@@ -564,13 +564,13 @@ testProxyMatrixWithPrev ps@(t, msType@(ASType qs _ms)) runTest = do
withServers2 cfg1 cfg2 a =
withSmpServerConfigOn t cfg1 testPort $ \_ -> withSmpServerConfigOn t cfg2 testPort2 $ \_ -> a
testPQMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
testPQMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
testPQMatrix2 = pqMatrix2_ True
testPQMatrix2NoInv :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
testPQMatrix2NoInv :: HasCallStack => (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
testPQMatrix2NoInv = pqMatrix2_ False
pqMatrix2_ :: HasCallStack => Bool -> (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
pqMatrix2_ :: HasCallStack => Bool -> (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec
pqMatrix2_ pqInv ps test = do
it "dh/dh handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff)
it "dh/pq handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn)
@@ -584,7 +584,7 @@ pqMatrix2_ pqInv ps test = do
testPQMatrix3 ::
HasCallStack =>
(ATransport, AStoreType) ->
(ASrvTransport, AStoreType) ->
(HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) ->
Spec
testPQMatrix3 ps test = do
@@ -1047,7 +1047,7 @@ testAsyncBothOffline = do
liftIO $ disposeAgentClient alice'
liftIO $ disposeAgentClient bob'
testAsyncServerOffline :: HasCallStack => (ATransport, AStoreType) -> IO ()
testAsyncServerOffline :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do
-- create connection and shutdown the server
(bobId, cReq) <- withSmpServerStoreLogOn ps testPort $ \_ ->
@@ -1063,6 +1063,7 @@ testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do
liftIO $ do
srv1 `shouldBe` testSMPServer
conns1 `shouldBe` [bobId]
liftIO $ threadDelay 250000
(aliceId, sqSecured) <- joinConnection bob 1 True cReq "bob's connInfo" SMSubscribe
liftIO $ sqSecured `shouldBe` True
("", _, CONF confId _ "bob's connInfo") <- get alice
@@ -1072,7 +1073,7 @@ testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do
get bob ##> ("", aliceId, CON)
exchangeGreetings alice bobId bob aliceId
testAllowConnectionClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
testAllowConnectionClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testAllowConnectionClientRestart ps@(t, ASType qsType _) = do
let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
@@ -1253,7 +1254,7 @@ testAddContactShortLink viaProxy a b =
connReq4 `shouldBe` connReq
linkUserData updatedConnData' `shouldBe` updatedData
testInviationShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
testInviationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do
let userData = "some user data"
(bId, CCLink connReq (Just shortLink)) <- withSmpServer ps $
@@ -1265,7 +1266,7 @@ testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do
connReq' `shouldBe` connReq
linkUserData connData' `shouldBe` userData
testContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
let userData = "some user data"
(contactId, CCLink connReq0 (Just shortLink)) <- withSmpServer ps $
@@ -1285,7 +1286,7 @@ testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
connReq4 `shouldBe` connReq
linkUserData updatedConnData' `shouldBe` updatedData
testAddContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
let userData = "some user data"
((contactId, CCLink connReq0 Nothing), shortLink) <- withSmpServer ps $ runRight $ do
@@ -1306,7 +1307,7 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do
connReq4 `shouldBe` connReq
linkUserData updatedConnData' `shouldBe` updatedData
testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO ()
testIncreaseConnAgentVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testIncreaseConnAgentVersion ps = do
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
@@ -1371,7 +1372,7 @@ checkVersion c connId v = do
ConnectionStats {connAgentVersion} <- getConnectionServers c connId
liftIO $ connAgentVersion `shouldBe` VersionSMPA v
testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => (ATransport, AStoreType) -> IO ()
testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testIncreaseConnAgentVersionMaxCompatible ps = do
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB2
@@ -1401,7 +1402,7 @@ testIncreaseConnAgentVersionMaxCompatible ps = do
disposeAgentClient alice2
disposeAgentClient bob2
testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => (ATransport, AStoreType) -> IO ()
testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testIncreaseConnAgentVersionStartDifferentVersion ps = do
alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 2} initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
@@ -1427,7 +1428,7 @@ testIncreaseConnAgentVersionStartDifferentVersion ps = do
disposeAgentClient alice2
disposeAgentClient bob
testDeliverClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
testDeliverClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testDeliverClientRestart ps = do
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1458,7 +1459,7 @@ testDeliverClientRestart ps = do
disposeAgentClient alice
disposeAgentClient bob2
testDuplicateMessage :: HasCallStack => (ATransport, AStoreType) -> IO ()
testDuplicateMessage :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testDuplicateMessage ps = do
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1510,7 +1511,7 @@ testDuplicateMessage ps = do
disposeAgentClient alice2
disposeAgentClient bob2
testSkippedMessages :: HasCallStack => (ATransport, AStoreType) -> IO ()
testSkippedMessages :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testSkippedMessages (t, msType) = do
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1561,7 +1562,7 @@ testSkippedMessages (t, msType) = do
where
cfg' = (cfgMS msType) {serverStoreCfg = ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just $ StorePaths testStoreLogFile Nothing}
testDeliveryAfterSubscriptionError :: HasCallStack => (ATransport, AStoreType) -> IO ()
testDeliveryAfterSubscriptionError :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testDeliveryAfterSubscriptionError ps = do
(aId, bId) <- withAgentClients2 $ \a b -> do
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b
@@ -1579,7 +1580,7 @@ testDeliveryAfterSubscriptionError ps = do
withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False
ackMessage b aId 2 Nothing
testMsgDeliveryQuotaExceeded :: HasCallStack => (ATransport, AStoreType) -> IO ()
testMsgDeliveryQuotaExceeded :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testMsgDeliveryQuotaExceeded ps =
withAgentClients2 $ \a b -> withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
(aId, bId) <- makeConnection a b
@@ -1607,7 +1608,7 @@ testMsgDeliveryQuotaExceeded ps =
get a =##> \case ("", c, SENT 6) -> bId == c; _ -> False
liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events")
testExpireMessage :: HasCallStack => (ATransport, AStoreType) -> IO ()
testExpireMessage :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testExpireMessage ps =
withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a ->
withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do
@@ -1623,7 +1624,7 @@ testExpireMessage ps =
withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False
ackMessage b aId 2 Nothing
testExpireManyMessages :: HasCallStack => (ATransport, AStoreType) -> IO ()
testExpireManyMessages :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testExpireManyMessages ps =
withAgent 1 agentCfg {messageTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a ->
withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do
@@ -1662,7 +1663,7 @@ withUP a bId p =
\case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False
]
testExpireMessageQuota :: HasCallStack => (ATransport, AStoreType) -> IO ()
testExpireMessageQuota :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testExpireMessageQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1688,7 +1689,7 @@ testExpireMessageQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msg
ackMessage b' aId 4 Nothing
disposeAgentClient a
testExpireManyMessagesQuota :: (ATransport, AStoreType) -> IO ()
testExpireManyMessagesQuota :: (ASrvTransport, AStoreType) -> IO ()
testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 1, maxJournalMsgCount = 2} testPort $ \_ -> do
a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB
b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1725,7 +1726,7 @@ testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t (cfgMS msType)
ackMessage b' aId 4 Nothing
disposeAgentClient a
testRatchetSync :: HasCallStack => (ATransport, AStoreType) -> IO ()
testRatchetSync :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testRatchetSync ps = withAgentClients2 $ \alice bob ->
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
(aliceId, bobId, bob2) <- setupDesynchronizedRatchet alice bob
@@ -1799,7 +1800,7 @@ ratchetSyncP' cId rss = \case
cId' == cId && rss' == rss && ratchetSyncState == rss
_ -> False
testRatchetSyncServerOffline :: HasCallStack => (ATransport, AStoreType) -> IO ()
testRatchetSyncServerOffline :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testRatchetSyncServerOffline ps = withAgentClients2 $ \alice bob -> do
(aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ ->
setupDesynchronizedRatchet alice bob
@@ -1825,7 +1826,7 @@ serverUpP = \case
("", "", AEvt SAENone (UP _ _)) -> True
_ -> False
testRatchetSyncClientRestart :: HasCallStack => (ATransport, AStoreType) -> IO ()
testRatchetSyncClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testRatchetSyncClientRestart ps = do
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1850,7 +1851,7 @@ testRatchetSyncClientRestart ps = do
disposeAgentClient bob
disposeAgentClient bob3
testRatchetSyncSuspendForeground :: HasCallStack => (ATransport, AStoreType) -> IO ()
testRatchetSyncSuspendForeground :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testRatchetSyncSuspendForeground ps = do
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -1879,7 +1880,7 @@ testRatchetSyncSuspendForeground ps = do
disposeAgentClient bob
disposeAgentClient bob2
testRatchetSyncSimultaneous :: HasCallStack => (ATransport, AStoreType) -> IO ()
testRatchetSyncSimultaneous :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testRatchetSyncSimultaneous ps = do
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2
@@ -2006,7 +2007,7 @@ makeConnectionForUsers_ pqSupport sqSecured alice aliceUserId bob bobUserId = do
get bob ##> ("", aliceId, A.CON pqEnc)
pure (aliceId, bobId)
testInactiveNoSubs :: (ATransport, AStoreType) -> IO ()
testInactiveNoSubs :: (ASrvTransport, AStoreType) -> IO ()
testInactiveNoSubs (t, msType) = do
let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
withSmpServerConfigOn t cfg' testPort $ \_ ->
@@ -2016,7 +2017,7 @@ testInactiveNoSubs (t, msType) = do
Just (_, _, AEvt SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice)
pure ()
testInactiveWithSubs :: (ATransport, AStoreType) -> IO ()
testInactiveWithSubs :: (ASrvTransport, AStoreType) -> IO ()
testInactiveWithSubs (t, msType) = do
let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
withSmpServerConfigOn t cfg' testPort $ \_ ->
@@ -2027,7 +2028,7 @@ testInactiveWithSubs (t, msType) = do
-- and after 2 sec of inactivity no DOWN is sent as we have a live subscription
liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing
testActiveClientNotDisconnected :: (ATransport, AStoreType) -> IO ()
testActiveClientNotDisconnected :: (ASrvTransport, AStoreType) -> IO ()
testActiveClientNotDisconnected (t, msType) = do
let cfg' = (cfgMS msType) {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}}
withSmpServerConfigOn t cfg' testPort $ \_ ->
@@ -2070,7 +2071,7 @@ testSuspendingAgent =
liftIO $ foregroundAgent b
get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False
testSuspendingAgentCompleteSending :: (ATransport, AStoreType) -> IO ()
testSuspendingAgentCompleteSending :: (ASrvTransport, AStoreType) -> IO ()
testSuspendingAgentCompleteSending ps = withAgentClients2 $ \a b -> do
(aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
(aId, bId) <- makeConnection a b
@@ -2101,7 +2102,7 @@ testSuspendingAgentCompleteSending ps = withAgentClients2 $ \a b -> do
get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False
ackMessage a bId 4 Nothing
testSuspendingAgentTimeout :: (ATransport, AStoreType) -> IO ()
testSuspendingAgentTimeout :: (ASrvTransport, AStoreType) -> IO ()
testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do
(aId, _) <- withSmpServer ps . runRight $ do
(aId, bId) <- makeConnection a b
@@ -2120,7 +2121,7 @@ testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do
("", "", SUSPENDED) <- nGet b
pure ()
testBatchedSubscriptions :: Int -> Int -> (ATransport, AStoreType) -> IO ()
testBatchedSubscriptions :: Int -> Int -> (ASrvTransport, AStoreType) -> IO ()
testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) =
withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
conns <- runServers $ do
@@ -2312,7 +2313,7 @@ testAsyncCommands sqSecured alice bob baseId =
where
msgId = subtract baseId
testAsyncCommandsRestore :: (ATransport, AStoreType) -> IO ()
testAsyncCommandsRestore :: (ASrvTransport, AStoreType) -> IO ()
testAsyncCommandsRestore ps = do
alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB
bobId <- runRight $ createConnectionAsync alice 1 "1" True SCMInvitation (IKNoPQ PQSupportOn) SMSubscribe
@@ -2363,7 +2364,7 @@ testAcceptContactAsync sqSecured alice bob baseId =
where
msgId = subtract baseId
testDeleteConnectionAsync :: (ATransport, AStoreType) -> IO ()
testDeleteConnectionAsync :: (ASrvTransport, AStoreType) -> IO ()
testDeleteConnectionAsync ps =
withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \a -> do
connIds <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
@@ -2379,7 +2380,7 @@ testDeleteConnectionAsync ps =
get a =##> \case ("", "", DEL_CONNS cs) -> length cs == 3 && all (`elem` connIds) cs; _ -> False
liftIO $ noMessages a "nothing else should be delivered to alice"
testWaitDeliveryNoPending :: (ATransport, AStoreType) -> IO ()
testWaitDeliveryNoPending :: (ASrvTransport, AStoreType) -> IO ()
testWaitDeliveryNoPending ps = withAgentClients2 $ \alice bob ->
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
(aliceId, bobId) <- makeConnection alice bob
@@ -2407,7 +2408,7 @@ testWaitDeliveryNoPending ps = withAgentClients2 $ \alice bob ->
baseId = 1
msgId = subtract baseId
testWaitDelivery :: (ATransport, AStoreType) -> IO ()
testWaitDelivery :: (ASrvTransport, AStoreType) -> IO ()
testWaitDelivery ps =
withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
@@ -2461,7 +2462,7 @@ testWaitDelivery ps =
baseId = 1
msgId = subtract baseId
testWaitDeliveryAUTHErr :: (ATransport, AStoreType) -> IO ()
testWaitDeliveryAUTHErr :: (ASrvTransport, AStoreType) -> IO ()
testWaitDeliveryAUTHErr ps =
withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
@@ -2504,7 +2505,7 @@ testWaitDeliveryAUTHErr ps =
baseId = 1
msgId = subtract baseId
testWaitDeliveryTimeout :: (ATransport, AStoreType) -> IO ()
testWaitDeliveryTimeout :: (ASrvTransport, AStoreType) -> IO ()
testWaitDeliveryTimeout ps =
withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
@@ -2544,7 +2545,7 @@ testWaitDeliveryTimeout ps =
baseId = 1
msgId = subtract baseId
testWaitDeliveryTimeout2 :: (ATransport, AStoreType) -> IO ()
testWaitDeliveryTimeout2 :: (ASrvTransport, AStoreType) -> IO ()
testWaitDeliveryTimeout2 ps =
withAgent 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
@@ -2590,7 +2591,7 @@ testWaitDeliveryTimeout2 ps =
baseId = 1
msgId = subtract baseId
testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => (ATransport, AStoreType) -> IO ()
testJoinConnectionAsyncReplyErrorV8 :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do
let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
withAgent 1 cfg' initAgentServers testDB $ \a ->
@@ -2635,7 +2636,7 @@ testJoinConnectionAsyncReplyErrorV8 ps@(t, ASType qsType _) = do
smpCfg = smpCfgVPrev {serverVRange = V.mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion} -- before SKEY
}
testJoinConnectionAsyncReplyError :: HasCallStack => (ATransport, AStoreType) -> IO ()
testJoinConnectionAsyncReplyError :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do
let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]}
withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -2702,7 +2703,7 @@ testDeleteUserQuietly =
exchangeGreetingsMsgId 4 a bId b aId
liftIO $ noMessages a "nothing else should be delivered to alice"
testUsersNoServer :: HasCallStack => (ATransport, AStoreType) -> IO ()
testUsersNoServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testUsersNoServer ps = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do
(aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
(aId, bId) <- makeConnection a b
@@ -3137,7 +3138,7 @@ testCreateQueueAuth srvVersion clnt1 clnt2 sqSecured baseId = do
sndAuthAlg = if srvVersion >= authCmdsSMPVersion && clntVersion >= authCmdsSMPVersion then C.AuthAlg C.SX25519 else C.AuthAlg C.SEd25519
in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db
testSMPServerConnectionTest :: (ATransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
testSMPServerConnectionTest :: (ASrvTransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv =
withSmpServerConfigOn t (cfgMS msType) {newQueueBasicAuth} testPort2 $ \_ -> do
-- initially passed server is not running
@@ -3172,7 +3173,7 @@ testDeliveryReceipts =
ackMessage b aId 5 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e)
ackMessage b aId 5 Nothing
testDeliveryReceiptsVersion :: HasCallStack => (ATransport, AStoreType) -> IO ()
testDeliveryReceiptsVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testDeliveryReceiptsVersion ps = do
a <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB
b <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 1 3} initAgentServers testDB2
@@ -3225,7 +3226,7 @@ testDeliveryReceiptsVersion ps = do
disposeAgentClient a'
disposeAgentClient b'
testDeliveryReceiptsConcurrent :: HasCallStack => (ATransport, AStoreType) -> IO ()
testDeliveryReceiptsConcurrent :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
testDeliveryReceiptsConcurrent (t, msType) =
withSmpServerConfigOn t (cfgMS msType) {msgQueueQuota = 256, maxJournalMsgCount = 512} testPort $ \_ -> do
withAgentClients2 $ \a b -> do

34
tests/AgentTests/NotificationTests.hs
View File

@@ -81,7 +81,7 @@ import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgFlags (MsgFlags), NMsgMeta (..), NtfServer, ProtocolServer (..), SMPMsgMeta (..), SubscriptionMode (..))
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..))
import Simplex.Messaging.Transport (ATransport)
import Simplex.Messaging.Transport (ASrvTransport)
import System.Process (callCommand)
import Test.Hspec hiding (fit, it)
import UnliftIO
@@ -92,7 +92,7 @@ import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.SQLite.Simple.QQ (sql)
#endif
notificationTests :: (ATransport, AStoreType) -> Spec
notificationTests :: (ASrvTransport, AStoreType) -> Spec
notificationTests ps@(t, _) = do
describe "Managing notification tokens" $ do
it "should register and verify notification token" $
@@ -176,7 +176,7 @@ notificationTests ps@(t, _) = do
withNtfServerOn t ntfTestPort2 ntfTestDBCfg2 . withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf ->
testNotificationsNewToken apns ntf
testNtfMatrix :: HasCallStack => (ATransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
testNtfMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec
testNtfMatrix ps@(_, msType) runTest = do
describe "next and current" $ do
it "curr servers; curr clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfg runTest
@@ -193,7 +193,7 @@ testNtfMatrix ps@(_, msType) runTest = do
cfg' = cfgMS msType
cfgVPrev' = cfgVPrev msType
runNtfTestCfg :: HasCallStack => (ATransport, AStoreType) -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO ()
runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do
let smpCfg' = smpCfg {serverStoreCfg = serverStoreConfig msType}
withSmpServerConfigOn t smpCfg' testPort $ \_ ->
@@ -275,7 +275,7 @@ testNtfTokenSecondRegistration apns =
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestart :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestart t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -296,7 +296,7 @@ testNtfTokenServerRestart t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverify :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverify t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a -> do
@@ -319,7 +319,7 @@ testNtfTokenServerRestartReverify t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReverifyTimeout :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReverifyTimeout t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
@@ -354,7 +354,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregister :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregister t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -378,7 +378,7 @@ testNtfTokenServerRestartReregister t apns = do
NTActive <- checkNtfToken a' tkn
pure ()
testNtfTokenServerRestartReregisterTimeout :: ATransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenServerRestartReregisterTimeout t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do
@@ -419,7 +419,7 @@ getTestNtfTokenPort a =
Just NtfToken {ntfServer = ProtocolServer {port}} -> pure port
Nothing -> error "no active NtfToken"
testNtfTokenMultipleServers :: ATransport -> APNSMockServer -> IO ()
testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenMultipleServers t apns = do
let tkn = DeviceToken PPApnsTest "abcd"
withAgent 1 agentCfg initAgentServers2 testDB $ \a ->
@@ -443,7 +443,7 @@ testNtfTokenMultipleServers t apns = do
Left _ <- tryError (checkNtfToken a tkn)
pure ()
testNtfTokenChangeServers :: ATransport -> APNSMockServer -> IO ()
testNtfTokenChangeServers :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenChangeServers t apns =
withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> do
tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -473,7 +473,7 @@ testNtfTokenChangeServers t apns =
tkn <- registerTestToken a "qwer" NMInstant apns
checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive
testNtfTokenReRegisterInvalid :: ATransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalid :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalid t apns = do
tkn <- withNtfServer t $ do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -504,7 +504,7 @@ replaceSubstringInFile filePath oldText newText = do
let newContent = T.replace oldText newText content
TIO.writeFile filePath newContent
testNtfTokenReRegisterInvalidOnCheck :: ATransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalidOnCheck :: ASrvTransport -> APNSMockServer -> IO ()
testNtfTokenReRegisterInvalidOnCheck t apns = do
tkn <- withNtfServer t $ do
withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do
@@ -529,7 +529,7 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do
NTActive <- checkNtfToken a tkn1
pure ()
testRunNTFServerTests :: ATransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
testRunNTFServerTests t srv =
withNtfServer t $
withAgent 1 agentCfg initAgentServers testDB $ \a ->
@@ -751,7 +751,7 @@ testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> d
baseId = 1
msgId = subtract baseId
testNotificationsStoreLog :: (ATransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsStoreLog :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
withSmpServerStoreMsgLogOn ps testPort $ \_ -> do
(aliceId, bobId) <- withNtfServer t $ runRight $ do
@@ -786,7 +786,7 @@ testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do
withNtfServer t $ runRight_ $ do
void $ messageNotificationData alice apns
testNotificationsSMPRestart :: (ATransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestart :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do
(aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \threadId -> runRight $ do
(aliceId, bobId) <- makeConnection alice bob
@@ -814,7 +814,7 @@ testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do
get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False
liftIO $ killThread threadId
testNotificationsSMPRestartBatch :: Int -> (ATransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestartBatch :: Int -> (ASrvTransport, AStoreType) -> APNSMockServer -> IO ()
testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns =
withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do
threadDelay 1000000

7
tests/CLITests.hs
View File

@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
@@ -23,7 +24,7 @@ import qualified Network.HTTP2.Client as H2
import Simplex.FileTransfer.Server.Main (xftpServerCLI)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Server.Main (smpServerCLI, smpServerCLI_)
import Simplex.Messaging.Transport (TLS (..), defaultSupportedParams, defaultSupportedParamsHTTPS, simplexMQVersion, supportedClientSMPRelayVRange)
import Simplex.Messaging.Transport (TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS, simplexMQVersion, supportedClientSMPRelayVRange)
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), defaultTransportClientConfig, runTLSTransportClient, smpClientHandshake)
import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..))
import qualified Simplex.Messaging.Transport.HTTP2.Client as HC
@@ -192,9 +193,9 @@ smpServerTestStatic = do
runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange False
logDebug "Combined SMP works"
where
getCerts :: TLS -> [X.Certificate]
getCerts :: TLS 'TClient -> [X.Certificate]
getCerts tls =
let X.CertificateChain cc = tlsServerCerts tls
let X.CertificateChain cc = tlsPeerCert tls
in map (X.signedObject . X.getSigned) cc
#if defined(dbServerPostgres)

10
tests/NtfClient.hs
View File

@@ -174,7 +174,7 @@ ntfServerCfgVPrev =
smpCfg' = smpCfg smpAgentCfg'
serverVRange' = serverVRange smpCfg'
withNtfServerThreadOn :: HasCallStack => ATransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
withNtfServerThreadOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a
withNtfServerThreadOn t port' dbStoreConfig =
withNtfServerCfg ntfServerCfg {transports = [(port', t, False)], dbStoreConfig}
@@ -187,10 +187,10 @@ withNtfServerCfg cfg@NtfServerConfig {transports} =
(\started -> runNtfServerBlocking started cfg)
(pure ())
withNtfServerOn :: HasCallStack => ATransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a
withNtfServerOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a
withNtfServerOn t port' dbStoreConfig = withNtfServerThreadOn t port' dbStoreConfig . const
withNtfServer :: HasCallStack => ATransport -> (HasCallStack => IO a) -> IO a
withNtfServer :: HasCallStack => ASrvTransport -> (HasCallStack => IO a) -> IO a
withNtfServer t = withNtfServerOn t ntfTestPort ntfTestDBCfg
runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
@@ -199,7 +199,7 @@ runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
ntfServerTest ::
forall c smp.
(Transport c, Encoding smp) =>
TProxy c ->
TProxy c 'TServer ->
(Maybe TransmissionAuth, ByteString, ByteString, smp) ->
IO (Maybe TransmissionAuth, ByteString, ByteString, NtfResponse)
ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
@@ -213,7 +213,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
[(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h
pure (Nothing, corrId, qId, cmd)
ntfTest :: Transport c => TProxy c -> (THandleNTF c 'TClient -> IO ()) -> Expectation
ntfTest :: Transport c => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation
ntfTest _ test' = runNtfTest test' `shouldReturn` ()
data APNSMockRequest = APNSMockRequest

8
tests/NtfServerTests.hs
View File

@@ -47,14 +47,14 @@ import Test.Hspec hiding (fit, it)
import UnliftIO.STM
import Util
ntfServerTests :: ATransport -> Spec
ntfServerTests :: ASrvTransport -> Spec
ntfServerTests t = do
describe "Notifications server protocol syntax" $ ntfSyntaxTests t
describe "Notification subscriptions (NKEY)" $ testNotificationSubscription t createNtfQueueNKEY
-- describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription t createNtfQueueNEW
describe "Retried notification subscription" $ testRetriedNtfSubscription t
ntfSyntaxTests :: ATransport -> Spec
ntfSyntaxTests :: ASrvTransport -> Spec
ntfSyntaxTests (ATransport t) = do
it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", NRErr $ CMD UNKNOWN)
describe "NEW" $ do
@@ -97,7 +97,7 @@ v .-> key =
let J.Object o = v
in U.decodeLenient . encodeUtf8 <$> JT.parseEither (J..: key) o
testNotificationSubscription :: ATransport -> CreateQueueFunc -> Spec
testNotificationSubscription :: ASrvTransport -> CreateQueueFunc -> Spec
testNotificationSubscription (ATransport t) createQueue =
it "should create notification subscription and notify when message is received" $ do
g <- C.newRandom
@@ -180,7 +180,7 @@ testNotificationSubscription (ATransport t) createQueue =
smpServer3 `shouldBe` srv
notifierId3 `shouldBe` nId
testRetriedNtfSubscription :: ATransport -> Spec
testRetriedNtfSubscription :: ASrvTransport -> Spec
testRetriedNtfSubscription (ATransport t) =
it "should allow retrying to create notification subscription with the same token and key" $ do
g <- C.newRandom

37
tests/SMPClient.hs
View File

@@ -37,7 +37,6 @@ import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import System.Environment (lookupEnv)
import System.Info (os)
import System.Process (callCommand)
import Test.Hspec hiding (fit, it)
import UnliftIO.Concurrent
import qualified UnliftIO.Exception as E
@@ -282,20 +281,20 @@ proxyCfgJ2QS = \case
proxyVRangeV8 :: VersionRangeSMP
proxyVRangeV8 = mkVersionRange minServerSMPRelayVersion sendingProxySMPVersion
withSmpServerStoreMsgLogOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreMsgLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreMsgLogOn (t, msType) =
withSmpServerConfigOn t (cfgMS msType) {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
withSmpServerStoreLogOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerStoreLogOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) {serverStatsBackupFile = Just testServerStatsBackupFile}
withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerConfigOn :: HasCallStack => ASrvTransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerConfigOn t cfg' port' =
serverBracket
(\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing)
(threadDelay 10000)
withSmpServerThreadOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerThreadOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
withSmpServerThreadOn (t, msType) = withSmpServerConfigOn t (cfgMS msType)
serverBracket :: HasCallStack => (TMVar Bool -> IO ()) -> IO () -> (HasCallStack => ThreadId -> IO a) -> IO a
@@ -303,7 +302,7 @@ serverBracket process afterProcess f = do
started <- newEmptyTMVarIO
E.bracket
(forkIOWithUnmask (\unmask -> unmask (process started) `E.catchAny` handleStartError started))
(\t -> killThread t >> afterProcess >> waitFor started "stop" >> callCommand "sync")
(\t -> killThread t >> afterProcess >> waitFor started "stop")
(\t -> waitFor started "start" >> f t >>= \r -> r <$ threadDelay 100000)
where
-- it putTMVar is called twise to unlock both parts of the bracket in case of start failure
@@ -316,19 +315,19 @@ serverBracket process afterProcess f = do
Nothing -> error $ "server did not " <> s
_ -> pure ()
withSmpServerOn :: HasCallStack => (ATransport, AStoreType) -> ServiceName -> IO a -> IO a
withSmpServerOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> IO a -> IO a
withSmpServerOn ps port' = withSmpServerThreadOn ps port' . const
withSmpServer :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a
withSmpServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServer ps = withSmpServerOn ps testPort
withSmpServerProxy :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a
withSmpServerProxy :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServerProxy (t, msType) = withSmpServerConfigOn t (proxyCfgMS msType) testPort . const
withSmpServers2 :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a
withSmpServers2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgJ2QS qs) testPort2 . const
withSmpServersProxy2 :: HasCallStack => (ATransport, AStoreType) -> IO a -> IO a
withSmpServersProxy2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a
withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgJ2QS qs) testPort2 . const
runSmpTest :: forall c a. (HasCallStack, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
@@ -347,7 +346,7 @@ runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c
smpServerTest ::
forall c smp.
(Transport c, Encoding smp) =>
TProxy c ->
TProxy c 'TServer ->
(Maybe TransmissionAuth, ByteString, ByteString, smp) ->
IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg)
smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >> tGet' h
@@ -361,36 +360,36 @@ smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t >
[(Nothing, _, (CorrId corrId, EntityId qId, Right cmd))] <- tGet h
pure (Nothing, corrId, qId, cmd)
smpTest :: (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest :: (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest _ msType test' = runSmpTest msType test' `shouldReturn` ()
smpTest' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest' :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest' = (`smpTest` ASType SQSMemory SMSJournal)
smpTestN :: (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` ()
smpTest2' :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2' :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2' = (`smpTest2` ASType SQSMemory SMSJournal)
smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2 t msType = smpTest2Cfg (cfgMS msType) supportedClientSMPRelayVRange t
smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` ()
where
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
_test [h1, h2] = test' h1 h2
_test _ = error "expected 2 handles"
smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest3 _ msType test' = smpTestN msType 3 _test
where
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
_test [h1, h2, h3] = test' h1 h2 h3
_test _ = error "expected 3 handles"
smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
smpTest4 _ msType test' = smpTestN msType 4 _test
where
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()

80
tests/ServerTests.hs
View File

@@ -53,7 +53,7 @@ import Test.HUnit
import Test.Hspec hiding (fit, it)
import Util
serverTests :: SpecWith (ATransport, AStoreType)
serverTests :: SpecWith (ASrvTransport, AStoreType)
serverTests = do
describe "SMP queues" $ do
describe "NEW and KEY commands, SEND messages" testCreateSecure
@@ -147,7 +147,7 @@ decryptMsgV3 dhShared nonce body =
Right ClientRcvMsgQuota {} -> Left "ClientRcvMsgQuota"
Left e -> Left e
testCreateSecure :: SpecWith (ATransport, AStoreType)
testCreateSecure :: SpecWith (ASrvTransport, AStoreType)
testCreateSecure =
it "should create (NEW) and secure (KEY) queue" $ \(ATransport t, msType) ->
smpTest2 t msType $ \r s -> do
@@ -212,7 +212,7 @@ testCreateSecure =
Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage)
pure ()
testCreateSndSecure :: SpecWith (ATransport, AStoreType)
testCreateSndSecure :: SpecWith (ASrvTransport, AStoreType)
testCreateSndSecure =
it "should create (NEW) and secure (SKEY) queue by sender" $ \(ATransport t, msType) ->
smpTest2 t msType $ \r s -> do
@@ -259,7 +259,7 @@ testCreateSndSecure =
Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv s sKey ("bcda", sId, _SEND biggerMessage)
pure ()
testSndSecureProhibited :: SpecWith (ATransport, AStoreType)
testSndSecureProhibited :: SpecWith (ASrvTransport, AStoreType)
testSndSecureProhibited =
it "should create (NEW) without allowing sndSecure and fail to and secure queue by sender (SKEY)" $ \(ATransport t, msType) ->
smpTest2 t msType $ \r s -> do
@@ -274,7 +274,7 @@ testSndSecureProhibited =
(sId2, sId) #== "secures queue, same queue ID in response"
(err, ERR AUTH) #== "rejects SKEY when not allowed in NEW command"
testCreateUpdateKeys :: SpecWith (ATransport, AStoreType)
testCreateUpdateKeys :: SpecWith (ASrvTransport, AStoreType)
testCreateUpdateKeys =
it "should create (NEW) and updated recipient keys (RKEY)" $ \(ATransport t, msType) ->
smpTest t msType $ \h -> do
@@ -306,7 +306,7 @@ testCreateUpdateKeys =
Resp "11" _ (INFO _) <- signSendRecv h rKey' ("11", rId, QUE)
pure ()
testCreateDelete :: SpecWith (ATransport, AStoreType)
testCreateDelete :: SpecWith (ASrvTransport, AStoreType)
testCreateDelete =
it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ \(ATransport t, msType) ->
smpTest2 t msType $ \rh sh -> do
@@ -377,7 +377,7 @@ testCreateDelete =
Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, SUB)
(err10, ERR AUTH) #== "rejects SUB when deleted"
stressTest :: SpecWith (ATransport, AStoreType)
stressTest :: SpecWith (ASrvTransport, AStoreType)
stressTest =
it "should create many queues, disconnect and re-connect" $ \(ATransport t, msType) ->
smpTest3 t msType $ \h1 h2 h3 -> do
@@ -395,9 +395,9 @@ stressTest =
closeConnection $ connection h2
subscribeQueues h3
testAllowNewQueues :: SpecWith (ATransport, AStoreType)
testAllowNewQueues :: SpecWith (ASrvTransport, AStoreType)
testAllowNewQueues =
it "should prohibit creating new queues with allowNewQueues = False" $ \(ATransport (t :: TProxy c), msType) ->
it "should prohibit creating new queues with allowNewQueues = False" $ \(ATransport (t :: TProxy c 'TServer), msType) ->
withSmpServerConfigOn (ATransport t) (cfgMS msType) {allowNewQueues = False} testPort $ \_ ->
testSMPClient @c $ \h -> do
g <- C.newRandom
@@ -406,7 +406,7 @@ testAllowNewQueues =
Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub)
pure ()
testDuplex :: SpecWith (ATransport, AStoreType)
testDuplex :: SpecWith (ASrvTransport, AStoreType)
testDuplex =
it "should create 2 simplex connections and exchange messages" $ \(ATransport t, msType) ->
smpTest2 t msType $ \alice bob -> do
@@ -461,7 +461,7 @@ testDuplex =
Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK mId5)
(bDec mId5 msg5, Right "how are you bob") #== "message received from alice"
testSwitchSub :: SpecWith (ATransport, AStoreType)
testSwitchSub :: SpecWith (ASrvTransport, AStoreType)
testSwitchSub =
it "should create simplex connections and switch subscription to another TCP connection" $ \(ATransport t, msType) ->
smpTest3 t msType $ \rh1 rh2 sh -> do
@@ -506,9 +506,9 @@ testSwitchSub =
Nothing -> return ()
Just _ -> error "nothing else is delivered to the 1st TCP connection"
testGetCommand :: SpecWith (ATransport, AStoreType)
testGetCommand :: SpecWith (ASrvTransport, AStoreType)
testGetCommand =
it "should retrieve messages from the queue using GET command" $ \(ATransport (t :: TProxy c), msType) -> do
it "should retrieve messages from the queue using GET command" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
g <- C.newRandom
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
smpTest t msType $ \sh -> do
@@ -525,7 +525,7 @@ testGetCommand =
Resp "4" _ OK <- signSendRecv rh rKey ("4", rId, GET)
pure ()
testGetSubCommands :: SpecWith (ATransport, AStoreType)
testGetSubCommands :: SpecWith (ASrvTransport, AStoreType)
testGetSubCommands =
it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ \(ATransport t, msType) -> do
g <- C.newRandom
@@ -575,9 +575,9 @@ testGetSubCommands =
Resp "12" _ OK <- signSendRecv rh2 rKey ("12", rId, GET)
pure ()
testExceedQueueQuota :: SpecWith (ATransport, AStoreType)
testExceedQueueQuota :: SpecWith (ASrvTransport, AStoreType)
testExceedQueueQuota =
it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ \(ATransport (t :: TProxy c), msType) -> do
it "should reply with ERR QUOTA to sender and send QUOTA message to the recipient" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
withSmpServerConfigOn (ATransport t) (cfgMS msType) {msgQueueQuota = 2} testPort $ \_ ->
testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do
g <- C.newRandom
@@ -602,7 +602,7 @@ testExceedQueueQuota =
Resp "10" _ OK <- signSendRecv rh rKey ("10", rId, ACK mId4)
pure ()
testWithStoreLog :: SpecWith (ATransport, AStoreType)
testWithStoreLog :: SpecWith (ASrvTransport, AStoreType)
testWithStoreLog =
it "should store simplex queues to log and restore them after server restart" $ \(at@(ATransport t), msType) -> do
g <- C.newRandom
@@ -678,12 +678,12 @@ testWithStoreLog =
logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 6)
removeFile testStoreLogFile
where
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
serverStoreLogCfg :: AStoreType -> (ServerConfig, Bool)
@@ -705,7 +705,7 @@ logSize f = go (10 :: Int)
| n > 0 -> threadDelay 100000 >> go (n - 1)
| otherwise -> throwIO e
testRestoreMessages :: SpecWith (ATransport, AStoreType)
testRestoreMessages :: SpecWith (ASrvTransport, AStoreType)
testRestoreMessages =
it "should store messages on exit and restore on start" $ \(at@(ATransport t), msType) -> do
removeFileIfExists testStoreLogFile
@@ -783,12 +783,12 @@ testRestoreMessages =
whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir
removeFile testServerStatsBackupFile
where
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
checkStats :: ServerStatsData -> [RecipientId] -> Int -> Int -> Expectation
@@ -807,7 +807,7 @@ checkStats s qs sent received = do
IS.toList _week `shouldBe` map (hash . unEntityId) qs
IS.toList _month `shouldBe` map (hash . unEntityId) qs
testRestoreExpireMessages :: SpecWith (ATransport, AStoreType)
testRestoreExpireMessages :: SpecWith (ASrvTransport, AStoreType)
testRestoreExpireMessages =
it "should store messages on exit and restore on start (old / v2)" $ \(at@(ATransport t), msType) -> do
g <- C.newRandom
@@ -869,15 +869,15 @@ testRestoreExpireMessages =
removeFileIfExists testStoreMsgsFile
exportMessages False ms testStoreMsgsFile False
closeMsgStore ms
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
runTest _ test' server = do
testSMPClient test' `shouldReturn` ()
killThread server
runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation
runClient _ test' = testSMPClient test' `shouldReturn` ()
testPrometheusMetrics :: SpecWith (ATransport, AStoreType)
testPrometheusMetrics :: SpecWith (ASrvTransport, AStoreType)
testPrometheusMetrics =
it "should save Prometheus metrics" $ \(at, msType) -> do
let cfg' = (cfgMS msType) {prometheusInterval = Just 1}
@@ -895,7 +895,7 @@ createAndSecureQueue h sPub = do
(rId', rId) #== "same queue ID"
pure (sId, rId, rKey, dhShared)
testTiming :: SpecWith (ATransport, AStoreType)
testTiming :: SpecWith (ASrvTransport, AStoreType)
testTiming =
describe "should have similar time for auth error, whether queue exists or not, for all key types" $
forM_ timingTests $ \tst ->
@@ -967,7 +967,7 @@ testTiming =
]
ok `shouldBe` True
testMessageNotifications :: SpecWith (ATransport, AStoreType)
testMessageNotifications :: SpecWith (ASrvTransport, AStoreType)
testMessageNotifications =
it "should create simplex connection, subscribe notifier and deliver notifications" $ \(ATransport t, msType) -> do
g <- C.newRandom
@@ -1007,9 +1007,9 @@ testMessageNotifications =
Nothing -> pure ()
Just _ -> error "nothing else should be delivered to the 2nd notifier's TCP connection"
testMsgExpireOnSend :: SpecWith (ATransport, AStoreType)
testMsgExpireOnSend :: SpecWith (ASrvTransport, AStoreType)
testMsgExpireOnSend =
it "should expire messages that are not received before messageTTL on SEND" $ \(ATransport (t :: TProxy c), msType) -> do
it "should expire messages that are not received before messageTTL on SEND" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
g <- C.newRandom
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
@@ -1027,10 +1027,10 @@ testMsgExpireOnSend =
Nothing -> return ()
Just _ -> error "nothing else should be delivered"
testMsgExpireOnInterval :: SpecWith (ATransport, AStoreType)
testMsgExpireOnInterval :: SpecWith (ASrvTransport, AStoreType)
testMsgExpireOnInterval =
-- fails on ubuntu
xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c), msType) -> do
xit' "should expire messages that are not received before messageTTL after expiry interval" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
g <- C.newRandom
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}, idleQueueInterval = 1}
@@ -1047,9 +1047,9 @@ testMsgExpireOnInterval =
Nothing -> return ()
Just _ -> error "nothing should be delivered"
testMsgNOTExpireOnInterval :: SpecWith (ATransport, AStoreType)
testMsgNOTExpireOnInterval :: SpecWith (ASrvTransport, AStoreType)
testMsgNOTExpireOnInterval =
it "should block and unblock message queues" $ \(ATransport (t :: TProxy c), msType) -> do
it "should block and unblock message queues" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
g <- C.newRandom
(sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
let cfg' = (cfgMS msType) {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}}
@@ -1066,10 +1066,10 @@ testMsgNOTExpireOnInterval =
Nothing -> return ()
Just _ -> error "nothing else should be delivered"
testBlockMessageQueue :: SpecWith (ATransport, AStoreType)
testBlockMessageQueue :: SpecWith (ASrvTransport, AStoreType)
testBlockMessageQueue =
-- TODO [postgres]
xit "should return BLOCKED error when queue is blocked" $ \ps@(ATransport (t :: TProxy c), _) -> do
xit "should return BLOCKED error when queue is blocked" $ \ps@(ATransport (t :: TProxy c 'TServer), _) -> do
g <- C.newRandom
(rId, sId) <- withSmpServerStoreLogOn ps testPort $ runTest t $ \h -> do
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
@@ -1086,13 +1086,13 @@ testBlockMessageQueue =
Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub)
(sId2, sId) #== "same queue ID in response"
where
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a
runTest _ test' server = do
a <- testSMPClient test'
killThread server
pure a
testInvQueueLinkData :: SpecWith (ATransport, AStoreType)
testInvQueueLinkData :: SpecWith (ASrvTransport, AStoreType)
testInvQueueLinkData =
it "create and access queue short link data for 1-time invitation" $ \(ATransport t, msType) ->
smpTest2 t msType $ \r s -> do
@@ -1145,7 +1145,7 @@ testInvQueueLinkData =
Resp "9" rId2 (ERR AUTH) <- signSendRecv r rKey ("9", rId, LDEL)
rId2 `shouldBe` rId
testContactQueueLinkData :: SpecWith (ATransport, AStoreType)
testContactQueueLinkData :: SpecWith (ASrvTransport, AStoreType)
testContactQueueLinkData =
it "create and access queue short link data for contact address" $ \(ATransport t, msType) ->
smpTest2 t msType $ \r s -> do
@@ -1224,7 +1224,7 @@ instance Eq C.ASignature where
Just Refl -> s == s'
_ -> False
serverSyntaxTests :: ATransport -> Spec
serverSyntaxTests :: ASrvTransport -> Spec
serverSyntaxTests (ATransport t) = do
it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN)
describe "NEW" $ do

32
tests/Util.hs
View File

@@ -12,6 +12,7 @@ import Data.Either (partitionEithers)
import Data.List (tails)
import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities)
import System.Directory (doesFileExist, removeFile)
import System.Process (callCommand)
import System.Timeout (timeout)
import Test.Hspec hiding (fit, it)
import qualified Test.Hspec as Hspec
@@ -50,25 +51,28 @@ testLogLevel = LogError
instance Example a => Example (TestWrapper a) where
type Arg (TestWrapper a) = Arg a
evaluateExample (TestWrapper action) params hooks state = do
let tt = 120
runTest =
timeout (tt * 1000000) (evaluateExample action params hooks state) >>= \case
Just r -> pure r
Nothing -> throwIO $ userError $ "test timed out after " <> show tt <> " seconds"
retryTest = do
putStrLn "Retrying with more logs..."
setLogLevel LogNote
runTest `finally` setLogLevel testLogLevel -- change this to match log level in Test.hs
E.try runTest >>= \case
Right r -> case resultStatus r of
evaluateExample (TestWrapper action) params hooks state =
runTest `E.catches` [E.Handler onTestFailure, E.Handler onTestException]
where
tt = 120
runTest =
timeout (tt * 1000000) (evaluateExample action params hooks state) `finally` callCommand "sync" >>= \case
Just r -> pure r
Nothing -> throwIO $ userError $ "test timed out after " <> show tt <> " seconds"
onTestFailure :: ResultStatus -> IO Result
onTestFailure = \case
Failure loc_ reason -> do
putStrLn $ "Test failed: location " ++ show loc_ ++ ", reason: " ++ show reason
retryTest
_ -> pure r
Left (e :: E.SomeException) -> do
r -> E.throwIO r
onTestException :: SomeException -> IO Result
onTestException e = do
putStrLn $ "Test exception: " ++ show e
retryTest
retryTest = do
putStrLn "Retrying with more logs..."
setLogLevel LogDebug
runTest `finally` setLogLevel testLogLevel -- change this to match log level in Test.hs
it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)
it label action = Hspec.it label (TestWrapper action)