mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-29 07:48:25 +00:00
parameterize THandle
This commit is contained in:
Evgeny Poberezkin
@@ -45,7 +45,7 @@ import Simplex.Messaging.Protocol
|
||||
RecipientId,
|
||||
SenderId,
|
||||
)
|
||||
import Simplex.Messaging.Transport (THandleParams (..), supportedParameters)
|
||||
import Simplex.Messaging.Transport (THandleParams (..), TransportPeer (..), supportedParameters)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.Client
|
||||
@@ -57,7 +57,7 @@ import UnliftIO.Directory
|
||||
data XFTPClient = XFTPClient
|
||||
{ http2Client :: HTTP2Client,
|
||||
transportSession :: TransportSession FileResponse,
|
||||
thParams :: THandleParams,
|
||||
thParams :: THandleParams 'TClient,
|
||||
config :: XFTPClientConfig
|
||||
}
|
||||
|
||||
@@ -138,7 +138,7 @@ sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateAuthKey ->
|
||||
sendXFTPCommand c@XFTPClient {thParams} pKey fId cmd chunkSpec_ = do
|
||||
t <-
|
||||
liftEither . first PCETransportError $
|
||||
xftpEncodeTransmission thParams (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
|
||||
xftpEncodeClntTransmission thParams (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd)
|
||||
sendXFTPTransmission c t chunkSpec_
|
||||
|
||||
sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body)
|
||||
@@ -218,7 +218,7 @@ pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
pingXFTP c@XFTPClient {thParams} = do
|
||||
t <-
|
||||
liftEither . first PCETransportError $
|
||||
xftpEncodeTransmission thParams Nothing ("", "", FileCmd SFRecipient PING)
|
||||
xftpEncodeClntTransmission thParams Nothing ("", "", FileCmd SFRecipient PING)
|
||||
(r, _) <- sendXFTPTransmission c t Nothing
|
||||
case r of
|
||||
FRPong -> pure ()
|
||||
|
||||
@@ -49,12 +49,13 @@ import Simplex.Messaging.Protocol
|
||||
Transmission,
|
||||
ClntTransmission (..),
|
||||
encodeClntTransmission,
|
||||
encodeSrvTransmission,
|
||||
messageTagP,
|
||||
tDecodeParseValidate,
|
||||
tEncodeBatch1,
|
||||
tParse,
|
||||
)
|
||||
import Simplex.Messaging.Transport (THandleParams (..), TransportError (..))
|
||||
import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Util (bshow, (<$?>))
|
||||
import Simplex.Messaging.Version
|
||||
|
||||
@@ -396,16 +397,21 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
|
||||
Just Refl -> Just c
|
||||
_ -> Nothing
|
||||
|
||||
xftpEncodeTransmission :: ProtocolEncoding e c => THandleParams -> Maybe C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
|
||||
xftpEncodeTransmission thParams pKey (corrId, fId, msg) = do
|
||||
xftpEncodeClntTransmission :: ProtocolEncoding e c => THandleParams 'TClient -> Maybe C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString
|
||||
xftpEncodeClntTransmission thParams pKey (corrId, fId, msg) = do
|
||||
let ClntTransmission {tForAuth, tToSend} = encodeClntTransmission thParams (corrId, fId, msg)
|
||||
xftpEncodeBatch1 . (,tToSend) =<< authTransmission Nothing pKey corrId tForAuth
|
||||
|
||||
xftpEncodeSrvTransmission :: ProtocolEncoding e c => THandleParams 'TServer -> Transmission c -> Either TransportError ByteString
|
||||
xftpEncodeSrvTransmission thParams (corrId, fId, msg) = do
|
||||
let t = encodeSrvTransmission thParams (corrId, fId, msg)
|
||||
xftpEncodeBatch1 (Nothing, t)
|
||||
|
||||
-- this function uses batch syntax but puts only one transmission in the batch
|
||||
xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString
|
||||
xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize
|
||||
|
||||
xftpDecodeTransmission :: ProtocolEncoding e c => THandleParams -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
|
||||
xftpDecodeTransmission :: ProtocolEncoding e c => THandleParams p -> ByteString -> Either XFTPErrorType (SignedTransmission e c)
|
||||
xftpDecodeTransmission thParams t = do
|
||||
t' <- first (const BLOCK) $ C.unPad t
|
||||
case tParse thParams t' of
|
||||
|
||||
@@ -51,7 +51,7 @@ import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicAuthKey, Rec
|
||||
import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.Stats
|
||||
import Simplex.Messaging.Transport (THandleParams (..))
|
||||
import Simplex.Messaging.Transport (THandleParams (..), TransportPeer (..))
|
||||
import Simplex.Messaging.Transport.Buffer (trimCR)
|
||||
import Simplex.Messaging.Transport.HTTP2
|
||||
import Simplex.Messaging.Transport.HTTP2.Server
|
||||
@@ -69,7 +69,7 @@ type M a = ReaderT XFTPEnv IO a
|
||||
|
||||
data XFTPTransportRequest =
|
||||
XFTPTransportRequest
|
||||
{ thParams :: THandleParams,
|
||||
{ thParams :: THandleParams 'TServer,
|
||||
reqBody :: HTTP2Body,
|
||||
request :: H.Request,
|
||||
sendResponse :: H.Response -> IO ()
|
||||
@@ -243,7 +243,7 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea
|
||||
where
|
||||
sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M ()
|
||||
sendXFTPResponse (corrId, fId, resp) serverFile_ = do
|
||||
let t_ = xftpEncodeTransmission thParams Nothing (corrId, fId, resp)
|
||||
let t_ = xftpEncodeSrvTransmission thParams (corrId, fId, resp)
|
||||
liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_
|
||||
where
|
||||
streamBody t_ send done = do
|
||||
|
||||
@@ -119,7 +119,7 @@ import System.Timeout (timeout)
|
||||
-- Use 'getSMPClient' to connect to an SMP server and create a client handle.
|
||||
data ProtocolClient err msg = ProtocolClient
|
||||
{ action :: Maybe (Async ()),
|
||||
thParams :: THandleParams,
|
||||
thParams :: THandleParams 'TClient,
|
||||
sessionTs :: UTCTime,
|
||||
timeoutPerBlock :: Int,
|
||||
client_ :: PClient err msg
|
||||
@@ -139,7 +139,7 @@ data PClient err msg = PClient
|
||||
msgQ :: Maybe (TBQueue (ServerTransmission msg))
|
||||
}
|
||||
|
||||
clientStub :: TVar ChaChaDRG -> ByteString -> Version -> Maybe THandleAuth -> STM (ProtocolClient err msg)
|
||||
clientStub :: TVar ChaChaDRG -> ByteString -> Version -> Maybe (THandleAuth 'TClient) -> STM (ProtocolClient err msg)
|
||||
clientStub g sessionId thVersion thAuth = do
|
||||
connected <- newTVar False
|
||||
clientCorrId <- C.newRandomDRG g
|
||||
@@ -369,9 +369,8 @@ getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize
|
||||
p -> (p, transport @TLS)
|
||||
|
||||
client :: forall c. Transport c => TProxy c -> PClient err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient err msg)) -> c -> IO ()
|
||||
client _ c cVar h = do
|
||||
ks <- atomically $ C.generateKeyPair g
|
||||
runExceptT (protocolClientHandshake @err @msg h ks (keyHash srv) serverVRange) >>= \case
|
||||
client _ c cVar h =
|
||||
runExceptT (protocolClientHandshake @err @msg h (keyHash srv) serverVRange) >>= \case
|
||||
Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
|
||||
Right th@THandle {params} -> do
|
||||
sessionTs <- getCurrentTime
|
||||
@@ -383,10 +382,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 err msg -> THandle c -> IO ()
|
||||
send :: Transport c => ProtocolClient err msg -> THandle c 'TClient -> IO ()
|
||||
send ProtocolClient {client_ = PClient {sndQ}} h = forever $ atomically (readTBQueue sndQ) >>= tPutLog h
|
||||
|
||||
receive :: Transport c => ProtocolClient err msg -> THandle c -> IO ()
|
||||
receive :: Transport c => ProtocolClient err msg -> THandle c 'TClient -> IO ()
|
||||
receive ProtocolClient {client_ = PClient {rcvQ}} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ
|
||||
|
||||
ping :: ProtocolClient err msg -> IO ()
|
||||
@@ -717,13 +716,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 THClientAuth {srvPubKey} -> Right $ TAAuthenticator $ C.cbAuthenticate srvPubKey pk (C.cbNonce corrId) t
|
||||
Nothing -> Left TENoServerAuth
|
||||
C.SEd25519 -> sign pk
|
||||
C.SEd448 -> sign pk
|
||||
|
||||
@@ -48,7 +48,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)
|
||||
@@ -338,7 +338,7 @@ updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do
|
||||
old <- atomically $ stateTVar tknStatus (,status)
|
||||
when (old /= status) $ withNtfLog $ \sl -> logTokenStatus sl ntfTknId status
|
||||
|
||||
runNtfClientTransport :: Transport c => THandle c -> M ()
|
||||
runNtfClientTransport :: Transport c => THandle c 'TServer -> M ()
|
||||
runNtfClientTransport th@THandle {params} = do
|
||||
qSize <- asks $ clientQSize . config
|
||||
ts <- liftIO getSystemTime
|
||||
@@ -355,7 +355,7 @@ runNtfClientTransport th@THandle {params} = do
|
||||
clientDisconnected :: NtfServerClient -> IO ()
|
||||
clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
|
||||
|
||||
receive :: Transport c => THandle c -> NtfServerClient -> M ()
|
||||
receive :: Transport c => THandle 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
|
||||
@@ -370,7 +370,7 @@ receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ
|
||||
where
|
||||
write q t = atomically $ writeTBQueue q t
|
||||
|
||||
send :: Transport c => THandle c -> NtfServerClient -> IO ()
|
||||
send :: Transport c => THandle c 'TServer -> NtfServerClient -> IO ()
|
||||
send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do
|
||||
t <- atomically $ readTBQueue sndQ
|
||||
void . liftIO $ tPut h [Right (Nothing, encodeSrvTransmission params t)]
|
||||
@@ -381,7 +381,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
|
||||
|
||||
@@ -32,7 +32,7 @@ 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 Simplex.Messaging.Version (VersionRange)
|
||||
import System.IO (IOMode (..))
|
||||
@@ -159,13 +159,13 @@ data NtfRequest
|
||||
data NtfServerClient = NtfServerClient
|
||||
{ rcvQ :: TBQueue NtfRequest,
|
||||
sndQ :: TBQueue (Transmission NtfResponse),
|
||||
ntfThParams :: THandleParams,
|
||||
ntfThParams :: THandleParams 'TServer,
|
||||
connected :: TVar Bool,
|
||||
rcvActiveAt :: TVar SystemTime,
|
||||
sndActiveAt :: TVar SystemTime
|
||||
}
|
||||
|
||||
newNtfServerClient :: Natural -> THandleParams -> SystemTime -> STM NtfServerClient
|
||||
newNtfServerClient :: Natural -> THandleParams 'TServer -> SystemTime -> STM NtfServerClient
|
||||
newNtfServerClient qSize ntfThParams ts = do
|
||||
rcvQ <- newTBQueue qSize
|
||||
sndQ <- newTBQueue qSize
|
||||
|
||||
@@ -48,9 +48,7 @@ data NtfClientHandshake = NtfClientHandshake
|
||||
{ -- | agreed SMP notifications server protocol version
|
||||
ntfVersion :: Version,
|
||||
-- | server identity - CA certificate fingerprint
|
||||
keyHash :: C.KeyHash,
|
||||
-- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
|
||||
authPubKey :: Maybe C.PublicKeyX25519
|
||||
keyHash :: C.KeyHash
|
||||
}
|
||||
|
||||
instance Encoding NtfServerHandshake where
|
||||
@@ -75,13 +73,11 @@ authEncryptCmdsP :: Version -> Parser a -> Parser (Maybe a)
|
||||
authEncryptCmdsP v p = if v >= authEncryptCmdsNTFVersion then Just <$> p else pure Nothing
|
||||
|
||||
instance Encoding NtfClientHandshake where
|
||||
smpEncode NtfClientHandshake {ntfVersion, keyHash, authPubKey} =
|
||||
smpEncode (ntfVersion, keyHash) <> encodeNtfAuthPubKey ntfVersion authPubKey
|
||||
smpEncode NtfClientHandshake {ntfVersion, keyHash} =
|
||||
smpEncode (ntfVersion, keyHash)
|
||||
smpP = do
|
||||
(ntfVersion, keyHash) <- smpP
|
||||
-- TODO drop SMP v6: remove special parser and make key non-optional
|
||||
authPubKey <- ntfAuthPubKeyP ntfVersion
|
||||
pure NtfClientHandshake {ntfVersion, keyHash, authPubKey}
|
||||
pure NtfClientHandshake {ntfVersion, keyHash}
|
||||
|
||||
ntfAuthPubKeyP :: Version -> Parser (Maybe C.PublicKeyX25519)
|
||||
ntfAuthPubKeyP v = if v >= authEncryptCmdsNTFVersion then Just <$> smpP else pure Nothing
|
||||
@@ -92,44 +88,45 @@ encodeNtfAuthPubKey v k
|
||||
| otherwise = ""
|
||||
|
||||
-- | Notifcations server transport handshake.
|
||||
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
|
||||
ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle 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
|
||||
sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange, authPubKey = Just sk}
|
||||
getHandshake th >>= \case
|
||||
NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = k'}
|
||||
NtfClientHandshake {ntfVersion = v, keyHash}
|
||||
| keyHash /= kh ->
|
||||
throwError $ TEHandshake IDENTITY
|
||||
| v `isCompatible` ntfVRange ->
|
||||
pure $ ntfThHandle th v pk k'
|
||||
pure $ ntfThHandle th v (Just $ THServerAuth pk)
|
||||
| otherwise -> throwError $ TEHandshake VERSION
|
||||
|
||||
-- | Notifcations server client transport handshake.
|
||||
ntfClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c)
|
||||
ntfClientHandshake c (k, pk) keyHash ntfVRange = do
|
||||
ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c 'TClient)
|
||||
ntfClientHandshake c keyHash ntfVRange = do
|
||||
let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
|
||||
NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th
|
||||
if sessionId /= sessId
|
||||
then throwError TEBadSession
|
||||
else case ntfVersionRange `compatibleVersion` ntfVRange of
|
||||
Just (Compatible v) -> do
|
||||
sk_ <- forM sk' $ \exact -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
|
||||
k_ <- forM sk' $ \exact -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
|
||||
serverKey <- getServerVerifyKey c
|
||||
pubKey <- C.verifyX509 serverKey exact
|
||||
C.x509ToPublic (pubKey, []) >>= C.pubKey
|
||||
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = Just k}
|
||||
pure $ ntfThHandle th v pk sk_
|
||||
sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
|
||||
pure $ ntfThHandle th v (THClientAuth <$> k_)
|
||||
Nothing -> throwError $ TEHandshake VERSION
|
||||
|
||||
ntfThHandle :: forall c. THandle c -> Version -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandle c
|
||||
ntfThHandle th@THandle {params} v privKey k_ =
|
||||
ntfThHandle :: forall c p. THandle c p -> Version -> Maybe (THandleAuth p) -> THandle c p
|
||||
ntfThHandle th@THandle {params} v thAuth_ =
|
||||
-- TODO drop SMP v6: make thAuth non-optional
|
||||
let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
|
||||
let encrypt = v >= authEncryptCmdsNTFVersion
|
||||
thAuth = if encrypt then thAuth_ else Nothing
|
||||
params' = params {thVersion = v, thAuth, encrypt = v >= authEncryptCmdsNTFVersion}
|
||||
in (th :: THandle c) {params = params'}
|
||||
in (th :: THandle c p) {params = params'}
|
||||
|
||||
ntfTHandle :: Transport c => c -> THandle c
|
||||
ntfTHandle :: Transport c => c -> THandle c p
|
||||
ntfTHandle c = THandle {connection = c, params}
|
||||
where
|
||||
params = THandleParams {sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, thAuth = Nothing, encrypt = False, batch = False}
|
||||
|
||||
@@ -1068,7 +1068,7 @@ data CommandError
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
-- | SMP transmission parser.
|
||||
transmissionP :: THandleParams -> Parser RawTransmission
|
||||
transmissionP :: THandleParams p -> Parser RawTransmission
|
||||
transmissionP THandleParams {sessionId, encrypt} = do
|
||||
authenticator <- smpP
|
||||
authorized <- A.takeByteString
|
||||
@@ -1085,7 +1085,7 @@ transmissionP THandleParams {sessionId, encrypt} = do
|
||||
class (ProtocolEncoding err msg, ProtocolEncoding err (ProtoCommand msg), Show err, Show msg) => Protocol err msg | 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 -> ExceptT TransportError IO (THandle c)
|
||||
protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c 'TClient)
|
||||
protocolPing :: ProtoCommand msg
|
||||
protocolError :: msg -> Maybe err
|
||||
|
||||
@@ -1314,7 +1314,7 @@ instance Encoding CommandError where
|
||||
_ -> fail "bad command error type"
|
||||
|
||||
-- | Send signed SMP transmission to TCP transport.
|
||||
tPut :: Transport c => THandle c -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
|
||||
tPut :: Transport c => THandle 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 ()]
|
||||
@@ -1323,7 +1323,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 c -> ByteString -> IO (Either TransportError ())
|
||||
tPutLog :: Transport c => THandle c p -> ByteString -> IO (Either TransportError ())
|
||||
tPutLog th s = do
|
||||
r <- tPutBlock th s
|
||||
case r of
|
||||
@@ -1385,7 +1385,7 @@ tEncodeBatch1 t = lenEncode 1 `B.cons` tEncodeForBatch t
|
||||
-- tForAuth is lazy to avoid computing it when there is no key to sign
|
||||
data ClntTransmission = ClntTransmission {tForAuth :: ~ByteString, tToSend :: ByteString}
|
||||
|
||||
encodeClntTransmission :: ProtocolEncoding e c => THandleParams -> Transmission c -> ClntTransmission
|
||||
encodeClntTransmission :: ProtocolEncoding e c => THandleParams 'TClient -> Transmission c -> ClntTransmission
|
||||
encodeClntTransmission THandleParams {thVersion = v, sessionId, encrypt} t =
|
||||
ClntTransmission {tForAuth, tToSend = if encrypt then t' else tForAuth}
|
||||
where
|
||||
@@ -1393,7 +1393,7 @@ encodeClntTransmission THandleParams {thVersion = v, sessionId, encrypt} t =
|
||||
t' = encodeTransmission_ v t
|
||||
{-# INLINE encodeClntTransmission #-}
|
||||
|
||||
encodeSrvTransmission :: ProtocolEncoding e c => THandleParams -> Transmission c -> ByteString
|
||||
encodeSrvTransmission :: ProtocolEncoding e c => THandleParams 'TServer -> Transmission c -> ByteString
|
||||
encodeSrvTransmission THandleParams {thVersion = v, sessionId, encrypt} t =
|
||||
if encrypt then t' else smpEncode sessionId <> t'
|
||||
where
|
||||
@@ -1406,11 +1406,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 c -> IO (NonEmpty (Either TransportError RawTransmission))
|
||||
tGetParse :: Transport c => THandle c p -> IO (NonEmpty (Either TransportError RawTransmission))
|
||||
tGetParse th@THandle {params} = eitherList (tParse params) <$> tGetBlock th
|
||||
{-# INLINE tGetParse #-}
|
||||
|
||||
tParse :: THandleParams -> ByteString -> NonEmpty (Either TransportError RawTransmission)
|
||||
tParse :: THandleParams p -> ByteString -> NonEmpty (Either TransportError RawTransmission)
|
||||
tParse thParams@THandleParams {batch} s
|
||||
| batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts
|
||||
| otherwise = [tParse1 s]
|
||||
@@ -1422,10 +1422,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 err cmd c. (ProtocolEncoding err cmd, Transport c) => THandle c -> IO (NonEmpty (SignedTransmission err cmd))
|
||||
tGet :: forall err cmd c p. (ProtocolEncoding err cmd, Transport c) => THandle c p -> IO (NonEmpty (SignedTransmission err cmd))
|
||||
tGet th@THandle {params} = L.map (tDecodeParseValidate params) <$> tGetParse th
|
||||
|
||||
tDecodeParseValidate :: forall err cmd. ProtocolEncoding err cmd => THandleParams -> Either TransportError RawTransmission -> SignedTransmission err cmd
|
||||
tDecodeParseValidate :: forall err cmd p. ProtocolEncoding err cmd => THandleParams p -> Either TransportError RawTransmission -> SignedTransmission err cmd
|
||||
tDecodeParseValidate THandleParams {sessionId, thVersion = v, encrypt} = \case
|
||||
Right RawTransmission {authenticator, authorized, sessId, corrId, entityId, command}
|
||||
| encrypt || sessId == sessionId ->
|
||||
|
||||
@@ -372,7 +372,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
|
||||
CPQuit -> pure ()
|
||||
CPSkip -> pure ()
|
||||
|
||||
runClientTransport :: Transport c => THandle c -> M ()
|
||||
runClientTransport :: Transport c => THandle c 'TServer -> M ()
|
||||
runClientTransport th@THandle {params = THandleParams {thVersion, sessionId}} = do
|
||||
q <- asks $ tbqSize . config
|
||||
ts <- liftIO getSystemTime
|
||||
@@ -417,7 +417,7 @@ cancelSub sub =
|
||||
Sub {subThread = SubThread t} -> liftIO $ deRefWeak t >>= mapM_ killThread
|
||||
_ -> return ()
|
||||
|
||||
receive :: Transport c => THandle c -> Client -> M ()
|
||||
receive :: Transport c => THandle 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
|
||||
@@ -438,7 +438,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 => THandle c -> Client -> IO ()
|
||||
send :: Transport c => THandle c 'TServer-> Client -> IO ()
|
||||
send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send"
|
||||
forever $ do
|
||||
@@ -453,7 +453,7 @@ send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do
|
||||
NMSG {} -> 0
|
||||
_ -> 1
|
||||
|
||||
disconnectTransport :: Transport c => THandle c -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO ()
|
||||
disconnectTransport :: Transport c => THandle 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
|
||||
@@ -474,7 +474,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
|
||||
@@ -496,7 +496,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
|
||||
@@ -508,12 +508,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 (THServerAuth {privKey}, nonce) -> C.cbVerify k privKey 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
|
||||
|
||||
@@ -55,6 +55,7 @@ module Simplex.Messaging.Transport
|
||||
|
||||
-- * SMP transport
|
||||
THandle (..),
|
||||
TClientHandle,
|
||||
THandleParams (..),
|
||||
THandleAuth (..),
|
||||
TransportError (..),
|
||||
@@ -287,18 +288,20 @@ instance Transport TLS where
|
||||
-- * SMP transport
|
||||
|
||||
-- | The handle for SMP encrypted transport connection over Transport.
|
||||
data THandle c = THandle
|
||||
data THandle c p = THandle
|
||||
{ connection :: c,
|
||||
params :: THandleParams
|
||||
params :: THandleParams p
|
||||
}
|
||||
|
||||
data THandleParams = THandleParams
|
||||
type TClientHandle c = THandle c 'TClient
|
||||
|
||||
data THandleParams p = THandleParams
|
||||
{ sessionId :: SessionId,
|
||||
blockSize :: Int,
|
||||
-- | agreed server protocol version
|
||||
thVersion :: Version,
|
||||
-- | peer public key for command authorization and shared secrets for entity ID encryption
|
||||
thAuth :: Maybe THandleAuth,
|
||||
thAuth :: Maybe (THandleAuth p),
|
||||
-- | additionally encrypt transmission inside transport protocol
|
||||
-- to protect transmission from sending proxies
|
||||
-- based on protocol version
|
||||
@@ -308,10 +311,11 @@ data THandleParams = 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
|
||||
-- used in the server (combined with client public per-queue or per-command keys)
|
||||
THServerAuth :: {privKey :: C.PrivateKeyX25519} -> THandleAuth 'TServer
|
||||
-- used in the client (combined with client private per-queue or per-command key)
|
||||
THClientAuth :: {srvPubKey :: C.PublicKeyX25519} -> THandleAuth 'TClient
|
||||
|
||||
-- | TLS-unique channel binding
|
||||
type SessionId = ByteString
|
||||
@@ -327,19 +331,15 @@ data ClientHandshake = ClientHandshake
|
||||
{ -- | agreed SMP server protocol version
|
||||
smpVersion :: Version,
|
||||
-- | server identity - CA certificate fingerprint
|
||||
keyHash :: C.KeyHash,
|
||||
-- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys.
|
||||
authPubKey :: Maybe C.PublicKeyX25519
|
||||
keyHash :: C.KeyHash
|
||||
}
|
||||
|
||||
instance Encoding ClientHandshake where
|
||||
smpEncode ClientHandshake {smpVersion, keyHash, authPubKey} =
|
||||
smpEncode (smpVersion, keyHash) <> encodeAuthEncryptCmds smpVersion authPubKey
|
||||
smpEncode ClientHandshake {smpVersion, keyHash} =
|
||||
smpEncode (smpVersion, keyHash)
|
||||
smpP = do
|
||||
(smpVersion, keyHash) <- smpP
|
||||
-- TODO drop SMP v6: remove special parser and make key non-optional
|
||||
authPubKey <- authEncryptCmdsP smpVersion smpP
|
||||
pure ClientHandshake {smpVersion, keyHash, authPubKey}
|
||||
pure ClientHandshake {smpVersion, keyHash}
|
||||
|
||||
instance Encoding ServerHandshake where
|
||||
smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} =
|
||||
@@ -413,13 +413,13 @@ serializeTransportError = \case
|
||||
TEHandshake e -> "HANDSHAKE " <> bshow e
|
||||
|
||||
-- | Pad and send block to SMP transport.
|
||||
tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
|
||||
tPutBlock :: Transport c => THandle 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 c -> IO (Either TransportError ByteString)
|
||||
tGetBlock :: Transport c => THandle c p -> IO (Either TransportError ByteString)
|
||||
tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do
|
||||
msg <- cGet c blockSize
|
||||
if B.length msg == blockSize
|
||||
@@ -429,32 +429,32 @@ 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 -> VersionRange -> ExceptT TransportError IO (THandle c)
|
||||
smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle 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
|
||||
certChain = getServerCerts c
|
||||
sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange, authPubKey = Just (certChain, sk)}
|
||||
getHandshake th >>= \case
|
||||
ClientHandshake {smpVersion = v, keyHash, authPubKey = k'}
|
||||
ClientHandshake {smpVersion = v, keyHash}
|
||||
| keyHash /= kh ->
|
||||
throwE $ TEHandshake IDENTITY
|
||||
| v `isCompatible` smpVRange ->
|
||||
pure $ smpThHandle th v pk k'
|
||||
pure $ smpThHandle th v (Just $ THServerAuth pk)
|
||||
| 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 -> VersionRange -> ExceptT TransportError IO (THandle c)
|
||||
smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do
|
||||
smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c 'TClient)
|
||||
smpClientHandshake c keyHash@(C.KeyHash kh) smpVRange = do
|
||||
let th@THandle {params = THandleParams {sessionId}} = smpTHandle c
|
||||
ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th
|
||||
if sessionId /= sessId
|
||||
then throwE TEBadSession
|
||||
else case smpVersionRange `compatibleVersion` smpVRange of
|
||||
Just (Compatible v) -> do
|
||||
sk_ <- forM authPubKey $ \(X.CertificateChain cert, exact) ->
|
||||
k_ <- forM authPubKey $ \(X.CertificateChain cert, exact) ->
|
||||
liftEitherWith (const $ TEHandshake BAD_AUTH) $ do
|
||||
case cert of
|
||||
[_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure ()
|
||||
@@ -462,25 +462,26 @@ smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do
|
||||
serverKey <- getServerVerifyKey c
|
||||
pubKey <- C.verifyX509 serverKey exact
|
||||
C.x509ToPublic (pubKey, []) >>= C.pubKey
|
||||
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = Just k}
|
||||
pure $ smpThHandle th v pk sk_
|
||||
sendHandshake th $ ClientHandshake {smpVersion = v, keyHash}
|
||||
pure $ smpThHandle th v (THClientAuth <$> k_)
|
||||
Nothing -> throwE $ TEHandshake VERSION
|
||||
|
||||
smpThHandle :: forall c. THandle c -> Version -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandle c
|
||||
smpThHandle th@THandle {params} v privKey k_ =
|
||||
smpThHandle :: forall c p. THandle c p -> Version -> Maybe (THandleAuth p) -> THandle c p
|
||||
smpThHandle th@THandle {params} v thAuth_ =
|
||||
-- TODO drop SMP v6: make thAuth non-optional
|
||||
let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_
|
||||
params' = params {thVersion = v, thAuth, encrypt = v >= authEncryptCmdsSMPVersion, batch = v >= batchCmdsSMPVersion}
|
||||
in (th :: THandle c) {params = params'}
|
||||
let encrypt = v >= authEncryptCmdsSMPVersion
|
||||
thAuth = if encrypt then thAuth_ else Nothing
|
||||
params' = params {thVersion = v, thAuth, encrypt, batch = v >= batchCmdsSMPVersion}
|
||||
in (th :: THandle c p) {params = params'}
|
||||
|
||||
sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO ()
|
||||
sendHandshake :: (Transport c, Encoding smp) => THandle 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 c -> ExceptT TransportError IO smp
|
||||
getHandshake :: (Transport c, Encoding smp) => THandle c p -> ExceptT TransportError IO smp
|
||||
getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP =<<) <$> tGetBlock th
|
||||
|
||||
smpTHandle :: Transport c => c -> THandle c
|
||||
smpTHandle :: Transport c => c -> THandle c p
|
||||
smpTHandle c = THandle {connection = c, params}
|
||||
where
|
||||
params = THandleParams {sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, thAuth = Nothing, encrypt = False, batch = False}
|
||||
|
||||
Reference in New Issue
Block a user