From 2f43b432254808ecac623d34fb553987d012114c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Mon, 15 Apr 2024 13:47:48 +0100 Subject: [PATCH] parameterize transport handle with transport peer to include server certificate (#1100) * parameterize transport handle with transport peer to include server certificate * include server certificate into THandle * load server chain and sign key * fix key type * fix for 8.10 --------- Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Co-authored-by: IC Rainbow --- src/Simplex/FileTransfer/Client.hs | 13 ++-- src/Simplex/FileTransfer/Protocol.hs | 12 ++-- src/Simplex/FileTransfer/Server.hs | 16 ++--- src/Simplex/FileTransfer/Transport.hs | 9 +-- src/Simplex/Messaging/Client.hs | 14 ++-- src/Simplex/Messaging/Notifications/Server.hs | 10 +-- .../Messaging/Notifications/Server/Env.hs | 8 +-- .../Messaging/Notifications/Transport.hs | 44 +++++++----- src/Simplex/Messaging/Protocol.hs | 22 +++--- src/Simplex/Messaging/Server.hs | 18 ++--- src/Simplex/Messaging/Transport.hs | 70 ++++++++++++------- tests/CoreTests/BatchingTests.hs | 21 ++++-- tests/NtfClient.hs | 8 +-- tests/NtfServerTests.hs | 6 +- tests/SMPClient.hs | 32 ++++----- tests/ServerTests.hs | 35 +++++----- 16 files changed, 191 insertions(+), 147 deletions(-) diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index fcb54aece..a223d492e 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -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' diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index f970fdfcc..418e48482 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index b426360ea..b3bee134f 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index d8bb72f6b..041069e98 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -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 diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index e0591b14d..61ec96003 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -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 () @@ -733,13 +733,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 diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 55ab40718..55bdb07eb 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -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 diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index 4a93a8a34..5bcd72f3d 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -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 diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index bc68fab03..d4a4a4cbe 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -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} diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 2c593fc6f..31577ccdb 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -1075,7 +1075,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 @@ -1089,10 +1089,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 @@ -1308,7 +1308,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 ()] @@ -1317,7 +1317,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 @@ -1383,7 +1383,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 @@ -1391,7 +1391,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 @@ -1404,11 +1404,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] @@ -1420,10 +1420,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 -> diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 4535c7bd5..5415ebd65 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -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 @@ -536,7 +536,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 @@ -548,12 +548,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 diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 6898af15d..6d4ccc83b 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -12,6 +12,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | @@ -311,20 +312,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, @@ -333,10 +334,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 @@ -438,13 +447,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 @@ -454,7 +463,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 @@ -465,13 +474,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 @@ -479,33 +488,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} diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 996d2fed1..c349096dc 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -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) diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 26981628f..d47722944 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -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 diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index e7e2018c2..e5f096eef 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -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) diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 3e5e9d2ce..9023574d8 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -67,10 +67,10 @@ 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 runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> do @@ -150,16 +150,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) @@ -171,7 +171,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')] @@ -180,33 +180,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" diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 09cf975c1..b4c40cd99 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -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