mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-07-03 04:42:49 +00:00
Merge branch 'proxy' into ep/proxy-client-server
This commit is contained in:
Evgeny Poberezkin
@@ -51,7 +51,7 @@ import Simplex.Messaging.Protocol
|
||||
RecipientId,
|
||||
SenderId,
|
||||
)
|
||||
import Simplex.Messaging.Transport (ALPN, HandshakeError (VERSION), THandleAuth (..), THandleParams (..), TransportError (..), supportedParameters)
|
||||
import Simplex.Messaging.Transport (ALPN, HandshakeError (VERSION), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), supportedParameters)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost, alpn)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.Client
|
||||
@@ -64,7 +64,7 @@ import UnliftIO.Directory
|
||||
data XFTPClient = XFTPClient
|
||||
{ http2Client :: HTTP2Client,
|
||||
transportSession :: TransportSession FileResponse,
|
||||
thParams :: THandleParams XFTPVersion,
|
||||
thParams :: THandleParams XFTPVersion 'TClient,
|
||||
config :: XFTPClientConfig
|
||||
}
|
||||
|
||||
@@ -120,19 +120,21 @@ getXFTPClient g transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN
|
||||
atomically $ writeTVar clientVar $ Just c
|
||||
pure c
|
||||
|
||||
xftpClientHandshakeV1 :: TVar ChaChaDRG -> VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP -> ExceptT XFTPClientError IO THandleParamsXFTP
|
||||
xftpClientHandshakeV1 :: TVar ChaChaDRG -> VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient)
|
||||
xftpClientHandshakeV1 g serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do
|
||||
shs <- getServerHandshake
|
||||
shs@XFTPServerHandshake {authPubKey = ck} <- getServerHandshake
|
||||
(v, sk) <- processServerHandshake shs
|
||||
(k, pk) <- atomically $ C.generateKeyPair g
|
||||
sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash, authPubKey = k}
|
||||
pure thParams0 {thAuth = Just THandleAuth {peerPubKey = sk, privKey = pk}, thVersion = v}
|
||||
pure thParams0 {thAuth = Just THAuthClient {serverPeerPubKey = sk, serverCertKey = ck, clientPrivKey = pk}, thVersion = v}
|
||||
where
|
||||
getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake
|
||||
getServerHandshake = do
|
||||
let helloReq = H.requestNoBody "POST" "/" []
|
||||
HTTP2Response {respBody = HTTP2Body {bodyHead = shsBody}} <-
|
||||
liftError' (const $ PCEResponseError HANDSHAKE) $ sendRequest c helloReq Nothing
|
||||
liftHS . smpDecode =<< liftHS (C.unPad shsBody)
|
||||
processServerHandshake :: XFTPServerHandshake -> ExceptT XFTPClientError IO (VersionXFTP, C.PublicKeyX25519)
|
||||
processServerHandshake XFTPServerHandshake {xftpVersionRange, sessionId = serverSessId, authPubKey = serverAuth} = do
|
||||
unless (sessionId == serverSessId) $ throwError $ PCEResponseError SESSION
|
||||
case xftpVersionRange `compatibleVersion` serverVRange of
|
||||
@@ -145,6 +147,7 @@ xftpClientHandshakeV1 g serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessi
|
||||
_ -> throwError "bad certificate"
|
||||
pubKey <- maybe (throwError "bad server key type") (`C.verifyX509` exact) serverKey
|
||||
C.x509ToPublic (pubKey, []) >>= C.pubKey
|
||||
sendClientHandshake :: XFTPClientHandshake -> ExceptT XFTPClientError IO ()
|
||||
sendClientHandshake chs = do
|
||||
chs' <- liftHS $ C.pad (smpEncode chs) xftpBlockSize
|
||||
let chsReq = H.requestBuilder "POST" "/" [] $ byteString chs'
|
||||
|
||||
@@ -39,8 +39,8 @@ import Simplex.Messaging.Protocol
|
||||
ProtocolErrorType (..),
|
||||
ProtocolMsgTag (..),
|
||||
ProtocolType (..),
|
||||
RcvPublicDhKey,
|
||||
RcvPublicAuthKey,
|
||||
RcvPublicDhKey,
|
||||
RecipientId,
|
||||
SenderId,
|
||||
SentRawTransmission,
|
||||
@@ -48,14 +48,14 @@ import Simplex.Messaging.Protocol
|
||||
SndPublicAuthKey,
|
||||
Transmission,
|
||||
TransmissionForAuth (..),
|
||||
encodeTransmissionForAuth,
|
||||
encodeTransmission,
|
||||
encodeTransmissionForAuth,
|
||||
messageTagP,
|
||||
tDecodeParseValidate,
|
||||
tEncodeBatch1,
|
||||
tParse,
|
||||
)
|
||||
import Simplex.Messaging.Transport (THandleParams (..), TransportError (..))
|
||||
import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Util ((<$?>))
|
||||
|
||||
xftpBlockSize :: Int
|
||||
@@ -325,12 +325,12 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
|
||||
Just Refl -> Just c
|
||||
_ -> Nothing
|
||||
|
||||
xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
|
||||
xftpEncodeAuthTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion 'TClient -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
|
||||
xftpEncodeAuthTransmission thParams@THandleParams {thAuth} pKey (corrId, fId, msg) = do
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg)
|
||||
xftpEncodeBatch1 . (,tToSend) =<< authTransmission thAuth (Just pKey) corrId tForAuth
|
||||
|
||||
xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> Transmission c -> Either TransportError ByteString
|
||||
xftpEncodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> Transmission c -> Either TransportError ByteString
|
||||
xftpEncodeTransmission thParams (corrId, fId, msg) = do
|
||||
let t = encodeTransmission thParams (corrId, fId, msg)
|
||||
xftpEncodeBatch1 (Nothing, t)
|
||||
@@ -339,7 +339,7 @@ xftpEncodeTransmission thParams (corrId, fId, msg) = do
|
||||
xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
|
||||
xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize
|
||||
|
||||
xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
|
||||
xftpDecodeTransmission :: ProtocolEncoding XFTPVersion e c => THandleParams XFTPVersion p -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
|
||||
xftpDecodeTransmission thParams t = do
|
||||
t' <- first (const BLOCK) $ C.unPad t
|
||||
case tParse thParams t' of
|
||||
|
||||
@@ -56,7 +56,7 @@ import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..))
|
||||
import Simplex.Messaging.Transport (SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.Buffer (trimCR)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
|
||||
@@ -75,7 +75,7 @@ import qualified UnliftIO.Exception as E
|
||||
type M a = ReaderT XFTPEnv IO a
|
||||
|
||||
data XFTPTransportRequest = XFTPTransportRequest
|
||||
{ thParams :: THandleParamsXFTP,
|
||||
{ thParams :: THandleParamsXFTP 'TServer,
|
||||
reqBody :: HTTP2Body,
|
||||
request :: H.Request,
|
||||
sendResponse :: H.Response -> IO ()
|
||||
@@ -91,7 +91,7 @@ runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpSer
|
||||
|
||||
data Handshake
|
||||
= HandshakeSent C.PrivateKeyX25519
|
||||
| HandshakeAccepted THandleAuth VersionXFTP
|
||||
| HandshakeAccepted (THandleAuth 'TServer) VersionXFTP
|
||||
|
||||
xftpServer :: XFTPServerConfig -> TMVar Bool -> M ()
|
||||
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration} started = do
|
||||
@@ -120,7 +120,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
Nothing -> pure () -- handshake response sent
|
||||
Just thParams -> processRequest req0 {thParams} -- proceed with new version (XXX: may as well switch the request handler here)
|
||||
_ -> liftIO . sendResponse $ H.responseNoBody N.ok200 [] -- shouldn't happen: means server picked handshake protocol it doesn't know about
|
||||
xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion))
|
||||
xftpServerHandshakeV1 :: X.CertificateChain -> C.APrivateSignKey -> TMap SessionId Handshake -> XFTPTransportRequest -> M (Maybe (THandleParams XFTPVersion 'TServer))
|
||||
xftpServerHandshakeV1 chain serverSignKey sessions XFTPTransportRequest {thParams = thParams@THandleParams {sessionId}, reqBody = HTTP2Body {bodyHead}, sendResponse} = do
|
||||
s <- atomically $ TM.lookup sessionId sessions
|
||||
r <- runExceptT $ case s of
|
||||
@@ -138,18 +138,18 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
shs <- encodeXftp hs
|
||||
liftIO . sendResponse $ H.responseBuilder N.ok200 [] shs
|
||||
pure Nothing
|
||||
processClientHandshake privKey = do
|
||||
processClientHandshake pk = do
|
||||
unless (B.length bodyHead == xftpBlockSize) $ throwError HANDSHAKE
|
||||
body <- liftHS $ C.unPad bodyHead
|
||||
XFTPClientHandshake {xftpVersion, keyHash, authPubKey} <- liftHS $ smpDecode body
|
||||
kh <- asks serverIdentity
|
||||
unless (keyHash == kh) $ throwError HANDSHAKE
|
||||
unless (xftpVersion `isCompatible` supportedFileServerVRange) $ throwError HANDSHAKE
|
||||
let auth = THandleAuth {peerPubKey = authPubKey, privKey}
|
||||
let auth = THAuthServer {clientPeerPubKey = authPubKey, serverPrivKey = pk}
|
||||
atomically $ TM.insert sessionId (HandshakeAccepted auth xftpVersion) sessions
|
||||
liftIO . sendResponse $ H.responseNoBody N.ok200 []
|
||||
pure Nothing
|
||||
sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion))
|
||||
sendError :: XFTPErrorType -> M (Maybe (THandleParams XFTPVersion 'TServer))
|
||||
sendError err = do
|
||||
runExceptT (encodeXftp err) >>= \case
|
||||
Right bs -> liftIO . sendResponse $ H.responseBuilder N.ok200 [] bs
|
||||
@@ -326,7 +326,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
|
||||
|
||||
data VerificationResult = VRVerified XFTPRequest | VRFailed
|
||||
|
||||
verifyXFTPTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
|
||||
verifyXFTPTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
|
||||
verifyXFTPTransmission auth_ tAuth authorized fId cmd =
|
||||
case cmd of
|
||||
FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
@@ -51,7 +52,7 @@ import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol (CommandError)
|
||||
import Simplex.Messaging.Transport (HandshakeError (..), SessionId, THandle (..), THandleParams (..), TransportError (..))
|
||||
import Simplex.Messaging.Transport (HandshakeError (..), SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.HTTP2.File
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
import Simplex.Messaging.Version
|
||||
@@ -76,8 +77,8 @@ type VersionRangeXFTP = VersionRange XFTPVersion
|
||||
pattern VersionXFTP :: Word16 -> VersionXFTP
|
||||
pattern VersionXFTP v = Version v
|
||||
|
||||
type THandleXFTP c = THandle XFTPVersion c
|
||||
type THandleParamsXFTP = THandleParams XFTPVersion
|
||||
type THandleXFTP c p = THandle XFTPVersion c p
|
||||
type THandleParamsXFTP p = THandleParams XFTPVersion p
|
||||
|
||||
initialXFTPVersion :: VersionXFTP
|
||||
initialXFTPVersion = VersionXFTP 1
|
||||
@@ -89,7 +90,7 @@ supportedFileServerVRange :: VersionRangeXFTP
|
||||
supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
|
||||
|
||||
-- XFTP protocol does not support handshake
|
||||
xftpClientHandshakeStub :: c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c)
|
||||
xftpClientHandshakeStub :: c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
|
||||
xftpClientHandshakeStub _c _ks _keyHash _xftpVRange = throwError $ TEHandshake VERSION
|
||||
|
||||
data XFTPServerHandshake = XFTPServerHandshake
|
||||
|
||||
@@ -84,8 +84,8 @@ import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Except
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import qualified Data.Aeson.TH as J
|
||||
@@ -119,7 +119,7 @@ import System.Timeout (timeout)
|
||||
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
|
||||
data ProtocolClient v err msg = ProtocolClient
|
||||
{ action :: Maybe (Async ()),
|
||||
thParams :: THandleParams v,
|
||||
thParams :: THandleParams v 'TClient,
|
||||
sessionTs :: UTCTime,
|
||||
client_ :: PClient v err msg
|
||||
}
|
||||
@@ -138,7 +138,7 @@ data PClient v err msg = PClient
|
||||
msgQ :: Maybe (TBQueue (ServerTransmission v msg))
|
||||
}
|
||||
|
||||
smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe THandleAuth -> STM SMPClient
|
||||
smpClientStub :: TVar ChaChaDRG -> ByteString -> VersionSMP -> Maybe (THandleAuth 'TClient) -> STM SMPClient
|
||||
smpClientStub g sessionId thVersion thAuth = do
|
||||
connected <- newTVar False
|
||||
clientCorrId <- C.newRandomDRG g
|
||||
@@ -387,10 +387,10 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
raceAny_ ([send c' th, process c', receive c' th] <> [ping c' | smpPingInterval > 0])
|
||||
`finally` disconnected c'
|
||||
|
||||
send :: Transport c => ProtocolClient v err msg -> THandle v c -> IO ()
|
||||
send :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
|
||||
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPutLog h
|
||||
|
||||
receive :: Transport c => ProtocolClient v err msg -> THandle v c -> IO ()
|
||||
receive :: Transport c => ProtocolClient v err msg -> THandle v c 'TClient -> IO ()
|
||||
receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
|
||||
|
||||
ping :: ProtocolClient v err msg -> IO ()
|
||||
@@ -753,13 +753,13 @@ mkTransmission ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCo
|
||||
TM.insert corrId r sentCommands
|
||||
pure r
|
||||
|
||||
authTransmission :: Maybe THandleAuth -> Maybe C.APrivateAuthKey -> CorrId -> ByteString -> Either TransportError (Maybe TransmissionAuth)
|
||||
authTransmission :: Maybe (THandleAuth 'TClient) -> Maybe C.APrivateAuthKey -> CorrId -> ByteString -> Either TransportError (Maybe TransmissionAuth)
|
||||
authTransmission thAuth pKey_ (CorrId corrId) t = traverse authenticate pKey_
|
||||
where
|
||||
authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth
|
||||
authenticate (C.APrivateAuthKey a pk) = case a of
|
||||
C.SX25519 -> case thAuth of
|
||||
Just THandleAuth {peerPubKey} -> Right $ TAAuthenticator $ C.cbAuthenticate peerPubKey pk (C.cbNonce corrId) t
|
||||
Just THAuthClient {serverPeerPubKey = k} -> Right $ TAAuthenticator $ C.cbAuthenticate k pk (C.cbNonce corrId) t
|
||||
Nothing -> Left TENoServerAuth
|
||||
C.SEd25519 -> sign pk
|
||||
C.SEd448 -> sign pk
|
||||
|
||||
@@ -47,7 +47,7 @@ import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Server
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..))
|
||||
import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.Server (runTransportServer, tlsServerCredentials)
|
||||
import Simplex.Messaging.Util
|
||||
import System.Exit (exitFailure)
|
||||
@@ -339,7 +339,7 @@ updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do
|
||||
old <- atomically $ stateTVar tknStatus (,status)
|
||||
when (old /= status) $ withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
|
||||
|
||||
runNtfClientTransport :: Transport c => THandleNTF c -> M ()
|
||||
runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M ()
|
||||
runNtfClientTransport th@THandle {params} = do
|
||||
qSize <- asks $ clientQSize . config
|
||||
ts <- liftIO getSystemTime
|
||||
@@ -356,7 +356,7 @@ runNtfClientTransport th@THandle {params} = do
|
||||
clientDisconnected :: NtfServerClient -> IO ()
|
||||
clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
|
||||
|
||||
receive :: Transport c => THandleNTF c -> NtfServerClient -> M ()
|
||||
receive :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> M ()
|
||||
receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
|
||||
ts <- liftIO $ tGet th
|
||||
forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do
|
||||
@@ -371,7 +371,7 @@ receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ
|
||||
where
|
||||
write q t = atomically $ writeTBQueue q t
|
||||
|
||||
send :: Transport c => THandleNTF c -> NtfServerClient -> IO ()
|
||||
send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO ()
|
||||
send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
|
||||
t <- atomically $ readTBQueue sndQ
|
||||
void . liftIO $ tPut h [Right (Nothing, encodeTransmission params t)]
|
||||
@@ -382,7 +382,7 @@ send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
|
||||
|
||||
data VerificationResult = VRVerified NtfRequest | VRFailed
|
||||
|
||||
verifyNtfTransmission :: Maybe (THandleAuth, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
|
||||
verifyNtfTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult
|
||||
verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do
|
||||
st <- asks store
|
||||
case cmd of
|
||||
|
||||
@@ -24,16 +24,16 @@ import Numeric.Natural
|
||||
import Simplex.Messaging.Client.Agent
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Notifications.Protocol
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
|
||||
import Simplex.Messaging.Notifications.Server.Push.APNS
|
||||
import Simplex.Messaging.Notifications.Server.Stats
|
||||
import Simplex.Messaging.Notifications.Server.Store
|
||||
import Simplex.Messaging.Notifications.Server.StoreLog
|
||||
import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
|
||||
import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport (ATransport, THandleParams)
|
||||
import Simplex.Messaging.Transport (ATransport, THandleParams, TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams)
|
||||
import System.IO (IOMode (..))
|
||||
import System.Mem.Weak (Weak)
|
||||
@@ -161,13 +161,13 @@ data NtfRequest
|
||||
data NtfServerClient = NtfServerClient
|
||||
{ rcvQ :: TBQueue NtfRequest,
|
||||
sndQ :: TBQueue (Transmission NtfResponse),
|
||||
ntfThParams :: THandleParams NTFVersion,
|
||||
ntfThParams :: THandleParams NTFVersion 'TServer,
|
||||
connected :: TVar Bool,
|
||||
rcvActiveAt :: TVar SystemTime,
|
||||
sndActiveAt :: TVar SystemTime
|
||||
}
|
||||
|
||||
newNtfServerClient :: Natural -> THandleParams NTFVersion -> SystemTime -> STM NtfServerClient
|
||||
newNtfServerClient :: Natural -> THandleParams NTFVersion 'TServer -> SystemTime -> STM NtfServerClient
|
||||
newNtfServerClient qSize ntfThParams ts = do
|
||||
rcvQ <- newTBQueue qSize
|
||||
sndQ <- newTBQueue qSize
|
||||
|
||||
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Simplex.Messaging.Notifications.Transport where
|
||||
|
||||
@@ -18,9 +19,9 @@ import qualified Data.X509 as X
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Util (liftEitherWith)
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.Messaging.Version.Internal
|
||||
import Simplex.Messaging.Util (liftEitherWith)
|
||||
|
||||
ntfBlockSize :: Int
|
||||
ntfBlockSize = 512
|
||||
@@ -54,7 +55,7 @@ supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVers
|
||||
supportedServerNTFVRange :: VersionRangeNTF
|
||||
supportedServerNTFVRange = mkVersionRange initialNTFVersion currentServerNTFVersion
|
||||
|
||||
type THandleNTF c = THandle NTFVersion c
|
||||
type THandleNTF c p = THandle NTFVersion c p
|
||||
|
||||
data NtfServerHandshake = NtfServerHandshake
|
||||
{ ntfVersionRange :: VersionRangeNTF,
|
||||
@@ -111,7 +112,7 @@ encodeNtfAuthPubKey v k
|
||||
| otherwise = ""
|
||||
|
||||
-- | Notifcations server transport handshake.
|
||||
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c)
|
||||
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> 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
|
||||
@@ -121,11 +122,11 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do
|
||||
| keyHash /= kh ->
|
||||
throwError $ TEHandshake IDENTITY
|
||||
| v `isCompatible` ntfVRange ->
|
||||
pure $ ntfThHandle th v pk k'
|
||||
pure $ ntfThHandleServer th v pk k'
|
||||
| otherwise -> throwError $ TEHandshake VERSION
|
||||
|
||||
-- | Notifcations server client transport handshake.
|
||||
ntfClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c)
|
||||
ntfClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TClient)
|
||||
ntfClientHandshake c (k, pk) keyHash ntfVRange = do
|
||||
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
|
||||
NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
|
||||
@@ -133,23 +134,32 @@ ntfClientHandshake c (k, pk) keyHash ntfVRange = do
|
||||
then throwError TEBadSession
|
||||
else case ntfVersionRange `compatibleVersion` ntfVRange of
|
||||
Just (Compatible v) -> do
|
||||
sk_ <- forM sk' $ \exact -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
|
||||
ck_ <- forM sk' $ \signedKey -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
|
||||
serverKey <- getServerVerifyKey c
|
||||
pubKey <- C.verifyX509 serverKey exact
|
||||
C.x509ToPublic (pubKey, []) >>= C.pubKey
|
||||
pubKey <- C.verifyX509 serverKey signedKey
|
||||
(,(getServerCerts c, signedKey)) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
|
||||
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = Just k}
|
||||
pure $ ntfThHandle th v pk sk_
|
||||
pure $ ntfThHandleClient th v pk ck_
|
||||
Nothing -> throwError $ TEHandshake VERSION
|
||||
|
||||
ntfThHandle :: forall c. THandleNTF c -> VersionNTF -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleNTF c
|
||||
ntfThHandle th@THandle {params} v privKey k_ =
|
||||
-- TODO drop SMP v6: make thAuth non-optional
|
||||
let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
|
||||
v3 = v >= authBatchCmdsNTFVersion
|
||||
params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3}
|
||||
in (th :: THandleNTF c) {params = params'}
|
||||
ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleNTF c 'TServer
|
||||
ntfThHandleServer th v pk k_ =
|
||||
let thAuth = (\k -> THAuthServer {clientPeerPubKey = k, serverPrivKey = pk}) <$> k_
|
||||
in ntfThHandle_ th v thAuth
|
||||
|
||||
ntfTHandle :: Transport c => c -> THandleNTF c
|
||||
ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleNTF c 'TClient
|
||||
ntfThHandleClient th v pk ck_ =
|
||||
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, clientPrivKey = pk}) <$> ck_
|
||||
in ntfThHandle_ th v thAuth
|
||||
|
||||
ntfThHandle_ :: forall c p. THandleNTF c p -> VersionNTF -> Maybe (THandleAuth p) -> THandleNTF c p
|
||||
ntfThHandle_ th@THandle {params} v thAuth =
|
||||
-- TODO drop SMP v6: make thAuth non-optional
|
||||
let v3 = v >= authBatchCmdsNTFVersion
|
||||
params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3}
|
||||
in (th :: THandleNTF c p) {params = params'}
|
||||
|
||||
ntfTHandle :: Transport c => c -> THandleNTF c p
|
||||
ntfTHandle c = THandle {connection = c, params}
|
||||
where
|
||||
params = THandleParams {sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = VersionNTF 0, thAuth = Nothing, implySessId = False, batch = False}
|
||||
|
||||
@@ -1135,7 +1135,7 @@ data CommandError
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
-- | SMP transmission parser.
|
||||
transmissionP :: THandleParams v -> Parser RawTransmission
|
||||
transmissionP :: THandleParams v p -> Parser RawTransmission
|
||||
transmissionP THandleParams {sessionId, implySessId} = do
|
||||
authenticator <- smpP
|
||||
authorized <- A.takeByteString
|
||||
@@ -1149,10 +1149,10 @@ transmissionP THandleParams {sessionId, implySessId} = do
|
||||
command <- A.takeByteString
|
||||
pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command}
|
||||
|
||||
class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
|
||||
class (ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
|
||||
type ProtoCommand msg = cmd | cmd -> msg
|
||||
type ProtoType msg = (sch :: ProtocolType) | sch -> msg
|
||||
protocolClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c)
|
||||
protocolClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c 'TClient)
|
||||
protocolPing :: ProtoCommand msg
|
||||
protocolError :: msg -> Maybe err
|
||||
|
||||
@@ -1258,7 +1258,6 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
PFWD_ -> error "TODO: PFWD_"
|
||||
RFWD_ -> error "TODO: RFWD_"
|
||||
PRXY_ -> PRXY <$> (_smpP >>= either fail pure . strDecode) <*> _smpP
|
||||
|
||||
CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
|
||||
|
||||
fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
|
||||
@@ -1386,7 +1385,7 @@ instance Encoding CommandError where
|
||||
_ -> fail "bad command error type"
|
||||
|
||||
-- | Send signed SMP transmission to TCP transport.
|
||||
tPut :: Transport c => THandle v c -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
|
||||
tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
|
||||
tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (batch params) (blockSize params)
|
||||
where
|
||||
tPutBatch :: TransportBatch () -> IO [Either TransportError ()]
|
||||
@@ -1395,7 +1394,7 @@ tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (ba
|
||||
TBTransmissions s n _ -> replicate n <$> tPutLog th s
|
||||
TBTransmission s _ -> (: []) <$> tPutLog th s
|
||||
|
||||
tPutLog :: Transport c => THandle v c -> ByteString -> IO (Either TransportError ())
|
||||
tPutLog :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
|
||||
tPutLog th s = do
|
||||
r <- tPutBlock th s
|
||||
case r of
|
||||
@@ -1461,7 +1460,7 @@ tEncodeBatch1 t = lenEncode 1 `B.cons` tEncodeForBatch t
|
||||
-- tForAuth is lazy to avoid computing it when there is no key to sign
|
||||
data TransmissionForAuth = TransmissionForAuth {tForAuth :: ~ByteString, tToSend :: ByteString}
|
||||
|
||||
encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> TransmissionForAuth
|
||||
encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> TransmissionForAuth
|
||||
encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId} t =
|
||||
TransmissionForAuth {tForAuth, tToSend = if implySessId then t' else tForAuth}
|
||||
where
|
||||
@@ -1469,7 +1468,7 @@ encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId}
|
||||
t' = encodeTransmission_ v t
|
||||
{-# INLINE encodeTransmissionForAuth #-}
|
||||
|
||||
encodeTransmission :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> ByteString
|
||||
encodeTransmission :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> ByteString
|
||||
encodeTransmission THandleParams {thVersion = v, sessionId, implySessId} t =
|
||||
if implySessId then t' else smpEncode sessionId <> t'
|
||||
where
|
||||
@@ -1482,11 +1481,11 @@ encodeTransmission_ v (CorrId corrId, queueId, command) =
|
||||
{-# INLINE encodeTransmission_ #-}
|
||||
|
||||
-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
|
||||
tGetParse :: Transport c => THandle v c -> IO (NonEmpty (Either TransportError RawTransmission))
|
||||
tGetParse :: Transport c => THandle v c p -> IO (NonEmpty (Either TransportError RawTransmission))
|
||||
tGetParse th@THandle {params} = eitherList (tParse params) <$> tGetBlock th
|
||||
{-# INLINE tGetParse #-}
|
||||
|
||||
tParse :: THandleParams v -> ByteString -> NonEmpty (Either TransportError RawTransmission)
|
||||
tParse :: THandleParams v p -> ByteString -> NonEmpty (Either TransportError RawTransmission)
|
||||
tParse thParams@THandleParams {batch} s
|
||||
| batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts
|
||||
| otherwise = [tParse1 s]
|
||||
@@ -1498,10 +1497,10 @@ eitherList :: (a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b
|
||||
eitherList = either (\e -> [Left e])
|
||||
|
||||
-- | Receive client and server transmissions (determined by `cmd` type).
|
||||
tGet :: forall v err cmd c. (ProtocolEncoding v err cmd, Transport c) => THandle v c -> IO (NonEmpty (SignedTransmission err cmd))
|
||||
tGet :: forall v err cmd c p. (ProtocolEncoding v err cmd, Transport c) => THandle v c p -> IO (NonEmpty (SignedTransmission err cmd))
|
||||
tGet th@THandle {params} = L.map (tDecodeParseValidate params) <$> tGetParse th
|
||||
|
||||
tDecodeParseValidate :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v -> Either TransportError RawTransmission -> SignedTransmission err cmd
|
||||
tDecodeParseValidate :: forall v p err cmd. ProtocolEncoding v err cmd => THandleParams v p -> Either TransportError RawTransmission -> SignedTransmission err cmd
|
||||
tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \case
|
||||
Right RawTransmission {authenticator, authorized, sessId, corrId, entityId, command}
|
||||
| implySessId || sessId == sessionId ->
|
||||
|
||||
@@ -409,7 +409,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
|
||||
logError "Unauthorized control port command"
|
||||
hPutStrLn h "AUTH"
|
||||
|
||||
runClientTransport :: Transport c => THandleSMP c -> M ()
|
||||
runClientTransport :: Transport c => THandleSMP c 'TServer -> M ()
|
||||
runClientTransport th@THandle {params = THandleParams {thVersion, sessionId}} = do
|
||||
q <- asks $ tbqSize . config
|
||||
ts <- liftIO getSystemTime
|
||||
@@ -457,7 +457,7 @@ cancelSub sub =
|
||||
Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
|
||||
_ -> return ()
|
||||
|
||||
receive :: Transport c => THandleSMP c -> Client -> M ()
|
||||
receive :: Transport c => THandleSMP c 'TServer -> Client -> M ()
|
||||
receive th@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
|
||||
forever $ do
|
||||
@@ -478,7 +478,7 @@ receive th@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActi
|
||||
VRFailed -> Left (corrId, queueId, ERR AUTH)
|
||||
write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
|
||||
|
||||
send :: Transport c => THandleSMP c -> Client -> IO ()
|
||||
send :: Transport c => THandleSMP c 'TServer -> Client -> IO ()
|
||||
send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
|
||||
forever $ do
|
||||
@@ -493,7 +493,7 @@ send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do
|
||||
NMSG {} -> 0
|
||||
_ -> 1
|
||||
|
||||
disconnectTransport :: Transport c => THandle v c -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
|
||||
disconnectTransport :: Transport c => THandle v c 'TServer -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
|
||||
disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcvActiveAt sndActiveAt expCfg noSubscriptions = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disconnectTransport"
|
||||
loop
|
||||
@@ -514,7 +514,7 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
|
||||
-- - the queue or party key do not exist.
|
||||
-- In all cases, the time of the verification should depend only on the provided authorization type,
|
||||
-- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result.
|
||||
verifyTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult
|
||||
verifyTransmission :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult
|
||||
verifyTransmission auth_ tAuth authorized queueId cmd =
|
||||
case cmd of
|
||||
Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k
|
||||
@@ -539,7 +539,7 @@ verifyTransmission auth_ tAuth authorized queueId cmd =
|
||||
st <- asks queueStore
|
||||
atomically $ getQueue st party queueId
|
||||
|
||||
verifyCmdAuthorization :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool
|
||||
verifyCmdAuthorization :: Maybe (THandleAuth 'TServer, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool
|
||||
verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth
|
||||
where
|
||||
verify :: C.APublicAuthKey -> TransmissionAuth -> Bool
|
||||
@@ -551,12 +551,12 @@ verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAu
|
||||
C.SX25519 -> verifyCmdAuth auth_ k s authorized
|
||||
_ -> verifyCmdAuth auth_ dummyKeyX25519 s authorized `seq` False
|
||||
|
||||
verifyCmdAuth :: Maybe (THandleAuth, C.CbNonce) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> Bool
|
||||
verifyCmdAuth :: Maybe (THandleAuth 'TServer, C.CbNonce) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> Bool
|
||||
verifyCmdAuth auth_ k authenticator authorized = case auth_ of
|
||||
Just (THandleAuth {privKey}, nonce) -> C.cbVerify k privKey nonce authenticator authorized
|
||||
Just (THAuthServer {serverPrivKey = pk}, nonce) -> C.cbVerify k pk nonce authenticator authorized
|
||||
Nothing -> False
|
||||
|
||||
dummyVerifyCmd :: Maybe (THandleAuth, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool
|
||||
dummyVerifyCmd :: Maybe (THandleAuth 'TServer, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool
|
||||
dummyVerifyCmd auth_ authorized = \case
|
||||
TASignature (C.ASignature a s) -> C.verify' (dummySignKey a) s authorized
|
||||
TAAuthenticator s -> verifyCmdAuth auth_ dummyKeyX25519 s authorized
|
||||
|
||||
@@ -12,6 +12,7 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
-- |
|
||||
@@ -315,20 +316,20 @@ instance Transport TLS where
|
||||
-- * SMP transport
|
||||
|
||||
-- | The handle for SMP encrypted transport connection over Transport.
|
||||
data THandle v c = THandle
|
||||
data THandle v c p = THandle
|
||||
{ connection :: c,
|
||||
params :: THandleParams v
|
||||
params :: THandleParams v p
|
||||
}
|
||||
|
||||
type THandleSMP c = THandle SMPVersion c
|
||||
type THandleSMP c p = THandle SMPVersion c p
|
||||
|
||||
data THandleParams v = THandleParams
|
||||
data THandleParams v p = THandleParams
|
||||
{ sessionId :: SessionId,
|
||||
blockSize :: Int,
|
||||
-- | agreed server protocol version
|
||||
thVersion :: Version v,
|
||||
-- | peer public key for command authorization and shared secrets for entity ID encryption
|
||||
thAuth :: Maybe THandleAuth,
|
||||
thAuth :: Maybe (THandleAuth p),
|
||||
-- | do NOT send session ID in transmission, but include it into signed message
|
||||
-- based on protocol version
|
||||
implySessId :: Bool,
|
||||
@@ -337,10 +338,18 @@ data THandleParams v = THandleParams
|
||||
batch :: Bool
|
||||
}
|
||||
|
||||
data THandleAuth = THandleAuth
|
||||
{ peerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key
|
||||
privKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server)
|
||||
}
|
||||
data THandleAuth (p :: TransportPeer) where
|
||||
THAuthClient ::
|
||||
{ serverPeerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key
|
||||
serverCertKey :: (X.CertificateChain, X.SignedExact X.PubKey), -- the key here is clientPrivKey signed with server certificate
|
||||
clientPrivKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server)
|
||||
} ->
|
||||
THandleAuth 'TClient
|
||||
THAuthServer ::
|
||||
{ clientPeerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key
|
||||
serverPrivKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server)
|
||||
} ->
|
||||
THandleAuth 'TServer
|
||||
|
||||
-- | TLS-unique channel binding
|
||||
type SessionId = ByteString
|
||||
@@ -443,13 +452,13 @@ serializeTransportError = \case
|
||||
TEHandshake e -> "HANDSHAKE " <> bshow e
|
||||
|
||||
-- | Pad and send block to SMP transport.
|
||||
tPutBlock :: Transport c => THandle v c -> ByteString -> IO (Either TransportError ())
|
||||
tPutBlock :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
|
||||
tPutBlock THandle {connection = c, params = THandleParams {blockSize}} block =
|
||||
bimapM (const $ pure TELargeMsg) (cPut c) $
|
||||
C.pad block blockSize
|
||||
|
||||
-- | Receive block from SMP transport.
|
||||
tGetBlock :: Transport c => THandle v c -> IO (Either TransportError ByteString)
|
||||
tGetBlock :: Transport c => THandle v c p -> IO (Either TransportError ByteString)
|
||||
tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
|
||||
msg <- cGet c blockSize
|
||||
if B.length msg == blockSize
|
||||
@@ -459,7 +468,7 @@ tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
|
||||
-- | 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)
|
||||
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
|
||||
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
|
||||
sk = C.signX509 serverSignKey $ C.publicToX509 k
|
||||
@@ -470,13 +479,13 @@ smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do
|
||||
| keyHash /= kh ->
|
||||
throwE $ TEHandshake IDENTITY
|
||||
| v `isCompatible` smpVRange ->
|
||||
pure $ smpThHandle th v pk k'
|
||||
pure $ smpThHandleServer th v pk k'
|
||||
| otherwise -> throwE $ TEHandshake VERSION
|
||||
|
||||
-- | Client SMP transport handshake.
|
||||
--
|
||||
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
|
||||
smpClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c)
|
||||
smpClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> ExceptT TransportError IO (THandleSMP c 'TClient)
|
||||
smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do
|
||||
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
|
||||
ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
|
||||
@@ -484,33 +493,42 @@ smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do
|
||||
then throwE TEBadSession
|
||||
else case smpVersionRange `compatibleVersion` smpVRange of
|
||||
Just (Compatible v) -> do
|
||||
sk_ <- forM authPubKey $ \(X.CertificateChain cert, exact) ->
|
||||
ck_ <- forM authPubKey $ \certKey@(X.CertificateChain cert, exact) ->
|
||||
liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
|
||||
case cert of
|
||||
[_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
|
||||
_ -> throwError "bad certificate"
|
||||
serverKey <- getServerVerifyKey c
|
||||
pubKey <- C.verifyX509 serverKey exact
|
||||
C.x509ToPublic (pubKey, []) >>= C.pubKey
|
||||
(,certKey) <$> (C.x509ToPublic (pubKey, []) >>= C.pubKey)
|
||||
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = Just k}
|
||||
pure $ smpThHandle th v pk sk_
|
||||
pure $ smpThHandleClient th v pk ck_
|
||||
Nothing -> throwE $ TEHandshake VERSION
|
||||
|
||||
smpThHandle :: forall c. THandleSMP c -> VersionSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c
|
||||
smpThHandle th@THandle {params} v privKey k_ =
|
||||
-- TODO drop SMP v6: make thAuth non-optional
|
||||
let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
|
||||
params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion}
|
||||
in (th :: THandleSMP c) {params = params'}
|
||||
smpThHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandleSMP c 'TServer
|
||||
smpThHandleServer th v pk k_ =
|
||||
let thAuth = (\k -> THAuthServer {clientPeerPubKey = k, serverPrivKey = pk}) <$> k_
|
||||
in smpThHandle_ th v thAuth
|
||||
|
||||
sendHandshake :: (Transport c, Encoding smp) => THandle v c -> smp -> ExceptT TransportError IO ()
|
||||
smpThHandleClient :: forall c. THandleSMP c 'TClient -> VersionSMP -> C.PrivateKeyX25519 -> Maybe (C.PublicKeyX25519, (X.CertificateChain, X.SignedExact X.PubKey)) -> THandleSMP c 'TClient
|
||||
smpThHandleClient th v pk ck_ =
|
||||
let thAuth = (\(k, ck) -> THAuthClient {serverPeerPubKey = k, serverCertKey = ck, clientPrivKey = pk}) <$> ck_
|
||||
in smpThHandle_ th v thAuth
|
||||
|
||||
smpThHandle_ :: forall c p. THandleSMP c p -> VersionSMP -> Maybe (THandleAuth p) -> THandleSMP c p
|
||||
smpThHandle_ th@THandle {params} v thAuth =
|
||||
-- TODO drop SMP v6: make thAuth non-optional
|
||||
let params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion}
|
||||
in (th :: THandleSMP c p) {params = params'}
|
||||
|
||||
sendHandshake :: (Transport c, Encoding smp) => THandle v c p -> smp -> ExceptT TransportError IO ()
|
||||
sendHandshake th = ExceptT . tPutBlock th . smpEncode
|
||||
|
||||
-- ignores tail bytes to allow future extensions
|
||||
getHandshake :: (Transport c, Encoding smp) => THandle v c -> ExceptT TransportError IO smp
|
||||
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
|
||||
smpTHandle :: Transport c => c -> THandleSMP c p
|
||||
smpTHandle c = THandle {connection = c, params}
|
||||
where
|
||||
params = THandleParams {sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = VersionSMP 0, thAuth = Nothing, implySessId = False, batch = True}
|
||||
|
||||
@@ -1,7 +1,9 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module CoreTests.BatchingTests (batchingTests) where
|
||||
|
||||
@@ -11,6 +13,9 @@ import Crypto.Random (ChaChaDRG)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.X509 as X
|
||||
import qualified Data.X509.CertificateStore as XS
|
||||
import qualified Data.X509.File as XF
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Protocol
|
||||
@@ -314,7 +319,7 @@ randomSEND_ a v sessId len = do
|
||||
TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, sId, Cmd SSender $ SEND noMsgFlags msg)
|
||||
pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) corrId tForAuth
|
||||
|
||||
testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion
|
||||
testTHandleParams :: VersionSMP -> ByteString -> THandleParams SMPVersion 'TClient
|
||||
testTHandleParams v sessionId =
|
||||
THandleParams
|
||||
{ sessionId,
|
||||
@@ -325,11 +330,17 @@ testTHandleParams v sessionId =
|
||||
batch = True
|
||||
}
|
||||
|
||||
testTHandleAuth :: VersionSMP -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe THandleAuth)
|
||||
testTHandleAuth v g (C.APublicAuthKey a k) = case a of
|
||||
testTHandleAuth :: VersionSMP -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe (THandleAuth 'TClient))
|
||||
testTHandleAuth v g (C.APublicAuthKey a serverPeerPubKey) = case a of
|
||||
C.SX25519 | v >= authCmdsSMPVersion -> do
|
||||
(_, privKey) <- atomically $ C.generateKeyPair g
|
||||
pure $ Just THandleAuth {peerPubKey = k, privKey}
|
||||
(_, clientPrivKey) <- atomically $ C.generateKeyPair @'C.X25519 g
|
||||
ca <- head <$> XS.readCertificates "tests/fixtures/ca.crt"
|
||||
serverCert <- head <$> XS.readCertificates "tests/fixtures/server.crt"
|
||||
serverKey <- head <$> XF.readKeyFile "tests/fixtures/server.key"
|
||||
signKey <- either error pure $ C.x509ToPrivate (serverKey, []) >>= C.privKey @C.APrivateSignKey
|
||||
(serverAuthPub, _) <- atomically $ C.generateKeyPair @'C.X25519 g
|
||||
let serverCertKey = (X.CertificateChain [serverCert, ca], C.signX509 signKey $ C.toPubKey C.publicToX509 serverAuthPub)
|
||||
pure $ Just THAuthClient {serverPeerPubKey, serverCertKey, clientPrivKey}
|
||||
_ -> pure Nothing
|
||||
|
||||
randomSENDCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg)
|
||||
|
||||
+4
-4
@@ -70,7 +70,7 @@ testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
|
||||
ntfTestStoreLogFile :: FilePath
|
||||
ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log"
|
||||
|
||||
testNtfClient :: Transport c => (THandleNTF c -> IO a) -> IO a
|
||||
testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
|
||||
testNtfClient client = do
|
||||
Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
|
||||
runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> do
|
||||
@@ -139,7 +139,7 @@ withNtfServerOn t port' = withNtfServerThreadOn t port' . const
|
||||
withNtfServer :: ATransport -> IO a -> IO a
|
||||
withNtfServer t = withNtfServerOn t ntfTestPort
|
||||
|
||||
runNtfTest :: forall c a. Transport c => (THandleNTF c -> IO a) -> IO a
|
||||
runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
|
||||
runNtfTest test = withNtfServer (transport @c) $ testNtfClient test
|
||||
|
||||
ntfServerTest ::
|
||||
@@ -150,7 +150,7 @@ ntfServerTest ::
|
||||
IO (Maybe TransmissionAuth, ByteString, ByteString, NtfResponse)
|
||||
ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
|
||||
where
|
||||
tPut' :: THandleNTF c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
|
||||
tPut' :: THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
|
||||
tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
|
||||
let t' = if implySessId then smpEncode (corrId, queueId, smp) else smpEncode (sessionId, corrId, queueId, smp)
|
||||
[Right ()] <- tPut h [Right (sig, t')]
|
||||
@@ -159,7 +159,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h
|
||||
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
|
||||
pure (Nothing, corrId, qId, cmd)
|
||||
|
||||
ntfTest :: Transport c => TProxy c -> (THandleNTF c -> IO ()) -> Expectation
|
||||
ntfTest :: Transport c => TProxy c -> (THandleNTF c 'TClient -> IO ()) -> Expectation
|
||||
ntfTest _ test' = runNtfTest test' `shouldReturn` ()
|
||||
|
||||
data APNSMockRequest = APNSMockRequest
|
||||
|
||||
@@ -6,8 +6,8 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
||||
|
||||
module NtfServerTests where
|
||||
|
||||
@@ -72,13 +72,13 @@ pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command
|
||||
|
||||
deriving instance Eq NtfResponse
|
||||
|
||||
sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c -> (Maybe TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
|
||||
sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
|
||||
sendRecvNtf h@THandle {params} (sgn, corrId, qId, cmd) = do
|
||||
let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
|
||||
Right () <- tPut1 h (sgn, tToSend)
|
||||
tGet1 h
|
||||
|
||||
signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c -> C.APrivateAuthKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
|
||||
signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandleNTF c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse)
|
||||
signSendRecvNtf h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
|
||||
Right () <- tPut1 h (authorize tForAuth, tToSend)
|
||||
|
||||
+18
-18
@@ -67,15 +67,15 @@ xit'' d t = do
|
||||
ci <- runIO $ lookupEnv "CI"
|
||||
(if ci == Just "true" then skip "skipped on CI" . it d else it d) t
|
||||
|
||||
testSMPClient :: Transport c => (THandleSMP c -> IO a) -> IO a
|
||||
testSMPClient :: Transport c => (THandleSMP c 'TClient -> IO a) -> IO a
|
||||
testSMPClient = testSMPClientVR supportedClientSMPRelayVRange
|
||||
|
||||
testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c -> IO a) -> IO a
|
||||
testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
|
||||
testSMPClientVR vr client = do
|
||||
Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
|
||||
testSMPClient_ useHost testPort vr client
|
||||
|
||||
testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> (THandleSMP c -> IO a) -> IO a
|
||||
testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a
|
||||
testSMPClient_ host port vr client = do
|
||||
runTransportClient defaultTransportClientConfig Nothing host port (Just testKeyHash) $ \h -> do
|
||||
g <- C.newRandom
|
||||
@@ -119,7 +119,7 @@ cfgV7 :: ServerConfig
|
||||
cfgV7 = cfg {smpServerVRange = mkVersionRange batchCmdsSMPVersion authCmdsSMPVersion}
|
||||
|
||||
proxyCfg :: ServerConfig
|
||||
proxyCfg = cfg { allowSMPProxy = True }
|
||||
proxyCfg = cfg {allowSMPProxy = True}
|
||||
|
||||
withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
|
||||
@@ -158,16 +158,16 @@ withSmpServer t = withSmpServerOn t testPort
|
||||
withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a
|
||||
withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const
|
||||
|
||||
runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandleSMP c -> IO a) -> IO a
|
||||
runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a
|
||||
runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
|
||||
|
||||
runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c] -> IO a) -> IO a
|
||||
runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
|
||||
runSmpTestN = runSmpTestNCfg cfg supportedClientSMPRelayVRange
|
||||
|
||||
runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c] -> IO a) -> IO a
|
||||
runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a
|
||||
runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients []
|
||||
where
|
||||
run :: Int -> [THandleSMP c] -> IO a
|
||||
run :: Int -> [THandleSMP c 'TClient] -> IO a
|
||||
run 0 hs = test hs
|
||||
run n hs = testSMPClientVR clntVR $ \h -> run (n - 1) (h : hs)
|
||||
|
||||
@@ -179,7 +179,7 @@ smpServerTest ::
|
||||
IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg)
|
||||
smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
|
||||
where
|
||||
tPut' :: THandleSMP c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
|
||||
tPut' :: THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO ()
|
||||
tPut' h@THandle {params = THandleParams {sessionId, implySessId}} (sig, corrId, queueId, smp) = do
|
||||
let t' = if implySessId then smpEncode (corrId, queueId, smp) else smpEncode (sessionId, corrId, queueId, smp)
|
||||
[Right ()] <- tPut h [Right (sig, t')]
|
||||
@@ -188,33 +188,33 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
|
||||
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
|
||||
pure (Nothing, corrId, qId, cmd)
|
||||
|
||||
smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> IO ()) -> Expectation
|
||||
smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation
|
||||
smpTest _ test' = runSmpTest test' `shouldReturn` ()
|
||||
|
||||
smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c] -> IO ()) -> Expectation
|
||||
smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation
|
||||
smpTestN n test' = runSmpTestN n test' `shouldReturn` ()
|
||||
|
||||
smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
|
||||
smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
|
||||
smpTest2 = smpTest2Cfg cfg supportedClientSMPRelayVRange
|
||||
|
||||
smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
|
||||
smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRangeSMP -> TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
|
||||
smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` ()
|
||||
where
|
||||
_test :: HasCallStack => [THandleSMP c] -> IO ()
|
||||
_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 -> (HasCallStack => THandleSMP c -> THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
|
||||
smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
|
||||
smpTest3 _ test' = smpTestN 3 _test
|
||||
where
|
||||
_test :: HasCallStack => [THandleSMP c] -> IO ()
|
||||
_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 -> (HasCallStack => THandleSMP c -> THandleSMP c -> THandleSMP c -> THandleSMP c -> IO ()) -> Expectation
|
||||
smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation
|
||||
smpTest4 _ test' = smpTestN 4 _test
|
||||
where
|
||||
_test :: HasCallStack => [THandleSMP c] -> IO ()
|
||||
_test :: HasCallStack => [THandleSMP c 'TClient] -> IO ()
|
||||
_test [h1, h2, h3, h4] = test' h1 h2 h3 h4
|
||||
_test _ = error "expected 4 handles"
|
||||
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
@@ -5,6 +6,7 @@
|
||||
|
||||
module SMPProxyTests where
|
||||
|
||||
import Debug.Trace
|
||||
import SMPAgentClient (testSMPServer, testSMPServer2)
|
||||
import SMPClient
|
||||
import ServerTests (sendRecv)
|
||||
@@ -13,7 +15,6 @@ import Simplex.Messaging.Server.Env.STM (ServerConfig (..))
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Version (mkVersionRange)
|
||||
import Test.Hspec
|
||||
import Debug.Trace
|
||||
|
||||
smpProxyTests :: Spec
|
||||
smpProxyTests = do
|
||||
@@ -39,14 +40,14 @@ proxyVRange = mkVersionRange batchCmdsSMPVersion sendingProxySMPVersion
|
||||
testNoProxy :: IO ()
|
||||
testNoProxy = do
|
||||
withSmpServerConfigOn (transport @TLS) cfg testPort2 $ \_ -> do
|
||||
testSMPClient_ "127.0.0.1" testPort2 proxyVRange $ \(th :: THandleSMP TLS) -> do
|
||||
testSMPClient_ "127.0.0.1" testPort2 proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do
|
||||
(_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer Nothing)
|
||||
reply `shouldBe` Right (ERR AUTH)
|
||||
|
||||
testProxyAuth :: IO ()
|
||||
testProxyAuth = do
|
||||
withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do
|
||||
testSMPClient_ "127.0.0.1" testPort proxyVRange $ \(th :: THandleSMP TLS) -> do
|
||||
testSMPClient_ "127.0.0.1" testPort proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do
|
||||
(_, s, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer2 $ Just "wrong")
|
||||
traceShowM s
|
||||
reply `shouldBe` Right (ERR AUTH)
|
||||
@@ -56,7 +57,7 @@ testProxyAuth = do
|
||||
testProxyConnect :: IO ()
|
||||
testProxyConnect = do
|
||||
withSmpServerConfigOn (transport @TLS) proxyCfg testPort $ \_ -> do
|
||||
testSMPClient_ "127.0.0.1" testPort proxyVRange $ \(th :: THandleSMP TLS) -> do
|
||||
testSMPClient_ "127.0.0.1" testPort proxyVRange $ \(th :: THandleSMP TLS 'TClient) -> do
|
||||
(_, _, (_corrId, _entityId, reply)) <- sendRecv th (Nothing, "0", "", PRXY testSMPServer2 Nothing)
|
||||
case reply of
|
||||
Right PKEY {} -> pure ()
|
||||
|
||||
+18
-17
@@ -78,13 +78,13 @@ pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh)
|
||||
pattern Msg :: MsgId -> MsgBody -> BrokerMsg
|
||||
pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body}
|
||||
|
||||
sendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c -> (Maybe TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
|
||||
sendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> (Maybe TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
|
||||
sendRecv h@THandle {params} (sgn, corrId, qId, cmd) = do
|
||||
let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
|
||||
Right () <- tPut1 h (sgn, tToSend)
|
||||
tGet1 h
|
||||
|
||||
signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c -> C.APrivateAuthKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
|
||||
signSendRecv :: forall c p. (Transport c, PartyI p) => THandleSMP c 'TClient -> C.APrivateAuthKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg)
|
||||
signSendRecv h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
|
||||
let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd)
|
||||
Right () <- tPut1 h (authorize tForAuth, tToSend)
|
||||
@@ -93,17 +93,17 @@ signSendRecv h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do
|
||||
authorize t = case a of
|
||||
C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t
|
||||
C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t
|
||||
C.SX25519 -> (\THandleAuth {peerPubKey} -> TAAuthenticator $ C.cbAuthenticate peerPubKey pk (C.cbNonce corrId) t) <$> thAuth params
|
||||
C.SX25519 -> (\THAuthClient {serverPeerPubKey = k} -> TAAuthenticator $ C.cbAuthenticate k pk (C.cbNonce corrId) t) <$> thAuth params
|
||||
#if !MIN_VERSION_base(4,18,0)
|
||||
_sx448 -> undefined -- ghc8107 fails to the branch excluded by types
|
||||
#endif
|
||||
|
||||
tPut1 :: Transport c => THandle v c -> SentRawTransmission -> IO (Either TransportError ())
|
||||
tPut1 :: Transport c => THandle v c 'TClient -> SentRawTransmission -> IO (Either TransportError ())
|
||||
tPut1 h t = do
|
||||
[r] <- tPut h [Right t]
|
||||
pure r
|
||||
|
||||
tGet1 :: (ProtocolEncoding v err cmd, Transport c) => THandle v c -> IO (SignedTransmission err cmd)
|
||||
tGet1 :: (ProtocolEncoding v err cmd, Transport c) => THandle v c 'TClient -> IO (SignedTransmission err cmd)
|
||||
tGet1 h = do
|
||||
[r] <- liftIO $ tGet h
|
||||
pure r
|
||||
@@ -555,12 +555,12 @@ testWithStoreLog at@(ATransport t) =
|
||||
logSize testStoreLogFile `shouldReturn` 1
|
||||
removeFile testStoreLogFile
|
||||
where
|
||||
runTest :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> ThreadId -> Expectation
|
||||
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
|
||||
runTest _ test' server = do
|
||||
testSMPClient test' `shouldReturn` ()
|
||||
killThread server
|
||||
|
||||
runClient :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> Expectation
|
||||
runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
|
||||
runClient _ test' = testSMPClient test' `shouldReturn` ()
|
||||
|
||||
logSize :: FilePath -> IO Int
|
||||
@@ -653,12 +653,12 @@ testRestoreMessages at@(ATransport t) =
|
||||
removeFile testStoreMsgsFile
|
||||
removeFile testServerStatsBackupFile
|
||||
where
|
||||
runTest :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> ThreadId -> Expectation
|
||||
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
|
||||
runTest _ test' server = do
|
||||
testSMPClient test' `shouldReturn` ()
|
||||
killThread server
|
||||
|
||||
runClient :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> Expectation
|
||||
runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
|
||||
runClient _ test' = testSMPClient test' `shouldReturn` ()
|
||||
|
||||
checkStats :: ServerStatsData -> [RecipientId] -> Int -> Int -> Expectation
|
||||
@@ -727,15 +727,15 @@ testRestoreExpireMessages at@(ATransport t) =
|
||||
Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile
|
||||
_msgExpired `shouldBe` 2
|
||||
where
|
||||
runTest :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> ThreadId -> Expectation
|
||||
runTest :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation
|
||||
runTest _ test' server = do
|
||||
testSMPClient test' `shouldReturn` ()
|
||||
killThread server
|
||||
|
||||
runClient :: Transport c => TProxy c -> (THandleSMP c -> IO ()) -> Expectation
|
||||
runClient :: Transport c => TProxy c -> (THandleSMP c 'TClient -> IO ()) -> Expectation
|
||||
runClient _ test' = testSMPClient test' `shouldReturn` ()
|
||||
|
||||
createAndSecureQueue :: Transport c => THandleSMP c -> SndPublicAuthKey -> IO (SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret)
|
||||
createAndSecureQueue :: Transport c => THandleSMP c 'TClient -> SndPublicAuthKey -> IO (SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret)
|
||||
createAndSecureQueue h sPub = do
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
|
||||
@@ -759,8 +759,8 @@ testTiming (ATransport t) =
|
||||
timingTests :: [(C.AuthAlg, C.AuthAlg, Int)]
|
||||
timingTests =
|
||||
[ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519, 200), -- correct key type
|
||||
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448, 150),
|
||||
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519, 200),
|
||||
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448, 150),
|
||||
-- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519, 200),
|
||||
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519, 200),
|
||||
(C.AuthAlg C.SEd448, C.AuthAlg C.SEd448, 150), -- correct key type
|
||||
(C.AuthAlg C.SEd448, C.AuthAlg C.SX25519, 200),
|
||||
@@ -770,7 +770,7 @@ testTiming (ATransport t) =
|
||||
]
|
||||
timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
|
||||
similarTime t1 t2 = abs (t2 / t1 - 1) < 0.2 -- normally the difference between "no queue" and "wrong key" is less than 5%
|
||||
testSameTiming :: forall c. Transport c => THandleSMP c -> THandleSMP c -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation
|
||||
testSameTiming :: forall c. Transport c => THandleSMP c 'TClient -> THandleSMP c 'TClient -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation
|
||||
testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do
|
||||
g <- C.newRandom
|
||||
(rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g
|
||||
@@ -791,10 +791,11 @@ testTiming (ATransport t) =
|
||||
|
||||
runTimingTest sh badKey sId $ _SEND "hello"
|
||||
where
|
||||
runTimingTest :: PartyI p => THandleSMP c -> C.APrivateAuthKey -> ByteString -> Command p -> IO ()
|
||||
runTimingTest :: PartyI p => THandleSMP c 'TClient -> C.APrivateAuthKey -> ByteString -> Command p -> IO ()
|
||||
runTimingTest h badKey qId cmd = do
|
||||
threadDelay 100000
|
||||
_ <- timeRepeat n $ do -- "warm up" the server
|
||||
_ <- timeRepeat n $ do
|
||||
-- "warm up" the server
|
||||
Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd)
|
||||
return ()
|
||||
threadDelay 100000
|
||||
|
||||
Reference in New Issue
Block a user