mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-12 02:22:45 +00:00
smp-server: add serverInfoBytes to THandleParams and related functions (#1836)
* smp-server: add serverInfoBytes to THandleParams and related functions * server information * fix test --------- Co-authored-by: Ed Asriyan <[email protected]>
This commit is contained in:
Evgeny
@@ -141,7 +141,7 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
|
||||
let HTTP2Client {sessionId, sessionALPN} = http2Client
|
||||
v = VersionXFTP 1
|
||||
thServerVRange = versionToRange v
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, serviceAuth = False}
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, serviceAuth = False, serverInfo = Nothing}
|
||||
logDebug $ "Client negotiated handshake protocol: " <> tshow sessionALPN
|
||||
thParams@THandleParams {thVersion} <- case sessionALPN of
|
||||
Just alpn
|
||||
|
||||
@@ -157,7 +157,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
reqBody <- getHTTP2Body r xftpBlockSize
|
||||
let v = VersionXFTP 1
|
||||
thServerVRange = versionToRange v
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, serviceAuth = False}
|
||||
thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, serviceAuth = False, serverInfo = Nothing}
|
||||
req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse, sniUsed, addCORS = addCORS'}
|
||||
flip runReaderT env $ case sessionALPN of
|
||||
Nothing -> processRequest req0
|
||||
|
||||
@@ -207,6 +207,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Agent.Store.Entity
|
||||
import Simplex.Messaging.Agent.Store.Interface (closeDBStore, execSQL, getCurrentMigrations)
|
||||
import Simplex.Messaging.Agent.Store.Shared (UpMigration (..), upMigration)
|
||||
import Simplex.Messaging.Server.Information (ServerPublicInfo)
|
||||
import qualified Simplex.Messaging.Agent.TSessionSubs as SS
|
||||
import Simplex.Messaging.Client (NetworkRequestMode (..), ProtocolClientError (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, TransportSessionMode (..), nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -675,11 +676,11 @@ getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c
|
||||
{-# INLINE getConnectionRatchetAdHash #-}
|
||||
|
||||
-- | Test protocol server
|
||||
testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Maybe ProtocolTestFailure)
|
||||
testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
testProtocolServer c nm userId srv = withAgentEnv' c $ case protocolTypeI @p of
|
||||
SPSMP -> runSMPServerTest c nm userId srv
|
||||
SPXFTP -> runXFTPServerTest c nm userId srv
|
||||
SPNTF -> runNTFServerTest c nm userId srv
|
||||
SPXFTP -> maybe (Right Nothing) Left <$> runXFTPServerTest c nm userId srv
|
||||
SPNTF -> maybe (Right Nothing) Left <$> runNTFServerTest c nm userId srv
|
||||
|
||||
-- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
|
||||
setNetworkConfig :: AgentClient -> NetworkConfig -> AE ()
|
||||
|
||||
@@ -304,11 +304,12 @@ import Simplex.Messaging.Protocol
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Protocol.Types
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.Server.Information (ServerPublicInfo)
|
||||
import Simplex.Messaging.Session
|
||||
import Simplex.Messaging.SystemTime
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion), TransportError (..), TransportPeer (..), shortLinksSMPVersion, newNtfCredsSMPVersion)
|
||||
import Simplex.Messaging.Transport (HandshakeError (..), SMPServiceRole (..), SMPVersion, ServiceCredentials (..), SessionId, THClientService' (..), THandleAuth (..), THandleParams (sessionId, thAuth, thVersion, serverInfo), TransportError (..), TransportPeer (..), shortLinksSMPVersion, newNtfCredsSMPVersion)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Transport.Credentials
|
||||
import Simplex.Messaging.Util
|
||||
@@ -1284,7 +1285,7 @@ data ProtocolTestFailure = ProtocolTestFailure
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
|
||||
runSMPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> SMPServerWithAuth -> AM' (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth srv auth) = do
|
||||
cfg <- getClientConfig c smpCfg
|
||||
C.AuthAlg ra <- asks $ rcvAuthAlg . config
|
||||
@@ -1306,8 +1307,8 @@ runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr
|
||||
_ -> secureSMPQueue smp nm rpKey rcvId sKey
|
||||
liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp nm rpKey rcvId
|
||||
ok <- netTimeoutInt (tcpTimeout $ networkConfig cfg) nm `timeout` closeProtocolClient smp
|
||||
pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
|
||||
Left e -> pure (Just $ testErr TSConnect e)
|
||||
pure $ r >> maybe (Left (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const $ Right $ serverInfo (thParams smp)) ok
|
||||
Left e -> pure $ Left (testErr TSConnect e)
|
||||
where
|
||||
addr = B.unpack $ strEncode srv
|
||||
testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
|
||||
|
||||
@@ -229,7 +229,8 @@ smpClientStub g sessionId thVersion thAuth = do
|
||||
blockSize = smpBlockSize,
|
||||
implySessId = True,
|
||||
encryptBlock = Nothing,
|
||||
serviceAuth = thVersion >= serviceCertsSMPVersion
|
||||
serviceAuth = thVersion >= serviceCertsSMPVersion,
|
||||
serverInfo = Nothing
|
||||
},
|
||||
sessionTs = ts,
|
||||
client_ =
|
||||
|
||||
@@ -160,5 +160,6 @@ ntfTHandle c = THandle {connection = c, params}
|
||||
thAuth = Nothing,
|
||||
implySessId = True,
|
||||
encryptBlock = Nothing,
|
||||
serviceAuth = False
|
||||
serviceAuth = False,
|
||||
serverInfo = Nothing
|
||||
}
|
||||
|
||||
@@ -56,6 +56,7 @@ import Control.Monad.Trans.Except
|
||||
import Control.Monad.STM (retry)
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Bifunctor (first, second)
|
||||
import qualified Data.Aeson as J
|
||||
import Data.ByteString.Base64 (encode)
|
||||
import qualified Data.ByteString.Builder as BLD
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
@@ -739,9 +740,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
|
||||
idSize <- asks $ queueIdBytes . config
|
||||
kh <- asks serverIdentity
|
||||
ks <- atomically . C.generateKeyPair =<< asks random
|
||||
ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config
|
||||
ServerConfig {smpServerVRange, smpHandshakeTimeout, information} <- asks config
|
||||
let serverInfo = LB.toStrict . J.encode <$> information
|
||||
labelMyThread $ "smp handshake for " <> transportName tp
|
||||
liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange $ getClientService ms g idSize) >>= \case
|
||||
liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange serverInfo $ getClientService ms g idSize) >>= \case
|
||||
Just (Right th) -> runClientTransport th
|
||||
_ -> pure ()
|
||||
|
||||
|
||||
@@ -26,7 +26,6 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Messaging.Agent.Protocol (ConnectionLink, ConnectionMode (..))
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
|
||||
|
||||
@@ -112,7 +111,7 @@ data Entity = Entity {name :: Text, country :: Maybe Text}
|
||||
deriving (Show)
|
||||
|
||||
data ServerContactAddress = ServerContactAddress
|
||||
{ simplex :: Maybe (ConnectionLink 'CMContact),
|
||||
{ simplex :: Maybe Text,
|
||||
email :: Maybe Text, -- it is recommended that it matches DNS email address, if either is present
|
||||
pgp :: Maybe PGPKey
|
||||
}
|
||||
|
||||
@@ -59,7 +59,7 @@ import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import qualified Data.Text.IO as T
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), connReqUriP')
|
||||
import Simplex.Messaging.Agent.Protocol (ConnectionLink (..), ConnectionMode (..), connReqUriP')
|
||||
import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
|
||||
import Simplex.Messaging.Client (HostMode (..), NetworkConfig (..), ProtocolClientConfig (..), SMPWebPortServers (..), SocksMode (..), defaultNetworkConfig, textToHostMode)
|
||||
@@ -85,7 +85,7 @@ import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupp
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultSocksProxy)
|
||||
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
|
||||
import Simplex.Messaging.Transport.Server (ServerCredentials (..), mkTransportServerConfig)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, ifM)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, ifM, safeDecodeUtf8)
|
||||
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
|
||||
import System.Exit (exitFailure)
|
||||
import System.FilePath (combine)
|
||||
@@ -787,12 +787,13 @@ serverPublicInfo ini = serverInfo <$!> infoValue "source_code"
|
||||
<$!> infoValue nameField
|
||||
countryValue field = (either error id . validCountryValue (T.unpack field) . T.unpack) <$!> infoValue field
|
||||
iniContacts simplexField emailField pgpKeyUriField pgpKeyFingerprintField =
|
||||
let simplex = either error id . parseAll linkP . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
|
||||
let addr :: Maybe (ConnectionLink 'CMContact) = either error id . parseAll linkP . encodeUtf8 <$!> eitherToMaybe (lookupValue "INFORMATION" simplexField ini)
|
||||
simplex = safeDecodeUtf8 . strEncode <$> addr
|
||||
linkP = CLFull <$> connReqUriP' Nothing <|> CLShort <$> strP
|
||||
email = infoValue emailField
|
||||
pkURI_ = infoValue pgpKeyUriField
|
||||
pkFingerprint_ = infoValue pgpKeyFingerprintField
|
||||
in case (simplex, email, pkURI_, pkFingerprint_) of
|
||||
in case (addr, email, pkURI_, pkFingerprint_) of
|
||||
(Nothing, Nothing, Nothing, _) -> Nothing
|
||||
(Nothing, Nothing, _, Nothing) -> Nothing
|
||||
(_, _, pkURI, pkFingerprint) -> Just ServerContactAddress {simplex, email, pgp = PGPKey <$> pkURI <*> pkFingerprint}
|
||||
|
||||
@@ -270,14 +270,14 @@ serverInfoSubsts simplexmqSource information =
|
||||
]
|
||||
admin ServerContactAddress {simplex, email, pgp} =
|
||||
[ ("admin", Just ""),
|
||||
("adminSimplex", strEncode <$> simplex),
|
||||
("adminSimplex", encodeUtf8 <$> simplex),
|
||||
("adminEmail", encodeUtf8 <$> email),
|
||||
("adminPGP", encodeUtf8 . pkURI <$> pgp),
|
||||
("adminPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp)
|
||||
]
|
||||
complaints ServerContactAddress {simplex, email, pgp} =
|
||||
[ ("complaints", Just ""),
|
||||
("complaintsSimplex", strEncode <$> simplex),
|
||||
("complaintsSimplex", encodeUtf8 <$> simplex),
|
||||
("complaintsEmail", encodeUtf8 <$> email),
|
||||
("complaintsPGP", encodeUtf8 . pkURI <$> pgp),
|
||||
("complaintsPGPFingerprint", encodeUtf8 . pkFingerprint <$> pgp)
|
||||
|
||||
@@ -52,6 +52,7 @@ module Simplex.Messaging.Transport
|
||||
clientNoticesSMPVersion,
|
||||
rcvServiceSMPVersion,
|
||||
namesSMPVersion,
|
||||
serverInfoSMPVersion,
|
||||
simplexMQVersion,
|
||||
smpBlockSize,
|
||||
TransportConfig (..),
|
||||
@@ -108,6 +109,7 @@ import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.TH as J
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (first)
|
||||
@@ -133,9 +135,10 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON)
|
||||
import Simplex.Messaging.Server.Information
|
||||
import Simplex.Messaging.Transport.Buffer
|
||||
import Simplex.Messaging.Transport.Shared
|
||||
import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith)
|
||||
import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith, (<$$>))
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.Messaging.Version.Internal
|
||||
import System.IO.Error (isEOFError)
|
||||
@@ -166,6 +169,7 @@ smpBlockSize = 16384
|
||||
-- 17 - create notification credentials with NEW (7/12/2025)
|
||||
-- 18 - support client notices (10/10/2025)
|
||||
-- 19 - service subscriptions to messages (10/20/2025)
|
||||
-- 20 - server public information in handshake (7/5/2026)
|
||||
|
||||
data SMPVersion
|
||||
|
||||
@@ -199,6 +203,9 @@ rcvServiceSMPVersion = VersionSMP 19
|
||||
namesSMPVersion :: VersionSMP
|
||||
namesSMPVersion = VersionSMP 20
|
||||
|
||||
serverInfoSMPVersion :: VersionSMP
|
||||
serverInfoSMPVersion = VersionSMP 20
|
||||
|
||||
minClientSMPRelayVersion :: VersionSMP
|
||||
minClientSMPRelayVersion = VersionSMP 14
|
||||
|
||||
@@ -459,7 +466,9 @@ data THandleParams v p = THandleParams
|
||||
-- | keys for additional transport encryption
|
||||
encryptBlock :: Maybe TSbChainKeys,
|
||||
-- | include service signature (or '0' if it is absent), based on protocol version
|
||||
serviceAuth :: Bool
|
||||
serviceAuth :: Bool,
|
||||
-- | JSON-encoded ServerPublicInfo from handshake, present when server version >= serverInfoSMPVersion
|
||||
serverInfo :: Maybe (Either String ServerPublicInfo)
|
||||
}
|
||||
|
||||
data THandleAuth (p :: TransportPeer) where
|
||||
@@ -511,7 +520,9 @@ data SMPServerHandshake = SMPServerHandshake
|
||||
sessionId :: SessionId,
|
||||
-- pub key to agree shared secrets for command authorization and entity ID encryption.
|
||||
-- todo C.PublicKeyX25519
|
||||
authPubKey :: CertChainPubKey
|
||||
authPubKey :: CertChainPubKey,
|
||||
-- | optional server public information (JSON-encoded ServerPublicInfo), sent when version >= serverInfoSMPVersion
|
||||
serverInfoBytes :: Maybe ByteString
|
||||
}
|
||||
|
||||
-- This is the third handshake message that SMP server sends to services
|
||||
@@ -597,12 +608,18 @@ instance Encoding SMPServiceRole where
|
||||
ifHasService :: VersionSMP -> a -> a -> a
|
||||
ifHasService v a b = if v >= serviceCertsSMPVersion then a else b
|
||||
|
||||
ifHasServerInfo :: VersionSMP -> a -> a -> a
|
||||
ifHasServerInfo v a b = if v >= serverInfoSMPVersion then a else b
|
||||
|
||||
instance Encoding SMPServerHandshake where
|
||||
smpEncode SMPServerHandshake {smpVersionRange, sessionId, authPubKey} =
|
||||
smpEncode (smpVersionRange, sessionId, authPubKey)
|
||||
smpEncode SMPServerHandshake {smpVersionRange, sessionId, authPubKey, serverInfoBytes} =
|
||||
smpEncode (smpVersionRange, sessionId, authPubKey) <> info
|
||||
where
|
||||
info = ifHasServerInfo (maxVersion smpVersionRange) (smpEncode (Large <$> serverInfoBytes)) ""
|
||||
smpP = do
|
||||
(smpVersionRange, sessionId, authPubKey) <- smpP
|
||||
pure SMPServerHandshake {smpVersionRange, sessionId, authPubKey}
|
||||
serverInfoBytes <- ifHasServerInfo (maxVersion smpVersionRange) (unLarge <$$> smpP) (pure Nothing)
|
||||
pure SMPServerHandshake {smpVersionRange, sessionId, authPubKey, serverInfoBytes}
|
||||
|
||||
-- newtype for CertificateChain and a session key signed with this certificate
|
||||
data CertChainPubKey = CertChainPubKey
|
||||
@@ -710,11 +727,12 @@ smpServerHandshake ::
|
||||
C.KeyPairX25519 ->
|
||||
C.KeyHash ->
|
||||
VersionRangeSMP ->
|
||||
Maybe ByteString ->
|
||||
(SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId) ->
|
||||
ExceptT TransportError IO (THandleSMP c 'TServer)
|
||||
smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVersionRange getService = do
|
||||
smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVersionRange serverInfoBytes getService = do
|
||||
let sk = C.signX509 srvSignKey $ C.publicToX509 k
|
||||
sendHandshake th $ SMPServerHandshake {sessionId, smpVersionRange, authPubKey = CertChainPubKey srvCert sk}
|
||||
sendHandshake th $ SMPServerHandshake {sessionId, smpVersionRange, authPubKey = CertChainPubKey srvCert sk, serverInfoBytes}
|
||||
SMPClientHandshake {smpVersion = v, keyHash, authPubKey = k', proxyServer, clientService} <- getHandshake th
|
||||
when (keyHash /= kh) $ throwE $ TEHandshake IDENTITY
|
||||
case compatibleVRange' smpVersionRange v of
|
||||
@@ -747,7 +765,7 @@ smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVersionRange getService =
|
||||
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
|
||||
smpClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandleSMP c 'TClient)
|
||||
smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKeys_ = do
|
||||
SMPServerHandshake {sessionId = sessId, smpVersionRange, authPubKey = certKey@(CertChainPubKey chain exact)} <- getHandshake th
|
||||
SMPServerHandshake {sessionId = sessId, smpVersionRange, authPubKey = certKey@(CertChainPubKey chain exact), serverInfoBytes} <- getHandshake th
|
||||
when (sessionId /= sessId) $ throwE TEBadSession
|
||||
case smpVersionRange `compatibleVRange` smpVRange of
|
||||
Just (Compatible vr) -> do
|
||||
@@ -766,7 +784,7 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKey
|
||||
hs = SMPClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer, clientService}
|
||||
sendHandshake th hs
|
||||
service <- mapM getClientService serviceKeys
|
||||
liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck proxyServer service
|
||||
liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck proxyServer service serverInfoBytes
|
||||
Nothing -> throwE TEVersion
|
||||
where
|
||||
th@THandle {params = THandleParams {sessionId}} = smpTHandle c
|
||||
@@ -784,14 +802,14 @@ smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRang
|
||||
smpTHandleServer th v vr pk k_ proxyServer peerClientService = do
|
||||
let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, sessSecret' = (`C.dh'` pk) <$!> k_}
|
||||
be <- blockEncryption th proxyServer thAuth
|
||||
pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys <$> be
|
||||
pure $ smpTHandle_ th v vr thAuth (uncurry TSbChainKeys <$> be) Nothing
|
||||
|
||||
smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> (C.PublicKeyX25519, CertChainPubKey) -> Bool -> Maybe THClientService -> IO (THandleSMP c 'TClient)
|
||||
smpTHandleClient th v vr pk_ (k, ck) proxyServer clientService = do
|
||||
smpTHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> VersionRangeSMP -> Maybe C.PrivateKeyX25519 -> (C.PublicKeyX25519, CertChainPubKey) -> Bool -> Maybe THClientService -> Maybe ByteString -> IO (THandleSMP c 'TClient)
|
||||
smpTHandleClient th v vr pk_ (k, ck) proxyServer clientService serverInfoBytes = do
|
||||
let thAuth = Just $! clientTHParams
|
||||
be <- blockEncryption th proxyServer thAuth
|
||||
-- swap is needed to use client's sndKey as server's rcvKey and vice versa
|
||||
pure $ smpTHandle_ th v vr thAuth $ uncurry TSbChainKeys . swap <$> be
|
||||
pure $ smpTHandle_ th v vr thAuth (uncurry TSbChainKeys . swap <$> be) serverInfoBytes
|
||||
where
|
||||
clientTHParams =
|
||||
THAuthClient
|
||||
@@ -811,8 +829,8 @@ blockEncryption THandle {params = THandleParams {sessionId}} proxyServer = \case
|
||||
be :: Maybe C.DhSecretX25519 -> IO (Maybe (TVar C.SbChainKey, TVar C.SbChainKey))
|
||||
be = mapM $ \(C.DhSecretX25519 secret) -> bimapM newTVarIO newTVarIO $ C.sbcInit sessionId secret
|
||||
|
||||
smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> Maybe TSbChainKeys -> THandleSMP c p
|
||||
smpTHandle_ th@THandle {params} v vr thAuth encryptBlock =
|
||||
smpTHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> VersionRangeSMP -> Maybe (THandleAuth p) -> Maybe TSbChainKeys -> Maybe ByteString -> THandleSMP c p
|
||||
smpTHandle_ th@THandle {params} v vr thAuth encryptBlock serverInfoBytes =
|
||||
-- TODO drop SMP v6: make thAuth non-optional
|
||||
-- * Note: update version-based parameters in smpTHParamsSetVersion as well.
|
||||
let params' =
|
||||
@@ -821,7 +839,8 @@ smpTHandle_ th@THandle {params} v vr thAuth encryptBlock =
|
||||
thServerVRange = vr,
|
||||
thAuth,
|
||||
encryptBlock,
|
||||
serviceAuth = v >= serviceCertsSMPVersion -- optional service signature will be encoded for all commands and responses
|
||||
serviceAuth = v >= serviceCertsSMPVersion, -- optional service signature will be encoded for all commands and responses
|
||||
serverInfo = J.eitherDecodeStrict' <$> serverInfoBytes
|
||||
}
|
||||
in (th :: THandleSMP c p) {params = params'}
|
||||
|
||||
@@ -859,7 +878,8 @@ smpTHandle c = THandle {connection = c, params}
|
||||
thAuth = Nothing,
|
||||
implySessId = True,
|
||||
encryptBlock = Nothing,
|
||||
serviceAuth = False
|
||||
serviceAuth = False,
|
||||
serverInfo = Nothing
|
||||
}
|
||||
|
||||
$(J.deriveJSON (sumTypeJSON id) ''HandshakeError)
|
||||
|
||||
@@ -8,6 +8,7 @@ import Data.Type.Equality
|
||||
import Simplex.Messaging.Agent.Protocol (ABinaryConnectionRequestUri (..), AMessage (..), AMessageReceipt (..), AgentMessage (..), APrivHeader (..), ShortLinkCreds (..))
|
||||
import Simplex.Messaging.Agent.Store
|
||||
import Simplex.Messaging.Client (ProxiedRelay (..))
|
||||
import Simplex.Messaging.Server.Information
|
||||
|
||||
instance (Eq rq, Eq sq) => Eq (SomeConn' rq sq) where
|
||||
SomeConn d c == SomeConn d' c' = case testEquality d d' of
|
||||
@@ -46,3 +47,15 @@ deriving instance Eq AMessageReceipt
|
||||
deriving instance Eq AMessage
|
||||
|
||||
deriving instance Eq AgentMessage
|
||||
|
||||
deriving instance Eq Entity
|
||||
|
||||
deriving instance Eq HostingType
|
||||
|
||||
deriving instance Eq PGPKey
|
||||
|
||||
deriving instance Eq ServerConditions
|
||||
|
||||
deriving instance Eq ServerContactAddress
|
||||
|
||||
deriving instance Eq ServerPublicInfo
|
||||
|
||||
@@ -105,6 +105,7 @@ import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Protocol.Types
|
||||
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.Information (ServerPublicInfo (..))
|
||||
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.Server.StoreLog (StoreLogRecord (..))
|
||||
@@ -561,17 +562,17 @@ functionalAPITests ps = do
|
||||
it "auth both " $ testBasicAuth ps True (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 2
|
||||
it "auth, disabled" $ testBasicAuth ps False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0
|
||||
describe "SMP server test via agent API" $ do
|
||||
it "should pass without basic auth" $ testSMPServerConnectionTest ps Nothing (noAuthSrv testSMPServer2) `shouldReturn` Nothing
|
||||
it "should pass without basic auth" $ testSMPServerConnectionTest ps Nothing (noAuthSrv testSMPServer2) `shouldReturn` Right (Just (Right testServerInformation))
|
||||
let srv1 = testSMPServer2 {keyHash = "1234"}
|
||||
it "should fail with incorrect fingerprint" $ do
|
||||
testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
|
||||
testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
|
||||
describe "server with password" $ do
|
||||
let auth = Just "abcd"
|
||||
srv = ProtoServerWithAuth testSMPServer2
|
||||
authErr = Just (ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH)
|
||||
it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Nothing
|
||||
it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` authErr
|
||||
it "should fail with incorrect password" $ testSMPServerConnectionTest ps auth (srv $ Just "wrong") `shouldReturn` authErr
|
||||
authErr = ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH
|
||||
it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation))
|
||||
it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` Left authErr
|
||||
it "should fail with incorrect password" $ testSMPServerConnectionTest ps auth (srv $ Just "wrong") `shouldReturn` Left authErr
|
||||
describe "getRatchetAdHash" $
|
||||
it "should return the same data for both peers" $
|
||||
withSmpServer ps testRatchetAdHash
|
||||
@@ -3326,8 +3327,8 @@ testWaitDeliveryAUTHErr ps =
|
||||
msgId = subtract baseId
|
||||
|
||||
testWaitDeliveryTimeout :: (ASrvTransport, AStoreType) -> IO ()
|
||||
testWaitDeliveryTimeout ps =
|
||||
withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
|
||||
testWaitDeliveryTimeout ps = do
|
||||
aliceId <- withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
|
||||
(aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do
|
||||
(aliceId, bobId) <- makeConnection alice bob
|
||||
@@ -3356,8 +3357,13 @@ testWaitDeliveryTimeout ps =
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
|
||||
liftIO $ threadDelay 100000
|
||||
pure aliceId
|
||||
|
||||
withSmpServerStoreLogOn ps testPort $ \_ -> do
|
||||
withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice ->
|
||||
withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do
|
||||
withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do
|
||||
subscribeAllConnections alice False Nothing
|
||||
subscribeAllConnections bob False Nothing
|
||||
nGet bob =##> \case ("", "", UP _ [cId]) -> cId == aliceId; _ -> False
|
||||
liftIO $ noMessages alice "nothing else should be delivered to alice"
|
||||
liftIO $ noMessages bob "nothing else should be delivered to bob"
|
||||
@@ -3921,14 +3927,28 @@ testCreateQueueAuth clnt1 clnt2 sqSecured baseId = do
|
||||
sndAuthAlg = C.AuthAlg C.SX25519
|
||||
in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db
|
||||
|
||||
testSMPServerConnectionTest :: (ASrvTransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure)
|
||||
testSMPServerConnectionTest :: (ASrvTransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv =
|
||||
withSmpServerConfigOn t cfg' testPort2 $ \_ -> do
|
||||
-- initially passed server is not running
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a NRMInteractive 1 srv
|
||||
where
|
||||
cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth}
|
||||
cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {newQueueBasicAuth, information = Just testServerInformation}
|
||||
|
||||
testServerInformation :: ServerPublicInfo
|
||||
testServerInformation =
|
||||
ServerPublicInfo
|
||||
{ sourceCode = "https://github.com/simplex-chat/simplexmq",
|
||||
usageConditions = Nothing,
|
||||
operator = Nothing,
|
||||
website = Nothing,
|
||||
adminContacts = Nothing,
|
||||
complaintsContacts = Nothing,
|
||||
hosting = Nothing,
|
||||
hostingType = Nothing,
|
||||
serverCountry = Nothing
|
||||
}
|
||||
|
||||
testRatchetAdHash :: HasCallStack => IO ()
|
||||
testRatchetAdHash =
|
||||
|
||||
@@ -82,6 +82,7 @@ import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Protocol (ErrorType (AUTH), NetworkError (..), 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.Server.Information (ServerPublicInfo (..))
|
||||
import Simplex.Messaging.Transport (ASrvTransport)
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig (..))
|
||||
import System.Process (callCommand)
|
||||
@@ -134,10 +135,10 @@ notificationTests ps@(t, _) = do
|
||||
withAPNSMockServer $ \apns ->
|
||||
testNtfTokenReRegisterInvalidOnCheck t apns
|
||||
describe "notification server tests" $ do
|
||||
it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Nothing
|
||||
it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Right Nothing
|
||||
let srv1 = testNtfServer {keyHash = "1234"}
|
||||
it "should fail with incorrect fingerprint" $ do
|
||||
testRunNTFServerTests t srv1 `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
|
||||
testRunNTFServerTests t srv1 `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
|
||||
describe "Managing notification subscriptions" $ do
|
||||
describe "should create notification subscription for existing connection" $
|
||||
testNtfMatrix ps testNotificationSubscriptionExistingConnection
|
||||
@@ -536,11 +537,11 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do
|
||||
NTActive <- checkNtfToken a tkn1
|
||||
pure ()
|
||||
|
||||
testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Maybe ProtocolTestFailure)
|
||||
testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
testRunNTFServerTests t srv =
|
||||
withNtfServer t $
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a NRMInteractive 1 $ ProtoServerWithAuth srv Nothing
|
||||
testProtocolServer a NRMInteractive 1 (ProtoServerWithAuth srv Nothing)
|
||||
|
||||
testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()
|
||||
testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do
|
||||
|
||||
@@ -247,7 +247,8 @@ testTHandleParams sessionId =
|
||||
thAuth = Nothing,
|
||||
implySessId = True,
|
||||
encryptBlock = Nothing,
|
||||
serviceAuth = True
|
||||
serviceAuth = True,
|
||||
serverInfo = Nothing
|
||||
}
|
||||
|
||||
testTHandleAuth :: TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe (THandleAuth 'TClient))
|
||||
|
||||
+8
-13
@@ -41,6 +41,7 @@ import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth)
|
||||
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
||||
import Simplex.Messaging.Server.Information (ServerPublicInfo)
|
||||
import Simplex.Messaging.Util (tshow)
|
||||
import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile)
|
||||
import System.FilePath ((</>))
|
||||
@@ -82,19 +83,19 @@ xftpAgentTests =
|
||||
it "if file is expired on server, should report error and continue receiving next file" testXFTPAgentExpiredOnServer
|
||||
it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs
|
||||
describe "XFTP server test via agent API" $ do
|
||||
it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Nothing
|
||||
it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Right Nothing
|
||||
let srv1 = testXFTPServer2 {keyHash = "1234"}
|
||||
it "should fail with incorrect fingerprint" $ \_ -> do
|
||||
testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Just (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
|
||||
testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError)
|
||||
describe "server with password" $ do
|
||||
let auth = Just "abcd"
|
||||
srv = ProtoServerWithAuth testXFTPServer2
|
||||
authErr = Just (ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH)
|
||||
it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Nothing
|
||||
it "should fail without password" $ \_ -> testXFTPServerTest auth (srv Nothing) `shouldReturn` authErr
|
||||
it "should fail with incorrect password" $ \_ -> testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` authErr
|
||||
authErr = ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH
|
||||
it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Right Nothing
|
||||
it "should fail without password" $ \_ -> testXFTPServerTest auth (srv Nothing) `shouldReturn` Left authErr
|
||||
it "should fail with incorrect password" $ \_ -> testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` Left authErr
|
||||
|
||||
testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
|
||||
testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
testXFTPServerTest newFileBasicAuth srv =
|
||||
withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2} $ \_ ->
|
||||
-- initially passed server is not running
|
||||
@@ -680,9 +681,3 @@ testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do
|
||||
void $ testReceive rcp (rfds !! 99) filePath
|
||||
void $ testReceive rcp (rfds !! 299) filePath
|
||||
void $ testReceive rcp (rfds !! 499) filePath
|
||||
|
||||
testXFTPServerTest_ :: HasCallStack => XFTPServerWithAuth -> IO (Maybe ProtocolTestFailure)
|
||||
testXFTPServerTest_ srv =
|
||||
-- initially passed server is not running
|
||||
withAgent 1 agentCfg initAgentServers testDB $ \a ->
|
||||
testProtocolServer a NRMInteractive 1 srv
|
||||
|
||||
Reference in New Issue
Block a user