mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-06-04 04:21:27 +00:00
Merge branch 'master' into pq
This commit is contained in:
Evgeny Poberezkin
@@ -46,6 +46,10 @@ module Simplex.Messaging.Protocol
|
||||
e2eEncMessageLength,
|
||||
|
||||
-- * SMP protocol types
|
||||
SMPClientVersion,
|
||||
VersionSMPC,
|
||||
VersionRangeSMPC,
|
||||
pattern VersionSMPC,
|
||||
ProtocolEncoding (..),
|
||||
Command (..),
|
||||
SubscriptionMode (..),
|
||||
@@ -117,6 +121,7 @@ module Simplex.Messaging.Protocol
|
||||
SMPMsgMeta (..),
|
||||
NMsgMeta (..),
|
||||
MsgFlags (..),
|
||||
initialSMPClientVersion,
|
||||
userProtocol,
|
||||
rcvMessageMeta,
|
||||
noMsgFlags,
|
||||
@@ -179,6 +184,7 @@ import Data.Maybe (isNothing)
|
||||
import Data.String
|
||||
import Data.Time.Clock.System (SystemTime (..))
|
||||
import Data.Type.Equality
|
||||
import Data.Word (Word16)
|
||||
import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
|
||||
import Network.Socket (ServiceName)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -190,19 +196,34 @@ import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
|
||||
import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>))
|
||||
import Simplex.Messaging.Version
|
||||
import Simplex.Messaging.Version.Internal
|
||||
|
||||
-- SMP client protocol version history:
|
||||
-- 1 - binary protocol encoding (1/1/2022)
|
||||
-- 2 - multiple server hostnames and versioned queue addresses (8/12/2022)
|
||||
|
||||
srvHostnamesSMPClientVersion :: Version
|
||||
srvHostnamesSMPClientVersion = 2
|
||||
data SMPClientVersion
|
||||
|
||||
currentSMPClientVersion :: Version
|
||||
currentSMPClientVersion = 2
|
||||
instance VersionScope SMPClientVersion
|
||||
|
||||
supportedSMPClientVRange :: VersionRange
|
||||
supportedSMPClientVRange = mkVersionRange 1 currentSMPClientVersion
|
||||
type VersionSMPC = Version SMPClientVersion
|
||||
|
||||
type VersionRangeSMPC = VersionRange SMPClientVersion
|
||||
|
||||
pattern VersionSMPC :: Word16 -> VersionSMPC
|
||||
pattern VersionSMPC v = Version v
|
||||
|
||||
initialSMPClientVersion :: VersionSMPC
|
||||
initialSMPClientVersion = VersionSMPC 1
|
||||
|
||||
srvHostnamesSMPClientVersion :: VersionSMPC
|
||||
srvHostnamesSMPClientVersion = VersionSMPC 2
|
||||
|
||||
currentSMPClientVersion :: VersionSMPC
|
||||
currentSMPClientVersion = VersionSMPC 2
|
||||
|
||||
supportedSMPClientVRange :: VersionRangeSMPC
|
||||
supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClientVersion
|
||||
|
||||
maxMessageLength :: Int
|
||||
maxMessageLength = 16088
|
||||
@@ -642,7 +663,7 @@ data ClientMsgEnvelope = ClientMsgEnvelope
|
||||
deriving (Show)
|
||||
|
||||
data PubHeader = PubHeader
|
||||
{ phVersion :: Version,
|
||||
{ phVersion :: VersionSMPC,
|
||||
phE2ePubDhKey :: Maybe C.PublicKeyX25519
|
||||
}
|
||||
deriving (Show)
|
||||
@@ -1048,7 +1069,7 @@ data CommandError
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
-- | SMP transmission parser.
|
||||
transmissionP :: THandleParams -> Parser RawTransmission
|
||||
transmissionP :: THandleParams v -> Parser RawTransmission
|
||||
transmissionP THandleParams {sessionId, implySessId} = do
|
||||
authenticator <- smpP
|
||||
authorized <- A.takeByteString
|
||||
@@ -1062,16 +1083,16 @@ transmissionP THandleParams {sessionId, implySessId} = do
|
||||
command <- A.takeByteString
|
||||
pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command}
|
||||
|
||||
class (ProtocolEncoding err msg, ProtocolEncoding err (ProtoCommand msg), Show err, Show msg) => Protocol err msg | 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 -> ExceptT TransportError IO (THandle c)
|
||||
protocolClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> ExceptT TransportError IO (THandle v c)
|
||||
protocolPing :: ProtoCommand msg
|
||||
protocolError :: msg -> Maybe err
|
||||
|
||||
type ProtoServer msg = ProtocolServer (ProtoType msg)
|
||||
|
||||
instance Protocol ErrorType BrokerMsg where
|
||||
instance Protocol SMPVersion ErrorType BrokerMsg where
|
||||
type ProtoCommand BrokerMsg = Cmd
|
||||
type ProtoType BrokerMsg = 'PSMP
|
||||
protocolClientHandshake = smpClientHandshake
|
||||
@@ -1080,14 +1101,14 @@ instance Protocol ErrorType BrokerMsg where
|
||||
ERR e -> Just e
|
||||
_ -> Nothing
|
||||
|
||||
class ProtocolMsgTag (Tag msg) => ProtocolEncoding err msg | msg -> err where
|
||||
class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg -> v where
|
||||
type Tag msg
|
||||
encodeProtocol :: Version -> msg -> ByteString
|
||||
protocolP :: Version -> Tag msg -> Parser msg
|
||||
encodeProtocol :: Version v -> msg -> ByteString
|
||||
protocolP :: Version v -> Tag msg -> Parser msg
|
||||
fromProtocolError :: ProtocolErrorType -> err
|
||||
checkCredentials :: SignedRawTransmission -> msg -> Either err msg
|
||||
|
||||
instance PartyI p => ProtocolEncoding ErrorType (Command p) where
|
||||
instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
|
||||
type Tag (Command p) = CommandTag p
|
||||
encodeProtocol v = \case
|
||||
NEW rKey dhKey auth_ subMode
|
||||
@@ -1114,7 +1135,7 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where
|
||||
|
||||
protocolP v tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP v (CT (sParty @p) tag)
|
||||
|
||||
fromProtocolError = fromProtocolError @ErrorType @BrokerMsg
|
||||
fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials (auth, _, queueId, _) cmd = case cmd of
|
||||
@@ -1136,7 +1157,7 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where
|
||||
| isNothing auth || B.null queueId -> Left $ CMD NO_AUTH
|
||||
| otherwise -> Right cmd
|
||||
|
||||
instance ProtocolEncoding ErrorType Cmd where
|
||||
instance ProtocolEncoding SMPVersion ErrorType Cmd where
|
||||
type Tag Cmd = CmdTag
|
||||
encodeProtocol v (Cmd _ c) = encodeProtocol v c
|
||||
|
||||
@@ -1164,12 +1185,12 @@ instance ProtocolEncoding ErrorType Cmd where
|
||||
PING_ -> pure PING
|
||||
CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
|
||||
|
||||
fromProtocolError = fromProtocolError @ErrorType @BrokerMsg
|
||||
fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
|
||||
{-# INLINE fromProtocolError #-}
|
||||
|
||||
checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c
|
||||
|
||||
instance ProtocolEncoding ErrorType BrokerMsg where
|
||||
instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
type Tag BrokerMsg = BrokerMsgTag
|
||||
encodeProtocol _v = \case
|
||||
IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh)
|
||||
@@ -1221,12 +1242,12 @@ instance ProtocolEncoding ErrorType BrokerMsg where
|
||||
| otherwise -> Right cmd
|
||||
|
||||
-- | Parse SMP protocol commands and broker messages
|
||||
parseProtocol :: forall err msg. ProtocolEncoding err msg => Version -> ByteString -> Either err msg
|
||||
parseProtocol :: forall v err msg. ProtocolEncoding v err msg => Version v -> ByteString -> Either err msg
|
||||
parseProtocol v s =
|
||||
let (tag, params) = B.break (== ' ') s
|
||||
in case decodeTag tag of
|
||||
Just cmd -> parse (protocolP v cmd) (fromProtocolError @err @msg $ PECmdSyntax) params
|
||||
Nothing -> Left $ fromProtocolError @err @msg $ PECmdUnknown
|
||||
Just cmd -> parse (protocolP v cmd) (fromProtocolError @v @err @msg $ PECmdSyntax) params
|
||||
Nothing -> Left $ fromProtocolError @v @err @msg $ PECmdUnknown
|
||||
|
||||
checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p)
|
||||
checkParty c = case testEquality (sParty @p) (sParty @p') of
|
||||
@@ -1281,7 +1302,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 v c -> 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 ()]
|
||||
@@ -1290,7 +1311,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 v c -> ByteString -> IO (Either TransportError ())
|
||||
tPutLog th s = do
|
||||
r <- tPutBlock th s
|
||||
case r of
|
||||
@@ -1352,7 +1373,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 e c => THandleParams -> Transmission c -> TransmissionForAuth
|
||||
encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> TransmissionForAuth
|
||||
encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId} t =
|
||||
TransmissionForAuth {tForAuth, tToSend = if implySessId then t' else tForAuth}
|
||||
where
|
||||
@@ -1360,24 +1381,24 @@ encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId}
|
||||
t' = encodeTransmission_ v t
|
||||
{-# INLINE encodeTransmissionForAuth #-}
|
||||
|
||||
encodeTransmission :: ProtocolEncoding e c => THandleParams -> Transmission c -> ByteString
|
||||
encodeTransmission :: ProtocolEncoding v e c => THandleParams v -> Transmission c -> ByteString
|
||||
encodeTransmission THandleParams {thVersion = v, sessionId, implySessId} t =
|
||||
if implySessId then t' else smpEncode sessionId <> t'
|
||||
where
|
||||
t' = encodeTransmission_ v t
|
||||
{-# INLINE encodeTransmission #-}
|
||||
|
||||
encodeTransmission_ :: ProtocolEncoding e c => Version -> Transmission c -> ByteString
|
||||
encodeTransmission_ :: ProtocolEncoding v e c => Version v -> Transmission c -> ByteString
|
||||
encodeTransmission_ v (CorrId corrId, queueId, command) =
|
||||
smpEncode (corrId, queueId) <> encodeProtocol v 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 v c -> 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 v -> ByteString -> NonEmpty (Either TransportError RawTransmission)
|
||||
tParse thParams@THandleParams {batch} s
|
||||
| batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts
|
||||
| otherwise = [tParse1 s]
|
||||
@@ -1389,24 +1410,24 @@ 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 v err cmd c. (ProtocolEncoding v err cmd, Transport c) => THandle v c -> 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 v err cmd. ProtocolEncoding v err cmd => THandleParams v -> Either TransportError RawTransmission -> SignedTransmission err cmd
|
||||
tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \case
|
||||
Right RawTransmission {authenticator, authorized, sessId, corrId, entityId, command}
|
||||
| implySessId || sessId == sessionId ->
|
||||
let decodedTransmission = (,corrId,entityId,command) <$> decodeTAuthBytes authenticator
|
||||
in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission
|
||||
| otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession))
|
||||
| otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PESession))
|
||||
Left _ -> tError ""
|
||||
where
|
||||
tError :: ByteString -> SignedTransmission err cmd
|
||||
tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PEBlock))
|
||||
tError corrId = (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @v @err @cmd PEBlock))
|
||||
|
||||
tParseValidate :: ByteString -> SignedRawTransmission -> SignedTransmission err cmd
|
||||
tParseValidate signed t@(sig, corrId, entityId, command) =
|
||||
let cmd = parseProtocol @err @cmd v command >>= checkCredentials t
|
||||
let cmd = parseProtocol @v @err @cmd v command >>= checkCredentials t
|
||||
in (sig, signed, (CorrId corrId, entityId, cmd))
|
||||
|
||||
$(J.deriveJSON defaultJSON ''MsgFlags)
|
||||
|
||||
Reference in New Issue
Block a user