From 5e29e3698e889a25bb3ac0bda183db3d184b7497 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 1 Jan 2022 13:10:19 +0000 Subject: [PATCH] binary SMP protocol encoding, split Command type to two types (#245) * binary SMP protocol encoding (server tests fail) * use 1 byte for bytestring length when encoding/decoding * Encoding class, binary tags * update server tests * negotiate SMP version in client/server handshake * add version columns to queues and connections * split parsing SMP client commands and server responses to different functions * check uniqueness of protocol tags * split client commands and server responses/messages to separate types * update types in SMP client * remove pattern synonyms for SMP errors * simplify getHandshake * update SMP protocol encoding in protocol spec * encode time as a number of seconds (64-bit integer) since epoch --- apps/smp-server/Main.hs | 4 +- migrations/20210101_initial.sql | 8 +- protocol/simplex-messaging.md | 114 ++-- simplexmq.cabal | 6 +- src/Simplex/Messaging/Agent.hs | 12 +- src/Simplex/Messaging/Agent/Client.hs | 10 +- src/Simplex/Messaging/Agent/Protocol.hs | 22 +- src/Simplex/Messaging/Client.hs | 38 +- src/Simplex/Messaging/Crypto.hs | 49 +- src/Simplex/Messaging/Crypto/Ratchet.hs | 34 +- src/Simplex/Messaging/Encoding.hs | 80 +++ src/Simplex/Messaging/Parsers.hs | 8 - src/Simplex/Messaging/Protocol.hs | 596 ++++++++++-------- src/Simplex/Messaging/Server.hs | 70 +- src/Simplex/Messaging/Server/Env/STM.hs | 4 +- src/Simplex/Messaging/Server/MsgStore.hs | 8 +- src/Simplex/Messaging/Server/QueueStore.hs | 2 +- .../Messaging/Server/QueueStore/STM.hs | 4 +- src/Simplex/Messaging/Transport.hs | 97 ++- src/Simplex/Messaging/Version.hs | 50 ++ tests/AgentTests/DoubleRatchetTests.hs | 3 +- tests/CoreTests/EncodingTests.hs | 46 ++ tests/{ => CoreTests}/ProtocolErrorTests.hs | 8 +- tests/CoreTests/VersionRangeTests.hs | 51 ++ tests/SMPAgentClient.hs | 2 +- tests/SMPClient.hs | 34 +- tests/ServerTests.hs | 306 +++++---- tests/Test.hs | 9 +- 28 files changed, 995 insertions(+), 680 deletions(-) create mode 100644 src/Simplex/Messaging/Encoding.hs create mode 100644 src/Simplex/Messaging/Version.hs create mode 100644 tests/CoreTests/EncodingTests.hs rename tests/{ => CoreTests}/ProtocolErrorTests.hs (73%) create mode 100644 tests/CoreTests/VersionRangeTests.hs diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index e29bb804a..64a863eeb 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -20,7 +20,7 @@ import Options.Applicative import Simplex.Messaging.Server (runSMPServer) import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Server.StoreLog (StoreLog, openReadStoreLog, storeLogFilePath) -import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..), currentSMPVersionStr, encodeFingerprint, loadFingerprint) +import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..), encodeFingerprint, loadFingerprint, simplexMQVersion) import Simplex.Messaging.Transport.WebSockets (WS) import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeDirectoryRecursive, removeFile) import System.Exit (exitFailure) @@ -126,7 +126,7 @@ makeConfig IniOpts {serverPort, enableWebsockets, caCertificateFile, serverPriva printConfig :: ServerConfig -> String -> IO () printConfig ServerConfig {storeLog} fingerprint = do - putStrLn $ "SMP server version: " <> B.unpack currentSMPVersionStr + putStrLn $ "SMP server v" <> simplexMQVersion putStrLn $ "fingerprint: " <> fingerprint putStrLn $ case storeLog of Just s -> "store log: " <> storeLogFilePath s diff --git a/migrations/20210101_initial.sql b/migrations/20210101_initial.sql index 3e7e18e0c..f4a4fe804 100644 --- a/migrations/20210101_initial.sql +++ b/migrations/20210101_initial.sql @@ -13,7 +13,9 @@ CREATE TABLE connections ( last_internal_snd_msg_id INTEGER NOT NULL DEFAULT 0, last_external_snd_msg_id INTEGER NOT NULL DEFAULT 0, last_rcv_msg_hash BLOB NOT NULL DEFAULT x'', - last_snd_msg_hash BLOB NOT NULL DEFAULT x'' + last_snd_msg_hash BLOB NOT NULL DEFAULT x'', + smp_agent_version INTEGER NOT NULL DEFAULT 1, + e2e_version INTEGER NOT NULL DEFAULT 1 ) WITHOUT ROWID; CREATE TABLE rcv_queues ( @@ -29,6 +31,8 @@ CREATE TABLE rcv_queues ( snd_id BLOB NOT NULL, snd_key BLOB, status TEXT NOT NULL, + smp_server_version INTEGER NOT NULL DEFAULT 1, + smp_client_version INTEGER NOT NULL DEFAULT 1, PRIMARY KEY (host, port, rcv_id), FOREIGN KEY (host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE, @@ -44,6 +48,8 @@ CREATE TABLE snd_queues ( e2e_pub_key BLOB NOT NULL, e2e_dh_secret BLOB NOT NULL, status TEXT NOT NULL, + smp_server_version INTEGER NOT NULL DEFAULT 1, + smp_client_version INTEGER NOT NULL DEFAULT 1, PRIMARY KEY (host, port, snd_id), FOREIGN KEY (host, port) REFERENCES servers ON DELETE RESTRICT ON UPDATE CASCADE diff --git a/protocol/simplex-messaging.md b/protocol/simplex-messaging.md index 7e4be2200..0667e2c32 100644 --- a/protocol/simplex-messaging.md +++ b/protocol/simplex-messaging.md @@ -124,13 +124,10 @@ port = 1*DIGIT serverIdentity = base64url queueId = base64url base64url = ; RFC4648, section 5 -recipientDhPublicKey = dhPublicKey -dhPublicKey = encryptionScheme ":" x509UrlEncoded -; the recipient's key for DH exchange to derive the secret +recipientDhPublicKey = x509UrlEncoded +; the recipient's Curve25519 key for DH exchange to derive the secret ; that the sender will use to encrypt delivered messages - -encryptionScheme = %s"x25519" -; x25519 scheme means [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305). +; using [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305). x509UrlEncoded = ``` @@ -435,35 +432,29 @@ Sending any of the commands in this section (other than `create`, that is sent w This command is sent by the recipient to the SMP server to create a new queue. The syntax is: ```abnf -create = %s"NEW" SP recipientSignaturePublicKey SP recipientDhPublicKey -recipientSignaturePublicKey = signaturePublicKey -; the recipient's public key to verify commands for this queue +create = %s"NEW " recipientSignaturePublicKey recipientDhPublicKey +recipientSignaturePublicKey = length x509encoded +; the recipient's Ed25519 or Ed448 public key to verify commands for this queue -signaturePublicKey = signatureScheme ":" x509encoded -signatureScheme = %s"rsa" | %s"ed25519" | %s"ed448" -; "rsa" means deprecated RSA-PSS signature scheme, -; it must not be used for the new queues. - -recipientDhPublicKey = dhPublicKey -dhPublicKey = encryptionScheme ":" x509encoded -; the recipient's key for DH exchange to derive the secret +recipientDhPublicKey = length x509encoded +; the recipient's Curve25519 key for DH exchange to derive the secret ; that the server will use to encrypt delivered message bodies +; using [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305). -encryptionScheme = %s"x25519" -; x25519 scheme means [NaCl crypto_box][16] encryption scheme (curve25519xsalsa20poly1305). +x509encoded = -x509encoded = +length = 1*1 OCTET ``` If the queue is created successfully, the server must send `queueIds` response with the recipient's and sender's queue IDs and public keys to sign all responses and messages and to encrypt delivered message bodies: ```abnf -queueIds = %s"IDS" SP recipientId SP senderId SP srvDhPublicKey -serverDhPublicKey = dhPublicKey -; the server's key for DH exchange to derive the secret +queueIds = %s"IDS " recipientId senderId srvDhPublicKey +serverDhPublicKey = length x509encoded +; the server's Curve25519 key for DH exchange to derive the secret ; that the server will use to encrypt delivered message bodies to the recipient -recipientId = encoded -senderId = encoded +recipientId = length *OCTET ; 16-24 bytes +senderId = length *OCTET ; 16-24 bytes ``` Once the queue is created, the recipient gets automatically subscribed to receive the messages from that queue, until the transport connection is closed. The `subscribe` command is needed only to start receiving the messages from the existing queue when the new transport connection is opened. @@ -491,9 +482,9 @@ This transmission and its response MUST be signed. This command is sent by the recipient to the server to add sender's key to the queue: ```abnf -secure = %s"KEY" SP senderSignaturePublicKey -senderSignaturePublicKey = signaturePublicKey -; the sender's key to verify SEND commands for this queue +secure = %s"KEY " senderSignaturePublicKey +senderSignaturePublicKey = length x509encoded +; the sender's Ed25519 or Ed448 key to verify SEND commands for this queue ``` `senderKey` is received from the sender as part of the first message - see [Send Message](#send-message) command. @@ -505,15 +496,16 @@ Once the queue is secured only signed messages can be sent to it. This command is sent by the recipient to the server to add notifier's key to the queue, to allow push notifications server to receive notifications when the message arrives, via a separate queue ID, without receiving message content. ```abnf -enableNotifications = %s"NKEY" SP notifierKey -notifierKey = signatureScheme ":" x509encoded ; the notifier's public key public key to verify NSUB command for this queue +enableNotifications = %s"NKEY " notifierKey +notifierKey = length x509encoded +; the notifier's Ed25519 or Ed448 public key public key to verify NSUB command for this queue ``` The server will respond with `notifierId` response if notifications were enabled and the notifier's key was successfully added to the queue: ```abnf -notifierId = %s"NID" SP notifierId -recipientId = encoded +notifierId = %s"NID " notifierId +notifierId = length *OCTET ; 16-24 bytes ``` This response is sent with the recipient's queue ID (the third part of the transmission). @@ -567,13 +559,13 @@ Currently SMP defines only one command that can be used by senders - `send` mess This command is sent to the server by the sender both to confirm the queue after the sender received out-of-band message from the recipient and to send messages after the queue is secured: ```abnf -send = %s"SEND" SP smpEncMessage +send = %s"SEND " smpEncMessage smpEncMessage = smpPubHeader sentMsgBody ; message up to 15968 bytes -smpPubHeader = smpClientVersion encodedLenKey +smpPubHeader = smpClientVersion senderPublicDhKey smpClientVersion = word16 -encodedLenKey = keyLen x509binary -keyLen = word16 -x509binary = +senderPublicDhKey = length x509encoded +; sender's Curve25519 public key to agree DH secret for E2E encryption in this queue +x509encoded = sentMsgBody = 15842*15842 OCTET ; E2E-encrypted smpClientMessage padded to 15842 bytes before encryption word16 = 2*2 OCTET @@ -599,7 +591,8 @@ smpClientMessage = smpPrivHeader clientMsgBody smpPrivHeader = emptyHeader / smpConfirmationHeader emptyHeader = " " smpConfirmationHeader = %s"K" senderKey -senderKey = encodedLenKey ; the sender's public key to sign SEND commands for this queue +senderKey = length x509encoded +; the sender's Ed25519 or Ed448 public key to sign SEND commands for this queue clientMsgBody = *OCTET ; up to 15784 in case of emptyHeader ``` @@ -700,16 +693,16 @@ See its syntax in [Create queue command](#create-queue-command) The server must deliver messages to all subscribed simplex queues on the currently open transport connection. The syntax for the message delivery is: ```abnf -message = %s"MSG" SP msgId SP timestamp SP encryptedMsgBody +message = %s"MSG " msgId SP timestamp SP encryptedMsgBody encryptedMsgBody = ; server-encrypted padded sent msgBody paddedSentMsgBody = ; maxMessageLength = 15968 -msgId = encoded -timestamp = +msgId = length 24*24OCTET +timestamp = 8*8OCTET ``` -`msgId` - unique message ID generated by the server based on cryptographically strong random bytes. It should be used by the clients to detect messages that were delivered more than once (in case the transport connection was interrupted and the server did not receive the message delivery acknowledgement). +`msgId` - unique message ID generated by the server based on cryptographically strong random bytes. It should be used by the clients to detect messages that were delivered more than once (in case the transport connection was interrupted and the server did not receive the message delivery acknowledgement). Message ID is used as a nonce for server/recipient encryption of message bodies. -`timestamp` - the UTC time when the server received the message from the sender, must be in date-time format defined by [RFC 3339][10] +`timestamp` - system time when the server received the message from the sender as **a number of seconds** since Unix epoch (1970-01-01) encoded as 64-bit integer in network byte order. If a client system/language does not support 64-bit integers, until 2106 it is safe to simply skip the first 4 zero bytes and decode 32-bit unsigned integer (or as signed integer until 2038). When server delivers the messages to the recipient, message body should be encrypted with the secret derived from DH exchange using the keys passed during the queue creation and returned with `queueIds` response. @@ -759,8 +752,8 @@ No further messages should be delivered to unsubscribed transport connection. The syntax for error responses: ```abnf -error = %s"ERR" SP errorType -errorType = %s"BLOCK" / %s"SESSION" / %s"CMD" SP cmdError / %s"AUTH" / %s"LARGE_MSG" /%s"INTERNAL" +error = %s"ERR " errorType +errorType = %s"BLOCK" / %s"SESSION" / %s"CMD " cmdError / %s"AUTH" / %s"LARGE_MSG" /%s"INTERNAL" cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_QUEUE" ``` @@ -799,29 +792,34 @@ By default, the client and server communicate using [TLS 1.3 protocol][13] restr - TLS_CHACHA20_POLY1305_SHA256 cipher suite (for better performance on mobile devices), - ed25519 and ed448 EdDSA algorithms for signatures, - x25519 and x448 ECDHE groups for key exchange. -- servers must send only one self-signed certificate in the handshake, clients must abort the connection in case more than one certificate is sent. +- servers must send the chain of exactly 2 self-signed certificates in the handshake, with the first (offline) certificate one signing the second (online) certificate. Offline certificate fingerprint is used as a server identity - it is a part of SMP server address. +- The clients must abort the connection in case a different number of certificates is sent. - server and client TLS configuration should not allow resuming the sessions. -During TLS handshake the client must validate that the hash of the server certificate SPKI block is equal to the `serverIdentity` the client received as part of SMP server address; if the server identity does not match the client must abort the connection. +During TLS handshake the client must validate that the fingerprint of the online server certificate is equal to the `serverIdentity` the client received as part of SMP server address; if the server identity does not match the client must abort the connection. Once TLS handshake is complete, client and server will exchange blocks of fixed size (16384 bytes). -The first block sent by the client should be `clientHello` and the server should respond with `serverHello`: +The first block sent by the server should be `serverHello` and the client should respond with `clientHello` - these blocks are used to agree SMP protocol version: ```abnf -clientHello = SP smpVersion SP reserved pad -serverHello = sessionIdentifier SP smpVersion SP reserved pad -sessionIdentifier = ; unique session identifier derived from transport connection handshake - ; it should be included in all SMP transmissions sent in this transport connection. +serverHello = minSmpVersion maxSmpVersion sessionIdentifier pad +minSmpVersion = smpVersion +maxSmpVersion = smpVersion +sessionIdentifier = length *OCTET +; unique session identifier derived from transport connection handshake +; it should be included in all SMP transmissions sent in this transport connection. -smpVersion = %s"SMP v" 1*DIGIT "." 1*DIGIT "." 1*DIGIT ; semver format, the version in this document is v0.5.0 -reserved = -pad = 1*OCTET +clientHello = smpVersion pad +; chosen SMP protocol version - it must be the maximum supported version +; within the range offered by the server + +smpVersion = 2*2OCTET ; Word16 version number + +pad = *OCTET ``` -For TLS 1.3 transport client should assert that `sessionIdentifier` is equal to `tls-unique` channel binding defined in [RFC 5929][14] (TLS Finished message struct); we pass it in `serverHello` block to allow communication over some other transport protocol. - -The communication party (client or server) that has the lower protocol version should assume that this version will be supported by another party, the party with the higher protocol version should abort the connection in case they cannot support the lower version. +For TLS 1.3 transport client should assert that `sessionIdentifier` is equal to `tls-unique` channel binding defined in [RFC 5929][14] (TLS Finished message struct); we pass it in `serverHello` block to allow communication over some other transport protocol (possibly, with another channel binding). [1]: https://en.wikipedia.org/wiki/Man-in-the-middle_attack [2]: https://en.wikipedia.org/wiki/End-to-end_encryption diff --git a/simplexmq.cabal b/simplexmq.cabal index 51194c03e..52717be04 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -42,6 +42,7 @@ library Simplex.Messaging.Client Simplex.Messaging.Crypto Simplex.Messaging.Crypto.Ratchet + Simplex.Messaging.Encoding Simplex.Messaging.Parsers Simplex.Messaging.Protocol Simplex.Messaging.Server @@ -54,6 +55,7 @@ library Simplex.Messaging.Transport Simplex.Messaging.Transport.WebSockets Simplex.Messaging.Util + Simplex.Messaging.Version other-modules: Paths_simplexmq hs-source-dirs: @@ -219,7 +221,9 @@ test-suite smp-server-test AgentTests.DoubleRatchetTests AgentTests.FunctionalAPITests AgentTests.SQLiteTests - ProtocolErrorTests + CoreTests.EncodingTests + CoreTests.ProtocolErrorTests + CoreTests.VersionRangeTests ServerTests SMPAgentClient SMPClient diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index d5df1e746..762b02a29 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -74,6 +74,7 @@ import Data.Maybe (isJust) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock +import Data.Time.Clock.System (systemToUTCTime) import Database.SQLite.Simple (SQLError) import Simplex.Messaging.Agent.Client import Simplex.Messaging.Agent.Env.SQLite @@ -83,10 +84,11 @@ import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore) import Simplex.Messaging.Client (SMPServerTransmission) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (parse) import Simplex.Messaging.Protocol (MsgBody) import qualified Simplex.Messaging.Protocol as SMP -import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), currentSMPVersionStr, loadTLSServerParams, runTransportServer) +import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), loadTLSServerParams, runTransportServer, simplexMQVersion) import Simplex.Messaging.Util (bshow, tryError, unlessM) import System.Random (randomR) import UnliftIO.Async (async, race_) @@ -114,7 +116,7 @@ runSMPAgentBlocking (ATransport t) started cfg@AgentConfig {tcpPort, caCertifica -- tlsServerParams not in env to avoid breaking functional api w/t key and certificate generation tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile agentCertificateFile agentPrivateKeyFile runTransportServer started tcpPort tlsServerParams $ \(h :: c) -> do - liftIO . putLn h $ "Welcome to SMP agent v" <> currentSMPVersionStr + liftIO . putLn h $ "Welcome to SMP agent v" <> B.pack simplexMQVersion c <- getAgentClient logConnection c True race_ (connectClient h c) (runAgentClient c) @@ -526,7 +528,7 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do -- TODO deduplicate with previously received msgBody <- agentCbDecrypt rcvDhSecret (C.cbNonce srvMsgId) msgBody' encMessage@SMP.EncMessage {emHeader = SMP.PubHeader v e2ePubKey} <- - liftEither $ parse SMP.encMessageP (AGENT A_MESSAGE) msgBody + liftEither $ parse smpP (AGENT A_MESSAGE) msgBody case e2eShared of Nothing -> do let e2eDhSecret = C.dh' e2ePubKey e2ePrivKey @@ -551,7 +553,7 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do -- note that there is no ACK sent here, it is sent with agent's user ACK command -- TODO add hash to other messages let msgHash = C.sha256Hash msg - agentClientMsg prevMsgHash sndMsgId (srvMsgId, srvTs) body msgHash + agentClientMsg prevMsgHash sndMsgId (srvMsgId, systemToUTCTime srvTs) body msgHash _ -> prohibited >> ack SMP.END -> do removeSubscription c connId @@ -577,7 +579,7 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do decryptAgentMessage e2eDhSecret SMP.EncMessage {emNonce, emBody} = do msg <- agentCbDecrypt e2eDhSecret emNonce emBody agentMessage <- - liftEither $ clientToAgentMsg =<< parse SMP.clientMessageP (AGENT A_MESSAGE) msg + liftEither $ clientToAgentMsg =<< parse smpP (AGENT A_MESSAGE) msg pure (msg, agentMessage) smpConfirmation :: SMPConfirmation -> m () diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 20defad38..e7c9f80f2 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -57,9 +57,11 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, QueueIdsKeys (..), SndPublicVerifyKey) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Util (bshow, liftEitherError, liftError) +import Simplex.Messaging.Version import UnliftIO.Exception (IOException) import qualified UnliftIO.Exception as E import UnliftIO.STM @@ -371,8 +373,8 @@ agentCbEncrypt SndQueue {e2ePubKey, e2eDhSecret} msg = do liftEither . first cryptoError $ C.cbEncrypt e2eDhSecret emNonce msg SMP.e2eEncMessageLength -- TODO per-queue client version - let emHeader = SMP.PubHeader SMP.clientVersion e2ePubKey - pure $ SMP.serializeEncMessage SMP.EncMessage {emHeader, emNonce, emBody} + let emHeader = SMP.PubHeader (maxVersion SMP.smpClientVersion) e2ePubKey + pure $ smpEncode SMP.EncMessage {emHeader, emNonce, emBody} agentCbEncryptOnce :: AgentMonad m => C.PublicKeyX25519 -> ByteString -> m ByteString agentCbEncryptOnce dhRcvPubKey msg = do @@ -383,8 +385,8 @@ agentCbEncryptOnce dhRcvPubKey msg = do liftEither . first cryptoError $ C.cbEncrypt e2eDhSecret emNonce msg SMP.e2eEncMessageLength -- TODO per-queue client version - let emHeader = SMP.PubHeader SMP.clientVersion dhSndPubKey - pure $ SMP.serializeEncMessage SMP.EncMessage {emHeader, emNonce, emBody} + let emHeader = SMP.PubHeader (maxVersion SMP.smpClientVersion) dhSndPubKey + pure $ smpEncode SMP.EncMessage {emHeader, emNonce, emBody} agentCbDecrypt :: AgentMonad m => C.DhSecretX25519 -> C.CbNonce -> ByteString -> m ByteString agentCbDecrypt dhSecret nonce msg = diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index f882c0dca..3f78d1cb9 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -84,6 +84,7 @@ module Simplex.Messaging.Agent.Protocol serializeConnReq, serializeConnReq', serializeAgentError, + serializeSmpErrorType, commandP, smpServerP, smpQueueUriP, @@ -92,6 +93,7 @@ module Simplex.Messaging.Agent.Protocol connReqP', msgIntegrityP, agentErrorTypeP, + smpErrorTypeP, serializeQueueStatus, queueStatusT, @@ -128,6 +130,7 @@ import Generic.Random (genericArbitraryU) import Network.HTTP.Types (parseSimpleQuery, renderSimpleQuery) import Network.Socket (HostName, ServiceName) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol ( ClientMessage (..), @@ -136,7 +139,6 @@ import Simplex.Messaging.Protocol MsgId, PrivHeader (..), SndPublicVerifyKey, - serializeClientMessage, ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP) @@ -317,7 +319,7 @@ data AMessage deriving (Show) serializeAgentMessage :: AgentMessage -> ByteString -serializeAgentMessage = serializeClientMessage . agentToClientMsg +serializeAgentMessage = smpEncode . agentToClientMsg agentToClientMsg :: AgentMessage -> ClientMessage agentToClientMsg = \case @@ -754,8 +756,8 @@ serializeMsgIntegrity = \case -- | SMP agent protocol error parser. agentErrorTypeP :: Parser AgentErrorType agentErrorTypeP = - "SMP " *> (SMP <$> SMP.errorTypeP) - <|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> SMP.errorTypeP) + "SMP " *> (SMP <$> smpErrorTypeP) + <|> "BROKER RESPONSE " *> (BROKER . RESPONSE <$> smpErrorTypeP) <|> "BROKER TRANSPORT " *> (BROKER . TRANSPORT <$> transportErrorP) <|> "INTERNAL " *> (INTERNAL <$> parseRead A.takeByteString) <|> parseRead2 @@ -763,11 +765,19 @@ agentErrorTypeP = -- | Serialize SMP agent protocol error. serializeAgentError :: AgentErrorType -> ByteString serializeAgentError = \case - SMP e -> "SMP " <> SMP.serializeErrorType e - BROKER (RESPONSE e) -> "BROKER RESPONSE " <> SMP.serializeErrorType e + SMP e -> "SMP " <> serializeSmpErrorType e + BROKER (RESPONSE e) -> "BROKER RESPONSE " <> serializeSmpErrorType e BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e e -> bshow e +-- | SMP error parser. +smpErrorTypeP :: Parser ErrorType +smpErrorTypeP = "CMD " *> (SMP.CMD <$> parseRead1) <|> parseRead1 + +-- | Serialize SMP error. +serializeSmpErrorType :: ErrorType -> ByteString +serializeSmpErrorType = bshow + serializeBinary :: ByteString -> ByteString serializeBinary body = bshow (B.length body) <> "\n" <> body diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index b48b72297..53028e4e7 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -84,12 +84,12 @@ data SMPClient = SMPClient clientCorrId :: TVar Natural, sentCommands :: TVar (Map CorrId Request), sndQ :: TBQueue SentRawTransmission, - rcvQ :: TBQueue (SignedTransmission (Command 'Broker)), + rcvQ :: TBQueue (SignedTransmission BrokerMsg), msgQ :: TBQueue SMPServerTransmission } -- | Type synonym for transmission from some SPM server queue. -type SMPServerTransmission = (SMPServer, RecipientId, Command 'Broker) +type SMPServerTransmission = (SMPServer, RecipientId, BrokerMsg) -- | SMP client configuration. data SMPClientConfig = SMPClientConfig @@ -118,7 +118,7 @@ data Request = Request responseVar :: TMVar Response } -type Response = Either SMPClientError (Command 'Broker) +type Response = Either SMPClientError BrokerMsg -- | Connects to 'SMPServer' using passed client configuration -- and queue for messages and notifications. @@ -185,12 +185,12 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ dis send SMPClient {sndQ} h = forever $ atomically (readTBQueue sndQ) >>= tPut h receive :: Transport c => SMPClient -> THandle c -> IO () - receive SMPClient {rcvQ} h = forever $ tGet fromServer h >>= atomically . writeTBQueue rcvQ + receive SMPClient {rcvQ} h = forever $ tGet h >>= atomically . writeTBQueue rcvQ ping :: SMPClient -> IO () ping c = forever $ do threadDelay smpPing - runExceptT $ sendSMPCommand c Nothing "" (ClientCmd SSender PING) + runExceptT $ sendSMPCommand c Nothing "" PING process :: SMPClient -> IO () process SMPClient {rcvQ, sentCommands} = forever $ do @@ -211,7 +211,7 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ dis Right r -> Right r else Left SMPUnexpectedResponse - sendMsg :: QueueId -> Either ErrorType (Command 'Broker) -> IO () + sendMsg :: QueueId -> Either ErrorType BrokerMsg -> IO () sendMsg qId = \case Right cmd -> atomically $ writeTBQueue msgQ (smpServer, qId, cmd) -- TODO send everything else to errQ and log in agent @@ -257,7 +257,7 @@ createSMPQueue :: RcvPublicDhKey -> ExceptT SMPClientError IO QueueIdsKeys createSMPQueue c rpKey rKey dhKey = - sendSMPCommand c (Just rpKey) "" (ClientCmd SRecipient $ NEW rKey dhKey) >>= \case + sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case IDS qik -> pure qik _ -> throwE SMPUnexpectedResponse @@ -266,7 +266,7 @@ createSMPQueue c rpKey rKey dhKey = -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO () subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId = - sendSMPCommand c (Just rpKey) rId (ClientCmd SRecipient SUB) >>= \case + sendSMPCommand c (Just rpKey) rId SUB >>= \case OK -> return () cmd@MSG {} -> lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd) @@ -276,20 +276,20 @@ subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId = -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO () -subscribeSMPQueueNotifications = okSMPCommand $ ClientCmd SNotifier NSUB +subscribeSMPQueueNotifications = okSMPCommand NSUB -- | Secure the SMP queue by adding a sender public key. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO () -secureSMPQueue c rpKey rId senderKey = okSMPCommand (ClientCmd SRecipient $ KEY senderKey) c rpKey rId +secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId -- | Enable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT SMPClientError IO NotifierId enableSMPQueueNotifications c rpKey rId notifierKey = - sendSMPCommand c (Just rpKey) rId (ClientCmd SRecipient $ NKEY notifierKey) >>= \case + sendSMPCommand c (Just rpKey) rId (NKEY notifierKey) >>= \case NID nId -> pure nId _ -> throwE SMPUnexpectedResponse @@ -298,7 +298,7 @@ enableSMPQueueNotifications c rpKey rId notifierKey = -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO () sendSMPMessage c spKey sId msg = - sendSMPCommand c spKey sId (ClientCmd SSender $ SEND msg) >>= \case + sendSMPCommand c spKey sId (SEND msg) >>= \case OK -> pure () _ -> throwE SMPUnexpectedResponse @@ -307,7 +307,7 @@ sendSMPMessage c spKey sId msg = -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO () ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId = - sendSMPCommand c (Just rpKey) rId (ClientCmd SRecipient ACK) >>= \case + sendSMPCommand c (Just rpKey) rId ACK >>= \case OK -> return () cmd@MSG {} -> lift . atomically $ writeTBQueue msgQ (smpServer, rId, cmd) @@ -318,26 +318,26 @@ ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId = -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO () -suspendSMPQueue = okSMPCommand $ ClientCmd SRecipient OFF +suspendSMPQueue = okSMPCommand OFF -- | Irreversibly delete SMP queue and all messages in it. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO () -deleteSMPQueue = okSMPCommand $ ClientCmd SRecipient DEL +deleteSMPQueue = okSMPCommand DEL -okSMPCommand :: ClientCmd -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO () +okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO () okSMPCommand cmd c pKey qId = sendSMPCommand c (Just pKey) qId cmd >>= \case OK -> return () _ -> throwE SMPUnexpectedResponse --- | Send any SMP command ('ClientCmd' type). +-- | Send SMP command -- TODO sign all requests (SEND of SMP confirmation would be signed with the same key that is passed to the recipient) -sendSMPCommand :: SMPClient -> Maybe C.APrivateSignKey -> QueueId -> ClientCmd -> ExceptT SMPClientError IO (Command 'Broker) +sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, sessionId, tcpTimeout} pKey qId cmd = do corrId <- lift_ getNextCorrId - t <- signTransmission $ serializeTransmission sessionId (corrId, qId, cmd) + t <- signTransmission $ encodeTransmission sessionId (corrId, qId, cmd) ExceptT $ sendRecv corrId t where lift_ :: STM a -> ExceptT SMPClientError IO a diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index f5dadf0cc..aa82cbeb5 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -66,9 +67,6 @@ module Simplex.Messaging.Crypto serializePubKeyUri', strPubKeyP, strPubKeyUriP, - encodeLenKey', - encodeLenKey, - binaryLenKeyP, encodePubKey, encodePubKey', binaryPubKeyP, @@ -116,7 +114,6 @@ module Simplex.Messaging.Crypto cbDecrypt, cbNonce, randomCbNonce, - cbNonceP, -- * SHA256 hash sha256Hash, @@ -168,7 +165,8 @@ import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) import GHC.TypeLits (ErrorMessage (..), TypeError) import Network.Transport.Internal (decodeWord16, encodeWord16) -import Simplex.Messaging.Parsers (base64P, base64UriP, blobFieldParser, parseAll, parseString, word16P) +import Simplex.Messaging.Encoding +import Simplex.Messaging.Parsers (base64P, base64UriP, blobFieldParser, parseAll, parseString) import Simplex.Messaging.Util ((<$?>)) type E2EEncryptionVersion = Word16 @@ -428,37 +426,45 @@ dhSecret' (ADhSecret a s) = case testEquality a $ sAlgorithm @a of Just Refl -> Right s _ -> Left "bad DH secret algorithm" --- | Class for all key types +-- | Class for public key types class CryptoPublicKey k where toPubKey :: (forall a. AlgorithmI a => PublicKey a -> b) -> k -> b pubKey :: APublicKey -> Either String k --- | X509 encoding of any public key. instance CryptoPublicKey APublicKey where toPubKey f (APublicKey _ k) = f k pubKey = Right --- | X509 encoding of signature public key. instance CryptoPublicKey APublicVerifyKey where toPubKey f (APublicVerifyKey _ k) = f k pubKey (APublicKey a k) = case signatureAlgorithm a of Just Dict -> Right $ APublicVerifyKey a k _ -> Left "key does not support signature algorithms" --- | X509 encoding of DH public key. instance CryptoPublicKey APublicDhKey where toPubKey f (APublicDhKey _ k) = f k pubKey (APublicKey a k) = case dhAlgorithm a of Just Dict -> Right $ APublicDhKey a k _ -> Left "key does not support DH algorithms" --- | X509 encoding of 'PublicKey'. instance AlgorithmI a => CryptoPublicKey (PublicKey a) where toPubKey = id pubKey (APublicKey a k) = case testEquality a $ sAlgorithm @a of Just Refl -> Right k _ -> Left "bad key algorithm" +instance Encoding APublicVerifyKey where + smpEncode k = smpEncode $ encodePubKey k + smpP = parseAll binaryPubKeyP <$?> smpP + +instance Encoding APublicDhKey where + smpEncode k = smpEncode $ encodePubKey k + smpP = parseAll binaryPubKeyP <$?> smpP + +instance AlgorithmI a => Encoding (PublicKey a) where + smpEncode k = smpEncode $ encodePubKey' k + smpP = parseAll binaryPubKeyP <$?> smpP + -- | base64 X509 key encoding with algorithm prefix serializePubKey :: CryptoPublicKey k => k -> ByteString serializePubKey = toPubKey serializePubKey' @@ -499,24 +505,6 @@ strPublicKeyP_ b64P = do Just Refl -> pure k _ -> fail $ "public key algorithm " <> show a <> " does not match prefix" -encodeLenKey :: CryptoPublicKey k => k -> ByteString -encodeLenKey = toPubKey encodeLenKey' -{-# INLINE encodeLenKey #-} - --- | binary X509 key encoding with 2-bytes length prefix -encodeLenKey' :: PublicKey a -> ByteString -encodeLenKey' k = - let s = encodePubKey' k - len = fromIntegral $ B.length s - in encodeWord16 len <> s -{-# INLINE encodeLenKey' #-} - --- | binary X509 key parser with 2-bytes length prefix -binaryLenKeyP :: CryptoPublicKey k => Parser k -binaryLenKeyP = do - len <- fromIntegral <$> word16P - parseAll binaryPubKeyP <$?> A.take len - encodePubKey :: CryptoPublicKey pk => pk -> ByteString encodePubKey = toPubKey encodePubKey' {-# INLINE encodePubKey #-} @@ -926,8 +914,9 @@ cbNonce s randomCbNonce :: IO CbNonce randomCbNonce = CbNonce <$> getRandomBytes 24 -cbNonceP :: Parser CbNonce -cbNonceP = CbNonce <$> A.take 24 +instance Encoding CbNonce where + smpEncode = unCbNonce + smpP = CbNonce <$> A.take 24 xSalsa20 :: DhSecret X25519 -> ByteString -> ByteString -> (ByteString, ByteString) xSalsa20 (DhSecretX25519 shared) nonce msg = (rs, msg') diff --git a/src/Simplex/Messaging/Crypto/Ratchet.hs b/src/Simplex/Messaging/Crypto/Ratchet.hs index 9eb19726b..fb14c668a 100644 --- a/src/Simplex/Messaging/Crypto/Ratchet.hs +++ b/src/Simplex/Messaging/Crypto/Ratchet.hs @@ -23,9 +23,9 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import Data.Word (Word32) -import Network.Transport.Internal (encodeWord16, encodeWord32) import Simplex.Messaging.Crypto -import Simplex.Messaging.Parsers (parseE, parseE', word16P, word32P) +import Simplex.Messaging.Encoding +import Simplex.Messaging.Parsers (parseE, parseE') import Simplex.Messaging.Util (tryE) data Ratchet a = Ratchet @@ -143,22 +143,16 @@ paddedHeaderLen = 128 fullHeaderLen :: Int fullHeaderLen = paddedHeaderLen + authTagSize + ivSize @AES256 -serializeMsgHeader' :: AlgorithmI a => MsgHeader a -> ByteString -serializeMsgHeader' MsgHeader {msgVersion, msgLatestVersion, msgDHRs, msgPN, msgNs} = - encodeWord16 msgVersion - <> encodeWord16 msgLatestVersion - <> encodeLenKey msgDHRs - <> encodeWord32 msgPN - <> encodeWord32 msgNs - -msgHeaderP' :: AlgorithmI a => Parser (MsgHeader a) -msgHeaderP' = do - msgVersion <- word16P - msgLatestVersion <- word16P - msgDHRs <- binaryLenKeyP - msgPN <- word32P - msgNs <- word32P - pure MsgHeader {msgVersion, msgLatestVersion, msgDHRs, msgPN, msgNs} +instance AlgorithmI a => Encoding (MsgHeader a) where + smpEncode MsgHeader {msgVersion, msgLatestVersion, msgDHRs, msgPN, msgNs} = + smpEncode (msgVersion, msgLatestVersion, msgDHRs, msgPN, msgNs) + smpP = do + msgVersion <- smpP + msgLatestVersion <- smpP + msgDHRs <- smpP + msgPN <- smpP + msgNs <- smpP + pure MsgHeader {msgVersion, msgLatestVersion, msgDHRs, msgPN, msgNs} data EncHeader = EncHeader { ehBody :: ByteString, @@ -213,7 +207,7 @@ rcEncrypt' rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcNs, rcAD} pa where -- header = HEADER(state.DHRs, state.PN, state.Ns) msgHeader = - serializeMsgHeader' + smpEncode MsgHeader { msgVersion = rcVersion rc, msgLatestVersion = currentE2EVersion, @@ -352,7 +346,7 @@ rcDecrypt' rc@Ratchet {rcRcv, rcMKSkipped, rcAD} msg' = do decryptNextHeader hdr = (AdvanceRatchet,) <$> decryptHeader (rcNHKr rc) hdr decryptHeader k EncHeader {ehBody, ehAuthTag, ehIV} = do header <- decryptAEAD k ehIV rcAD ehBody ehAuthTag `catchE` \_ -> throwE CERatchetHeader - parseE' CryptoHeaderError msgHeaderP' header + parseE' CryptoHeaderError smpP header decryptMessage :: MessageKey -> EncMessage -> ExceptT CryptoError IO (Either CryptoError ByteString) decryptMessage (MessageKey mk iv) EncMessage {emHeader, emBody, emAuthTag} = -- DECRYPT(mk, ciphertext, CONCAT(AD, enc_header)) diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs new file mode 100644 index 000000000..65b77a4fe --- /dev/null +++ b/src/Simplex/Messaging/Encoding.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Simplex.Messaging.Encoding (Encoding (..), Tail (..)) where + +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bits (shiftL, shiftR, (.|.)) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Internal (c2w, w2c) +import Data.Int (Int64) +import Data.Time.Clock.System (SystemTime (..)) +import Data.Word (Word16, Word32) +import Network.Transport.Internal (decodeWord16, decodeWord32, encodeWord16, encodeWord32) + +class Encoding a where + smpEncode :: a -> ByteString + smpP :: Parser a + +instance Encoding Char where + smpEncode = B.singleton + smpP = A.anyChar + +instance Encoding Word16 where + smpEncode = encodeWord16 + smpP = decodeWord16 <$> A.take 2 + +instance Encoding Word32 where + smpEncode = encodeWord32 + smpP = decodeWord32 <$> A.take 4 + +instance Encoding Int64 where + smpEncode i = w32 (i `shiftR` 32) <> w32 i + smpP = do + l <- w32P + r <- w32P + pure $ (l `shiftL` 32) .|. r + +w32 :: Int64 -> ByteString +w32 = smpEncode @Word32 . fromIntegral + +w32P :: Parser Int64 +w32P = fromIntegral <$> smpP @Word32 + +-- ByteStrings are assumed no longer than 255 bytes +instance Encoding ByteString where + smpEncode s = B.cons (w2c len) s where len = fromIntegral $ B.length s + smpP = A.take . fromIntegral . c2w =<< A.anyChar + +newtype Tail = Tail {unTail :: ByteString} + +instance Encoding Tail where + smpEncode = unTail + smpP = Tail <$> A.takeByteString + +instance Encoding SystemTime where + smpEncode = smpEncode . systemSeconds + smpP = MkSystemTime <$> smpP <*> pure 0 + +instance (Encoding a, Encoding b) => Encoding (a, b) where + smpEncode (a, b) = smpEncode a <> smpEncode b + smpP = (,) <$> smpP <*> smpP + +instance (Encoding a, Encoding b, Encoding c) => Encoding (a, b, c) where + smpEncode (a, b, c) = smpEncode a <> smpEncode b <> smpEncode c + smpP = (,,) <$> smpP <*> smpP <*> smpP + +instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c, d) where + smpEncode (a, b, c, d) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d + smpP = (,,,) <$> smpP <*> smpP <*> smpP <*> smpP + +instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where + smpEncode (a, b, c, d, e) = smpEncode a <> smpEncode b <> smpEncode c <> smpEncode d <> smpEncode e + smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP diff --git a/src/Simplex/Messaging/Parsers.hs b/src/Simplex/Messaging/Parsers.hs index fb2c88b52..d14419bf0 100644 --- a/src/Simplex/Messaging/Parsers.hs +++ b/src/Simplex/Messaging/Parsers.hs @@ -15,12 +15,10 @@ import Data.Char (isAlphaNum) import Data.Time.Clock (UTCTime) import Data.Time.ISO8601 (parseISO8601) import Data.Typeable (Typeable) -import Data.Word (Word16, Word32) import Database.SQLite.Simple (ResultError (..), SQLData (..)) import Database.SQLite.Simple.FromField (FieldParser, returnError) import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Ok (Ok (Ok)) -import Network.Transport.Internal (decodeWord16, decodeWord32) import Simplex.Messaging.Util ((<$?>)) import Text.Read (readMaybe) @@ -50,12 +48,6 @@ rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_') tsISO8601P :: Parser UTCTime tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill wordEnd -word16P :: Parser Word16 -word16P = decodeWord16 <$> A.take 2 - -word32P :: Parser Word32 -word32P = decodeWord32 <$> A.take 4 - parse :: Parser a -> e -> (ByteString -> Either e a) parse parser err = first (const err) . parseAll parser diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index fcfe4e349..862933489 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -1,16 +1,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} @@ -28,23 +30,22 @@ -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md module Simplex.Messaging.Protocol ( -- * SMP protocol parameters - clientVersion, + smpClientVersion, maxMessageLength, e2eEncMessageLength, -- * SMP protocol types + Protocol, Command (..), - CommandI (..), Party (..), - ClientParty (..), Cmd (..), - ClientCmd (..), + BrokerMsg (..), SParty (..), + PartyI (..), QueueIdsKeys (..), ErrorType (..), CommandError (..), Transmission, - BrokerTransmission, SignedTransmission, SentRawTransmission, SignedRawTransmission, @@ -65,58 +66,48 @@ module Simplex.Messaging.Protocol SndPublicVerifyKey, NtfPrivateSignKey, NtfPublicVerifyKey, - Encoded, MsgId, MsgBody, -- * Parse and serialize - serializeTransmission, - serializeErrorType, + encodeTransmission, transmissionP, - errorTypeP, - serializeEncMessage, - encMessageP, - serializeClientMessage, - clientMessageP, + encodeProtocol, -- * TCP transport functions tPut, tGet, - fromClient, - fromServer, + + -- * exports for tests + CommandTag (..), + BrokerMsgTag (..), ) where -import Control.Applicative ((<|>)) -import Control.Monad +import Control.Applicative (optional) import Control.Monad.Except import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.Bifunctor (first) -import Data.ByteString.Base64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Constraint (Dict (..)) -import Data.Functor (($>)) import Data.Kind import Data.Maybe (isNothing) import Data.String -import Data.Time.Clock -import Data.Time.ISO8601 +import Data.Time.Clock.System (SystemTime) import Data.Type.Equality import Data.Word (Word16) import GHC.Generics (Generic) -import GHC.TypeLits (ErrorMessage (..), TypeError) import Generic.Random (genericArbitraryU) -import Network.Transport.Internal (encodeWord16) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers import Simplex.Messaging.Transport (THandle (..), Transport, TransportError (..), tGetBlock, tPutBlock) -import Simplex.Messaging.Util +import Simplex.Messaging.Util ((<$?>)) +import Simplex.Messaging.Version import Test.QuickCheck (Arbitrary (..)) -clientVersion :: Word16 -clientVersion = 1 +smpClientVersion :: VersionRange +smpClientVersion = mkVersionRange 1 1 maxMessageLength :: Int maxMessageLength = 15968 @@ -124,19 +115,17 @@ maxMessageLength = 15968 e2eEncMessageLength :: Int e2eEncMessageLength = 15842 --- | SMP protocol participants. -data Party = Broker | Recipient | Sender | Notifier +-- | SMP protocol clients +data Party = Recipient | Sender | Notifier deriving (Show) --- | Singleton types for SMP protocol participants. +-- | Singleton types for SMP protocol clients data SParty :: Party -> Type where - SBroker :: SParty Broker SRecipient :: SParty Recipient SSender :: SParty Sender SNotifier :: SParty Notifier instance TestEquality SParty where - testEquality SBroker SBroker = Just Refl testEquality SRecipient SRecipient = Just Refl testEquality SSender SSender = Just Refl testEquality SNotifier SNotifier = Just Refl @@ -146,35 +135,20 @@ deriving instance Show (SParty p) class PartyI (p :: Party) where sParty :: SParty p -instance PartyI Broker where sParty = SBroker - instance PartyI Recipient where sParty = SRecipient instance PartyI Sender where sParty = SSender instance PartyI Notifier where sParty = SNotifier -data ClientParty = forall p. IsClient p => CP (SParty p) - -deriving instance Show ClientParty - --- | Type for command or response of any participant. +-- | Type for client command of any participant. data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p) deriving instance Show Cmd --- | Type for command or response of any participant. -data ClientCmd = forall p. (PartyI p, IsClient p) => ClientCmd (SParty p) (Command p) - -class CommandI c where - serializeCommand :: c -> ByteString - commandP :: Parser c - -- | Parsed SMP transmission without signature, size and session ID. type Transmission c = (CorrId, QueueId, c) -type BrokerTransmission = Transmission (Command Broker) - -- | signed parsed transmission, with original raw bytes and parsing error. type SignedTransmission c = (Maybe C.ASignature, Signed, Transmission (Either ErrorType c)) @@ -206,10 +180,10 @@ type SenderId = QueueId type NotifierId = QueueId -- | SMP queue ID on the server. -type QueueId = Encoded +type QueueId = ByteString --- | Parameterized type for SMP protocol commands from all participants. -data Command (a :: Party) where +-- | Parameterized type for SMP protocol commands from all clients. +data Command (p :: Party) where -- SMP recipient commands NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient SUB :: Command Recipient @@ -223,33 +197,120 @@ data Command (a :: Party) where PING :: Command Sender -- SMP notification subscriber commands NSUB :: Command Notifier - -- SMP broker commands (responses, messages, notifications) - IDS :: QueueIdsKeys -> Command Broker - MSG :: MsgId -> UTCTime -> MsgBody -> Command Broker - NID :: NotifierId -> Command Broker - NMSG :: Command Broker - END :: Command Broker - OK :: Command Broker - ERR :: ErrorType -> Command Broker - PONG :: Command Broker -deriving instance Show (Command a) +deriving instance Show (Command p) -deriving instance Eq (Command a) +deriving instance Eq (Command p) -type family IsClient p :: Constraint where - IsClient Recipient = () - IsClient Sender = () - IsClient Notifier = () - IsClient p = - (Int ~ Bool, TypeError (Text "Party " :<>: ShowType p :<>: Text " is not a Client")) +data BrokerMsg where + -- SMP broker messages (responses, client messages, notifications) + IDS :: QueueIdsKeys -> BrokerMsg + MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg + NID :: NotifierId -> BrokerMsg + NMSG :: BrokerMsg + END :: BrokerMsg + OK :: BrokerMsg + ERR :: ErrorType -> BrokerMsg + PONG :: BrokerMsg + deriving (Eq, Show) -isClient :: SParty p -> Maybe (Dict (IsClient p)) -isClient = \case - SRecipient -> Just Dict - SSender -> Just Dict - SNotifier -> Just Dict - _ -> Nothing +-- * SMP command tags + +data CommandTag (p :: Party) where + NEW_ :: CommandTag Recipient + SUB_ :: CommandTag Recipient + KEY_ :: CommandTag Recipient + NKEY_ :: CommandTag Recipient + ACK_ :: CommandTag Recipient + OFF_ :: CommandTag Recipient + DEL_ :: CommandTag Recipient + SEND_ :: CommandTag Sender + PING_ :: CommandTag Sender + NSUB_ :: CommandTag Notifier + +data CmdTag = forall p. PartyI p => CT (SParty p) (CommandTag p) + +deriving instance Show (CommandTag p) + +deriving instance Show CmdTag + +data BrokerMsgTag + = IDS_ + | MSG_ + | NID_ + | NMSG_ + | END_ + | OK_ + | ERR_ + | PONG_ + deriving (Show) + +class ProtocolMsgTag t where + decodeTag :: ByteString -> Maybe t + +messageTagP :: ProtocolMsgTag t => Parser t +messageTagP = + maybe (fail "bad command") pure . decodeTag + =<< (A.takeTill (== ' ') <* optional A.space) + +instance PartyI p => Encoding (CommandTag p) where + smpEncode = \case + NEW_ -> "NEW" + SUB_ -> "SUB" + KEY_ -> "KEY" + NKEY_ -> "NKEY" + ACK_ -> "ACK" + OFF_ -> "OFF" + DEL_ -> "DEL" + SEND_ -> "SEND" + PING_ -> "PING" + NSUB_ -> "NSUB" + smpP = messageTagP + +instance ProtocolMsgTag CmdTag where + decodeTag = \case + "NEW" -> Just $ CT SRecipient NEW_ + "SUB" -> Just $ CT SRecipient SUB_ + "KEY" -> Just $ CT SRecipient KEY_ + "NKEY" -> Just $ CT SRecipient NKEY_ + "ACK" -> Just $ CT SRecipient ACK_ + "OFF" -> Just $ CT SRecipient OFF_ + "DEL" -> Just $ CT SRecipient DEL_ + "SEND" -> Just $ CT SSender SEND_ + "PING" -> Just $ CT SSender PING_ + "NSUB" -> Just $ CT SNotifier NSUB_ + _ -> Nothing + +instance Encoding CmdTag where + smpEncode (CT _ t) = smpEncode t + smpP = messageTagP + +instance PartyI p => ProtocolMsgTag (CommandTag p) where + decodeTag s = decodeTag s >>= (\(CT _ t) -> checkParty' t) + +instance Encoding BrokerMsgTag where + smpEncode = \case + IDS_ -> "IDS" + MSG_ -> "MSG" + NID_ -> "NID" + NMSG_ -> "NMSG" + END_ -> "END" + OK_ -> "OK" + ERR_ -> "ERR" + PONG_ -> "PONG" + smpP = messageTagP + +instance ProtocolMsgTag BrokerMsgTag where + decodeTag = \case + "IDS" -> Just IDS_ + "MSG" -> Just MSG_ + "NID" -> Just NID_ + "NMSG" -> Just NMSG_ + "END" -> Just END_ + "OK" -> Just OK_ + "ERR" -> Just ERR_ + "PONG" -> Just PONG_ + _ -> Nothing -- | SMP message body format data EncMessage = EncMessage @@ -263,22 +324,18 @@ data PubHeader = PubHeader phE2ePubDhKey :: C.PublicKeyX25519 } -serializePubHeader :: PubHeader -> ByteString -serializePubHeader (PubHeader v k) = encodeWord16 v <> C.encodeLenKey' k +instance Encoding PubHeader where + smpEncode (PubHeader v k) = smpEncode (v, k) + smpP = PubHeader <$> smpP <*> smpP -pubHeaderP :: Parser PubHeader -pubHeaderP = PubHeader <$> word16P <*> C.binaryLenKeyP - -serializeEncMessage :: EncMessage -> ByteString -serializeEncMessage EncMessage {emHeader, emNonce, emBody} = - serializePubHeader emHeader <> C.unCbNonce emNonce <> emBody - -encMessageP :: Parser EncMessage -encMessageP = do - emHeader <- pubHeaderP - emNonce <- C.cbNonceP - emBody <- A.takeByteString - pure EncMessage {emHeader, emNonce, emBody} +instance Encoding EncMessage where + smpEncode EncMessage {emHeader, emNonce, emBody} = + smpEncode emHeader <> smpEncode emNonce <> emBody + smpP = do + emHeader <- smpP + emNonce <- smpP + emBody <- A.takeByteString + pure EncMessage {emHeader, emNonce, emBody} data ClientMessage = ClientMessage PrivHeader ByteString @@ -286,26 +343,19 @@ data PrivHeader = PHConfirmation C.APublicVerifyKey | PHEmpty -serializePrivHeader :: PrivHeader -> ByteString -serializePrivHeader = \case - PHConfirmation k -> "K" <> C.encodeLenKey k - PHEmpty -> " " +instance Encoding PrivHeader where + smpEncode = \case + PHConfirmation k -> "K" <> smpEncode k + PHEmpty -> " " + smpP = + A.anyChar >>= \case + 'K' -> PHConfirmation <$> smpP + ' ' -> pure PHEmpty + _ -> fail "invalid PrivHeader" -privHeaderP :: Parser PrivHeader -privHeaderP = - A.anyChar >>= \case - 'K' -> PHConfirmation <$> C.binaryLenKeyP - ' ' -> pure PHEmpty - _ -> fail "invalid PrivHeader" - -serializeClientMessage :: ClientMessage -> ByteString -serializeClientMessage (ClientMessage h msg) = serializePrivHeader h <> msg - -clientMessageP :: Parser ClientMessage -clientMessageP = ClientMessage <$> privHeaderP <*> A.takeByteString - --- | Base-64 encoded string. -type Encoded = ByteString +instance Encoding ClientMessage where + smpEncode (ClientMessage h msg) = smpEncode h <> msg + smpP = ClientMessage <$> smpP <*> A.takeByteString -- | Transmission correlation ID. newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show) @@ -350,7 +400,7 @@ type NtfPrivateSignKey = C.APrivateSignKey type NtfPublicVerifyKey = C.APublicVerifyKey -- | SMP message server ID. -type MsgId = Encoded +type MsgId = ByteString -- | SMP message body. type MsgBody = ByteString @@ -379,8 +429,8 @@ data ErrorType -- | SMP command error type. data CommandError - = -- | server response sent from client or vice versa - PROHIBITED + = -- | unknown command + UNKNOWN | -- | error parsing command SYNTAX | -- | transmission has no required credentials (signature or queue ID) @@ -398,141 +448,209 @@ instance Arbitrary CommandError where arbitrary = genericArbitraryU -- | SMP transmission parser. transmissionP :: Parser RawTransmission transmissionP = do - signature <- segment + signature <- smpP signed <- A.takeByteString either fail pure $ parseAll (trn signature signed) signed where - segment = A.takeTill (== ' ') <* A.space trn signature signed = do - sessId <- segment - corrId <- segment - queueId <- segment + sessId <- smpP + corrId <- smpP + queueId <- smpP command <- A.takeByteString pure RawTransmission {signature, signed, sessId, corrId, queueId, command} -instance CommandI Cmd where - serializeCommand (Cmd _ cmd) = serializeCommand cmd - commandP = - "NEW " *> newCmd - <|> "IDS " *> idsResp - <|> "SUB" $> Cmd SRecipient SUB - <|> "KEY " *> keyCmd - <|> "NKEY " *> nKeyCmd - <|> "NID " *> nIdsResp - <|> "ACK" $> Cmd SRecipient ACK - <|> "OFF" $> Cmd SRecipient OFF - <|> "DEL" $> Cmd SRecipient DEL - <|> "SEND " *> sendCmd - <|> "PING" $> Cmd SSender PING - <|> "NSUB" $> Cmd SNotifier NSUB - <|> "MSG " *> message - <|> "NMSG" $> Cmd SBroker NMSG - <|> "END" $> Cmd SBroker END - <|> "OK" $> Cmd SBroker OK - <|> "ERR " *> serverError - <|> "PONG" $> Cmd SBroker PONG +class Protocol msg where + type Tag msg + encodeProtocol :: msg -> ByteString + protocolP :: Tag msg -> Parser msg + checkCredentials :: SignedRawTransmission -> msg -> Either ErrorType msg + +instance PartyI p => Protocol (Command p) where + type Tag (Command p) = CommandTag p + encodeProtocol = \case + NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey) + SUB -> e SUB_ + KEY k -> e (KEY_, ' ', k) + NKEY k -> e (NKEY_, ' ', k) + ACK -> e ACK_ + OFF -> e OFF_ + DEL -> e DEL_ + SEND msg -> e (SEND_, ' ', Tail msg) + PING -> e PING_ + NSUB -> e NSUB_ where - newCmd = Cmd SRecipient <$> (NEW <$> C.strPubKeyP <* A.space <*> C.strPubKeyP) - idsResp = Cmd SBroker . IDS <$> qik - qik = QIK <$> base64P <* A.space <*> base64P <* A.space <*> C.strPubKeyP - nIdsResp = Cmd SBroker . NID <$> base64P - keyCmd = Cmd SRecipient . KEY <$> C.strPubKeyP - nKeyCmd = Cmd SRecipient . NKEY <$> C.strPubKeyP - sendCmd = Cmd SSender . SEND <$> A.takeByteString - message = do - msgId <- base64P <* A.space - ts <- tsISO8601P <* A.space - Cmd SBroker . MSG msgId ts <$> A.takeByteString - serverError = Cmd SBroker . ERR <$> errorTypeP + e :: Encoding a => a -> ByteString + e = smpEncode -instance CommandI ClientCmd where - serializeCommand (ClientCmd _ cmd) = serializeCommand cmd - commandP = clientCmd <$?> commandP + protocolP tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP (CT (sParty @p) tag) + + checkCredentials (sig, _, queueId, _) cmd = case cmd of + -- NEW must have signature but NOT queue ID + NEW {} + | isNothing sig -> Left $ CMD NO_AUTH + | not (B.null queueId) -> Left $ CMD HAS_AUTH + | otherwise -> Right cmd + -- SEND must have queue ID, signature is not always required + SEND _ + | B.null queueId -> Left $ CMD NO_QUEUE + | otherwise -> Right cmd + -- PING must not have queue ID or signature + PING + | isNothing sig && B.null queueId -> Right cmd + | otherwise -> Left $ CMD HAS_AUTH + -- other client commands must have both signature and queue ID + _ + | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH + | otherwise -> Right cmd + +instance Protocol Cmd where + type Tag Cmd = CmdTag + encodeProtocol (Cmd _ c) = encodeProtocol c + + protocolP = \case + CT SRecipient tag -> + Cmd SRecipient <$> case tag of + NEW_ -> NEW <$> _smpP <*> smpP + SUB_ -> pure SUB + KEY_ -> KEY <$> _smpP + NKEY_ -> NKEY <$> _smpP + ACK_ -> pure ACK + OFF_ -> pure OFF + DEL_ -> pure DEL + CT SSender tag -> + Cmd SSender <$> case tag of + SEND_ -> SEND . unTail <$> _smpP + PING_ -> pure PING + CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB + + checkCredentials t (Cmd p c) = Cmd p <$> checkCredentials t c + +instance Protocol BrokerMsg where + type Tag BrokerMsg = BrokerMsgTag + encodeProtocol = \case + IDS (QIK rcvId sndId srvDh) -> e (IDS_, ' ', rcvId, sndId, srvDh) + MSG msgId ts msgBody -> e (MSG_, ' ', msgId, ts, Tail msgBody) + NID nId -> e (NID_, ' ', nId) + NMSG -> e NMSG_ + END -> e END_ + OK -> e OK_ + ERR err -> e (ERR_, ' ', err) + PONG -> e PONG_ where - clientCmd :: Cmd -> Either String ClientCmd - clientCmd (Cmd p cmd) = case isClient p of - Just Dict -> Right (ClientCmd p cmd) - _ -> Left "not a client command" + e :: Encoding a => a -> ByteString + e = smpEncode --- | Parse SMP command. -parseCommand :: ByteString -> Either ErrorType Cmd -parseCommand = parse commandP $ CMD SYNTAX + protocolP = \case + MSG_ -> MSG <$> _smpP <*> smpP <*> (unTail <$> smpP) + IDS_ -> IDS <$> (QIK <$> _smpP <*> smpP <*> smpP) + NID_ -> NID <$> _smpP + NMSG_ -> pure NMSG + END_ -> pure END + OK_ -> pure OK + ERR_ -> ERR <$> _smpP + PONG_ -> pure PONG -instance PartyI p => CommandI (Command p) where - commandP = command' <$?> commandP - where - command' :: Cmd -> Either String (Command p) - command' (Cmd p cmd) = case testEquality p $ sParty @p of - Just Refl -> Right cmd - _ -> Left "bad command party" - serializeCommand = \case - NEW rKey dhKey -> B.unwords ["NEW", C.serializePubKey rKey, C.serializePubKey' dhKey] - KEY sKey -> "KEY " <> C.serializePubKey sKey - NKEY nKey -> "NKEY " <> C.serializePubKey nKey - SUB -> "SUB" - ACK -> "ACK" - OFF -> "OFF" - DEL -> "DEL" - SEND msgBody -> "SEND " <> msgBody - PING -> "PING" - NSUB -> "NSUB" - MSG msgId ts msgBody -> - B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts, msgBody] - IDS (QIK rcvId sndId srvDh) -> - B.unwords ["IDS", encode rcvId, encode sndId, C.serializePubKey' srvDh] - NID nId -> "NID " <> encode nId - ERR err -> "ERR " <> serializeErrorType err - NMSG -> "NMSG" - END -> "END" - OK -> "OK" - PONG -> "PONG" + checkCredentials (_, _, queueId, _) cmd = case cmd of + -- IDS response must not have queue ID + IDS _ -> Right cmd + -- ERR response does not always have queue ID + ERR _ -> Right cmd + -- PONG response must not have queue ID + PONG + | B.null queueId -> Right cmd + | otherwise -> Left $ CMD HAS_AUTH + -- other broker responses must have queue ID + _ + | B.null queueId -> Left $ CMD NO_QUEUE + | otherwise -> Right cmd --- | SMP error parser. -errorTypeP :: Parser ErrorType -errorTypeP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1 +_smpP :: Encoding a => Parser a +_smpP = A.space *> smpP --- | Serialize SMP error. -serializeErrorType :: ErrorType -> ByteString -serializeErrorType = bshow +-- | Parse SMP protocol commands and broker messages +parseProtocol :: (Protocol msg, ProtocolMsgTag (Tag msg)) => ByteString -> Either ErrorType msg +parseProtocol s = + let (tag, params) = B.break (== ' ') s + in case decodeTag tag of + Just cmd -> parse (protocolP cmd) (CMD SYNTAX) params + Nothing -> Left $ CMD UNKNOWN + +checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p) +checkParty c = case testEquality (sParty @p) (sParty @p') of + Just Refl -> Right c + Nothing -> Left "bad command party" + +checkParty' :: forall t p p'. (PartyI p, PartyI p') => t p' -> Maybe (t p) +checkParty' c = case testEquality (sParty @p) (sParty @p') of + Just Refl -> Just c + _ -> Nothing + +instance Encoding ErrorType where + smpEncode = \case + BLOCK -> "BLOCK" + SESSION -> "SESSION" + CMD err -> "CMD " <> smpEncode err + AUTH -> "AUTH" + QUOTA -> "QUOTA" + NO_MSG -> "NO_MSG" + LARGE_MSG -> "LARGE_MSG" + INTERNAL -> "INTERNAL" + DUPLICATE_ -> "DUPLICATE_" + + smpP = + A.takeTill (== ' ') >>= \case + "BLOCK" -> pure BLOCK + "SESSION" -> pure SESSION + "CMD" -> CMD <$> _smpP + "AUTH" -> pure AUTH + "QUOTA" -> pure QUOTA + "NO_MSG" -> pure NO_MSG + "LARGE_MSG" -> pure LARGE_MSG + "INTERNAL" -> pure INTERNAL + "DUPLICATE_" -> pure DUPLICATE_ + _ -> fail "bad error type" + +instance Encoding CommandError where + smpEncode e = case e of + UNKNOWN -> "UNKNOWN" + SYNTAX -> "SYNTAX" + NO_AUTH -> "NO_AUTH" + HAS_AUTH -> "HAS_AUTH" + NO_QUEUE -> "NO_QUEUE" + smpP = + A.takeTill (== ' ') >>= \case + "UNKNOWN" -> pure UNKNOWN + "SYNTAX" -> pure SYNTAX + "NO_AUTH" -> pure NO_AUTH + "HAS_AUTH" -> pure HAS_AUTH + "NO_QUEUE" -> pure NO_QUEUE + _ -> fail "bad command error type" -- | Send signed SMP transmission to TCP transport. tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ()) -tPut th (sig, t) = tPutBlock th $ C.serializeSignature sig <> " " <> t +tPut th (sig, t) = tPutBlock th $ smpEncode (C.signatureBytes sig) <> t -serializeTransmission :: CommandI c => ByteString -> Transmission c -> ByteString -serializeTransmission sessionId (CorrId corrId, queueId, command) = - B.unwords [sessionId, corrId, encode queueId, serializeCommand command] - --- | Validate that it is an SMP client command, used with 'tGet' by 'Simplex.Messaging.Server'. -fromClient :: Cmd -> Either ErrorType ClientCmd -fromClient (Cmd p cmd) = case isClient p of - Just Dict -> Right $ ClientCmd p cmd - Nothing -> Left $ CMD PROHIBITED - --- | Validate that it is an SMP server command, used with 'tGet' by 'Simplex.Messaging.Client'. -fromServer :: Cmd -> Either ErrorType (Command Broker) -fromServer = \case - Cmd SBroker cmd -> Right cmd - _ -> Left $ CMD PROHIBITED +encodeTransmission :: Protocol c => ByteString -> Transmission c -> ByteString +encodeTransmission sessionId (CorrId corrId, queueId, command) = + smpEncode (sessionId, corrId, queueId) <> encodeProtocol command -- | Receive and parse transmission from the TCP transport (ignoring any trailing padding). tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission) -tGetParse th = (parseTransmission =<<) <$> tGetBlock th - where - parseTransmission = first (const TEBadBlock) . A.parseOnly transmissionP +tGetParse th = (parse transmissionP TEBadBlock =<<) <$> tGetBlock th --- | Receive client and server transmissions. --- --- The first argument is used to limit allowed senders. --- 'fromClient' or 'fromServer' should be used here. -tGet :: forall c m cmd. (Transport c, MonadIO m) => (Cmd -> Either ErrorType cmd) -> THandle c -> m (SignedTransmission cmd) -tGet fromParty th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate +-- | Receive client and server transmissions (determined by `cmd` type). +tGet :: + forall cmd c m. + (Protocol cmd, ProtocolMsgTag (Tag cmd), Transport c, MonadIO m) => + THandle c -> + m (SignedTransmission cmd) +tGet th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseValidate where decodeParseValidate :: Either TransportError RawTransmission -> m (SignedTransmission cmd) decodeParseValidate = \case Right RawTransmission {signature, signed, sessId, corrId, queueId, command} | sessId == sessionId -> - let decodedTransmission = liftM2 (,corrId,,command) (C.decodeSignature =<< decode signature) (decode queueId) + let decodedTransmission = (,corrId,queueId,command) <$> C.decodeSignature signature in either (const $ tError corrId) (tParseValidate signed) decodedTransmission | otherwise -> pure (Nothing, "", (CorrId corrId, "", Left SESSION)) Left _ -> tError "" @@ -542,37 +660,5 @@ tGet fromParty th@THandle {sessionId} = liftIO (tGetParse th) >>= decodeParseVal tParseValidate :: ByteString -> SignedRawTransmission -> m (SignedTransmission cmd) tParseValidate signed t@(sig, corrId, queueId, command) = do - let cmd = parseCommand command >>= tCredentials t >>= fromParty - return (sig, signed, (CorrId corrId, queueId, cmd)) - - tCredentials :: SignedRawTransmission -> Cmd -> Either ErrorType Cmd - tCredentials (sig, _, queueId, _) cmd = case cmd of - -- IDS response must not have queue ID - Cmd SBroker (IDS _) -> Right cmd - -- ERR response does not always have queue ID - Cmd SBroker (ERR _) -> Right cmd - -- PONG response must not have queue ID - Cmd SBroker PONG - | B.null queueId -> Right cmd - | otherwise -> Left $ CMD HAS_AUTH - -- other responses must have queue ID - Cmd SBroker _ - | B.null queueId -> Left $ CMD NO_QUEUE - | otherwise -> Right cmd - -- NEW must have signature but NOT queue ID - Cmd SRecipient NEW {} - | isNothing sig -> Left $ CMD NO_AUTH - | not (B.null queueId) -> Left $ CMD HAS_AUTH - | otherwise -> Right cmd - -- SEND must have queue ID, signature is not always required - Cmd SSender (SEND _) - | B.null queueId -> Left $ CMD NO_QUEUE - | otherwise -> Right cmd - -- PING must not have queue ID or signature - Cmd SSender PING - | isNothing sig && B.null queueId -> Right cmd - | otherwise -> Left $ CMD HAS_AUTH - -- other client commands must have both signature and queue ID - Cmd _ _ - | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH - | otherwise -> Right cmd + let cmd = parseProtocol command >>= checkCredentials t + pure (sig, signed, (CorrId corrId, queueId, cmd)) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 4f854a38e..3647fdaa6 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -36,7 +36,7 @@ import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import qualified Data.Map.Strict as M import Data.Maybe (isNothing) -import Data.Time.Clock +import Data.Time.Clock.System (getSystemTime) import Data.Type.Equality import Network.Socket (ServiceName) import qualified Simplex.Messaging.Crypto as C @@ -154,7 +154,7 @@ cancelSub = \case receive :: (Transport c, MonadUnliftIO m, MonadReader Env m) => THandle c -> Client -> m () receive th Client {rcvQ, sndQ} = forever $ do - (sig, signed, (corrId, queueId, cmdOrError)) <- tGet fromClient th + (sig, signed, (corrId, queueId, cmdOrError)) <- tGet th case cmdOrError of Left e -> write sndQ (corrId, queueId, ERR e) Right cmd -> do @@ -168,19 +168,19 @@ receive th Client {rcvQ, sndQ} = forever $ do send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m () send h Client {sndQ, sessionId} = forever $ do t <- atomically $ readTBQueue sndQ - liftIO $ tPut h (Nothing, serializeTransmission sessionId t) + liftIO $ tPut h (Nothing, encodeTransmission sessionId t) verifyTransmission :: - forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> ClientCmd -> m Bool + forall m. (MonadUnliftIO m, MonadReader Env m) => Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> m Bool verifyTransmission sig_ signed queueId cmd = do case cmd of - ClientCmd SRecipient (NEW k _) -> pure $ verifySignature k - ClientCmd SRecipient _ -> verifyCmd (CP SRecipient) $ verifySignature . recipientKey - ClientCmd SSender (SEND _) -> verifyCmd (CP SSender) $ verifyMaybe . senderKey - ClientCmd SSender PING -> pure True - ClientCmd SNotifier NSUB -> verifyCmd (CP SNotifier) $ verifyMaybe . fmap snd . notifier + Cmd SRecipient (NEW k _) -> pure $ verifySignature k + Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey + Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey + Cmd SSender PING -> pure True + Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier where - verifyCmd :: ClientParty -> (QueueRec -> Bool) -> m Bool + verifyCmd :: SParty p -> (QueueRec -> Bool) -> m Bool verifyCmd party f = do st <- asks queueStore q <- atomically $ getQueue st party queueId @@ -217,16 +217,16 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri >>= processCommand >>= atomically . writeTBQueue sndQ where - processCommand :: Transmission ClientCmd -> m BrokerTransmission + processCommand :: Transmission Cmd -> m (Transmission BrokerMsg) processCommand (corrId, queueId, cmd) = do st <- asks queueStore case cmd of - ClientCmd SSender command -> + Cmd SSender command -> case command of SEND msgBody -> sendMessage st msgBody PING -> pure (corrId, "", PONG) - ClientCmd SNotifier NSUB -> subscribeNotifications - ClientCmd SRecipient command -> + Cmd SNotifier NSUB -> subscribeNotifications + Cmd SRecipient command -> case command of NEW rKey dhKey -> createQueue st rKey dhKey SUB -> subscribeQueue queueId @@ -236,7 +236,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri OFF -> suspendQueue_ st DEL -> delQueueAndMsgs st where - createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m BrokerTransmission + createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m (Transmission BrokerMsg) createQueue st recipientKey dhKey = do (rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair' let rcvDhSecret = C.dh' dhKey privDhKey @@ -254,7 +254,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri (corrId,queueId,) <$> addQueueRetry 3 qik qRec where addQueueRetry :: - Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> ((RecipientId, SenderId) -> QueueRec) -> m (Command 'Broker) + Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> ((RecipientId, SenderId) -> QueueRec) -> m BrokerMsg addQueueRetry 0 _ _ = pure $ ERR INTERNAL addQueueRetry n qik qRec = do ids@(rId, _) <- getIds @@ -268,7 +268,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO () logCreateById s rId = - atomically (getQueue st (CP SRecipient) rId) >>= \case + atomically (getQueue st SRecipient rId) >>= \case Right q -> logCreateQueue s q _ -> pure () @@ -277,15 +277,15 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri n <- asks $ queueIdBytes . config liftM2 (,) (randomId n) (randomId n) - secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m BrokerTransmission + secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg) secureQueue_ st sKey = do withLog $ \s -> logSecureQueue s queueId sKey atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey - addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m BrokerTransmission + addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m (Transmission BrokerMsg) addQueueNotifier_ st nKey = (corrId,queueId,) <$> addNotifierRetry 3 where - addNotifierRetry :: Int -> m (Command 'Broker) + addNotifierRetry :: Int -> m BrokerMsg addNotifierRetry 0 = pure $ ERR INTERNAL addNotifierRetry n = do nId <- randomId =<< asks (queueIdBytes . config) @@ -296,12 +296,12 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri withLog $ \s -> logAddNotifier s queueId nId nKey pure $ NID nId - suspendQueue_ :: QueueStore -> m BrokerTransmission + suspendQueue_ :: QueueStore -> m (Transmission BrokerMsg) suspendQueue_ st = do withLog (`logDeleteQueue` queueId) okResp <$> atomically (suspendQueue st queueId) - subscribeQueue :: RecipientId -> m BrokerTransmission + subscribeQueue :: RecipientId -> m (Transmission BrokerMsg) subscribeQueue rId = atomically (getSubscription rId) >>= deliverMessage tryPeekMsg rId @@ -316,7 +316,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri writeTVar subscriptions $ M.insert rId s subs return s - subscribeNotifications :: m BrokerTransmission + subscribeNotifications :: m (Transmission BrokerMsg) subscribeNotifications = atomically $ do subs <- readTVar ntfSubscriptions when (isNothing $ M.lookup queueId subs) $ do @@ -324,7 +324,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri writeTVar ntfSubscriptions $ M.insert queueId () subs pure ok - acknowledgeMsg :: m BrokerTransmission + acknowledgeMsg :: m (Transmission BrokerMsg) acknowledgeMsg = atomically (withSub queueId $ \s -> const s <$$> tryTakeTMVar (delivered s)) >>= \case @@ -334,14 +334,14 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri withSub :: RecipientId -> (Sub -> STM a) -> STM (Maybe a) withSub rId f = readTVar subscriptions >>= mapM f . M.lookup rId - sendMessage :: QueueStore -> MsgBody -> m BrokerTransmission + sendMessage :: QueueStore -> MsgBody -> m (Transmission BrokerMsg) sendMessage st msgBody | B.length msgBody > maxMessageLength = pure $ err LARGE_MSG | otherwise = do - qr <- atomically $ getQueue st (CP SSender) queueId + qr <- atomically $ getQueue st SSender queueId either (return . err) storeMessage qr where - storeMessage :: QueueRec -> m BrokerTransmission + storeMessage :: QueueRec -> m (Transmission BrokerMsg) storeMessage qr = case status qr of QueueOff -> return $ err AUTH QueueActive -> @@ -360,7 +360,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri mkMessage :: m (Either C.CryptoError Message) mkMessage = do msgId <- randomId =<< asks (msgIdBytes . config) - ts <- liftIO getCurrentTime + ts <- liftIO getSystemTime let c = C.cbEncrypt (rcvDhSecret qr) (C.cbNonce msgId) msgBody (maxMessageLength + 2) pure $ Message msgId ts <$> c @@ -374,7 +374,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri unlessM (isFullTBQueue sndQ) $ writeTBQueue q (CorrId "", nId, NMSG) - deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m BrokerTransmission + deliverMessage :: (MsgQueue -> STM (Maybe Message)) -> RecipientId -> Sub -> m (Transmission BrokerMsg) deliverMessage tryPeek rId = \case Sub {subThread = NoSub} -> do ms <- asks msgStore @@ -406,10 +406,10 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri setDelivered :: STM (Maybe Bool) setDelivered = withSub rId $ \s -> tryPutTMVar (delivered s) () - msgCmd :: Message -> Command 'Broker + msgCmd :: Message -> BrokerMsg msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody - delQueueAndMsgs :: QueueStore -> m BrokerTransmission + delQueueAndMsgs :: QueueStore -> m (Transmission BrokerMsg) delQueueAndMsgs st = do withLog (`logDeleteQueue` queueId) ms <- asks msgStore @@ -418,13 +418,13 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri Left e -> pure $ err e Right _ -> delMsgQueue ms queueId $> ok - ok :: BrokerTransmission + ok :: Transmission BrokerMsg ok = (corrId, queueId, OK) - err :: ErrorType -> BrokerTransmission + err :: ErrorType -> Transmission BrokerMsg err e = (corrId, queueId, ERR e) - okResp :: Either ErrorType () -> BrokerTransmission + okResp :: Either ErrorType () -> Transmission BrokerMsg okResp = either err $ const ok withLog :: (MonadUnliftIO m, MonadReader Env m) => (StoreLog 'WriteMode -> IO a) -> m () @@ -432,7 +432,7 @@ withLog action = do env <- ask liftIO . mapM_ action $ storeLog (env :: Env) -randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m Encoded +randomId :: (MonadUnliftIO m, MonadReader Env m) => Int -> m ByteString randomId n = do gVar <- asks idsDrg atomically (randomBytes n gVar) diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 22b710282..82975756d 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -56,8 +56,8 @@ data Server = Server data Client = Client { subscriptions :: TVar (Map RecipientId Sub), ntfSubscriptions :: TVar (Map NotifierId ()), - rcvQ :: TBQueue (Transmission ClientCmd), - sndQ :: TBQueue BrokerTransmission, + rcvQ :: TBQueue (Transmission Cmd), + sndQ :: TBQueue (Transmission BrokerMsg), sessionId :: ByteString, connected :: TVar Bool } diff --git a/src/Simplex/Messaging/Server/MsgStore.hs b/src/Simplex/Messaging/Server/MsgStore.hs index 3d729af60..9da8492f7 100644 --- a/src/Simplex/Messaging/Server/MsgStore.hs +++ b/src/Simplex/Messaging/Server/MsgStore.hs @@ -2,13 +2,13 @@ module Simplex.Messaging.Server.MsgStore where -import Data.Time.Clock +import Data.Time.Clock.System (SystemTime) import Numeric.Natural -import Simplex.Messaging.Protocol (Encoded, MsgBody, RecipientId) +import Simplex.Messaging.Protocol (MsgBody, MsgId, RecipientId) data Message = Message - { msgId :: Encoded, - ts :: UTCTime, + { msgId :: MsgId, + ts :: SystemTime, msgBody :: MsgBody } diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index d95b0c430..ed859422a 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -20,7 +20,7 @@ data QueueStatus = QueueActive | QueueOff deriving (Eq, Show) class MonadQueueStore s m where addQueue :: s -> QueueRec -> m (Either ErrorType ()) - getQueue :: s -> ClientParty -> QueueId -> m (Either ErrorType QueueRec) + getQueue :: s -> SParty p -> QueueId -> m (Either ErrorType QueueRec) secureQueue :: s -> RecipientId -> SndPublicVerifyKey -> m (Either ErrorType QueueRec) addQueueNotifier :: s -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> m (Either ErrorType QueueRec) suspendQueue :: s -> RecipientId -> m (Either ErrorType ()) diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index d0d52b3fc..b3424f6e8 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -42,8 +42,8 @@ instance MonadQueueStore QueueStore STM where } return $ Right () - getQueue :: QueueStore -> ClientParty -> QueueId -> STM (Either ErrorType QueueRec) - getQueue st (CP party) qId = do + getQueue :: QueueStore -> SParty p -> QueueId -> STM (Either ErrorType QueueRec) + getQueue st party qId = do cs <- readTVar st pure $ case party of SRecipient -> getRcpQueue cs qId diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index bbcb72cc1..fc824c58d 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -27,6 +27,8 @@ module Simplex.Messaging.Transport ( -- * SMP transport parameters smpBlockSize, + supportedSMPVersions, + simplexMQVersion, -- * Transport connection class Transport (..), @@ -55,7 +57,6 @@ module Simplex.Messaging.Transport tGetBlock, serializeTransportError, transportErrorP, - currentSMPVersionStr, -- * Trim trailing CR trimCR, @@ -68,7 +69,6 @@ import Control.Monad.IO.Unlift import Control.Monad.Trans.Except (throwE) import qualified Crypto.Store.X509 as SX import Data.Attoparsec.ByteString.Char8 (Parser) -import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) import Data.Bitraversable (bimapM) import Data.ByteString.Base64 @@ -79,7 +79,7 @@ import Data.Default (def) import Data.Functor (($>)) import Data.Set (Set) import qualified Data.Set as S -import Data.String +import Data.Word (Word16) import qualified Data.X509 as X import qualified Data.X509.CertificateStore as XS import qualified Data.X509.Validation as XV @@ -91,8 +91,10 @@ import Network.Socket import qualified Network.TLS as T import qualified Network.TLS.Extra as TE import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Parsers (parseAll, parseRead1, parseString) +import Simplex.Messaging.Encoding +import Simplex.Messaging.Parsers (parse, parseRead1) import Simplex.Messaging.Util (bshow) +import Simplex.Messaging.Version import System.Exit (exitFailure) import System.IO.Error import Test.QuickCheck (Arbitrary (..)) @@ -101,9 +103,17 @@ import UnliftIO.Exception (Exception, IOException) import qualified UnliftIO.Exception as E import UnliftIO.STM +-- * Transport parameters + smpBlockSize :: Int smpBlockSize = 16384 +supportedSMPVersions :: VersionRange +supportedSMPVersions = mkVersionRange 1 1 + +simplexMQVersion :: String +simplexMQVersion = "0.5.1" + -- * Transport connection class class Transport c where @@ -379,43 +389,32 @@ trimCR s = if B.last s == '\r' then B.init s else s -- * SMP transport -data SMPVersion = SMPVersion Int Int Int - deriving (Eq, Ord) - -instance IsString SMPVersion where - fromString = parseString $ parseAll smpVersionP - -currentSMPVersion :: SMPVersion -currentSMPVersion = "0.5.1" - -currentSMPVersionStr :: ByteString -currentSMPVersionStr = serializeSMPVersion currentSMPVersion - -serializeSMPVersion :: SMPVersion -> ByteString -serializeSMPVersion (SMPVersion a b c) = B.intercalate "." [bshow a, bshow b, bshow c] - -smpVersionP :: Parser SMPVersion -smpVersionP = - let ver = A.decimal <* A.char '.' - in SMPVersion <$> ver <*> ver <*> A.decimal - -- | The handle for SMP encrypted transport connection over Transport . data THandle c = THandle { connection :: c, + sessionId :: ByteString, + -- | agreed SMP server protocol version + smpVersion :: Word16 + } + +data ServerHandshake = ServerHandshake + { smpVersionRange :: VersionRange, sessionId :: ByteString } -data Handshake = Handshake - { sessionId :: ByteString, - smpVersion :: SMPVersion +newtype ClientHandshake = ClientHandshake + { -- | agreed SMP server protocol version + smpVersion :: Word16 } -serializeHandshake :: Handshake -> ByteString -serializeHandshake Handshake {sessionId, smpVersion} = - sessionId <> " " <> serializeSMPVersion smpVersion <> " " +instance Encoding ClientHandshake where + smpEncode ClientHandshake {smpVersion} = smpEncode smpVersion + smpP = ClientHandshake <$> smpP -handshakeP :: Parser Handshake -handshakeP = Handshake <$> A.takeWhile (/= ' ') <* A.space <*> smpVersionP <* A.space +instance Encoding ServerHandshake where + smpEncode ServerHandshake {smpVersionRange, sessionId} = + smpEncode (smpVersionRange, sessionId) + smpP = ServerHandshake <$> smpP <*> smpP -- | Error of SMP encrypted transport over TCP. data TransportError @@ -473,12 +472,14 @@ tGetBlock THandle {connection = c} = -- | Server SMP transport handshake. -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a -serverHandshake :: Transport c => c -> ExceptT TransportError IO (THandle c) +serverHandshake :: forall c. Transport c => c -> ExceptT TransportError IO (THandle c) serverHandshake c = do let th@THandle {sessionId} = tHandle c - _ <- getPeerHello th - sendHelloToPeer th sessionId - pure th + sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = supportedSMPVersions} + ClientHandshake smpVersion <- getHandshake th + if smpVersion `isCompatible` supportedSMPVersions + then pure (th :: THandle c) {smpVersion} + else throwE $ TEHandshake VERSION -- | Client SMP transport handshake. -- @@ -486,23 +487,21 @@ serverHandshake c = do clientHandshake :: forall c. Transport c => c -> ExceptT TransportError IO (THandle c) clientHandshake c = do let th@THandle {sessionId} = tHandle c - sendHelloToPeer th "" - Handshake {sessionId = sessId} <- getPeerHello th + ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th if sessionId == sessId - then pure th + then case smpVersionRange `compatibleVersion` supportedSMPVersions of + Just smpVersion -> do + sendHandshake th $ ClientHandshake smpVersion + pure (th :: THandle c) {smpVersion} + Nothing -> throwE $ TEHandshake VERSION else throwE TEBadSession -sendHelloToPeer :: Transport c => THandle c -> ByteString -> ExceptT TransportError IO () -sendHelloToPeer th sessionId = - let handshake = Handshake {sessionId, smpVersion = currentSMPVersion} - in ExceptT . tPutBlock th $ serializeHandshake handshake +sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO () +sendHandshake th = ExceptT . tPutBlock th . smpEncode -getPeerHello :: Transport c => THandle c -> ExceptT TransportError IO Handshake -getPeerHello th = ExceptT $ (parseHandshake =<<) <$> tGetBlock th - where - parseHandshake :: ByteString -> Either TransportError Handshake - parseHandshake = first (const $ TEHandshake PARSE) . A.parseOnly handshakeP +getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportError IO smp +getHandshake th = ExceptT $ (parse smpP (TEHandshake PARSE) =<<) <$> tGetBlock th tHandle :: Transport c => c -> THandle c tHandle c = - THandle {connection = c, sessionId = encode $ tlsUnique c} + THandle {connection = c, sessionId = tlsUnique c, smpVersion = 0} diff --git a/src/Simplex/Messaging/Version.hs b/src/Simplex/Messaging/Version.hs new file mode 100644 index 000000000..00a303590 --- /dev/null +++ b/src/Simplex/Messaging/Version.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Simplex.Messaging.Version + ( VersionRange (minVersion, maxVersion), + pattern VersionRange, + mkVersionRange, + versionRange, + compatibleVersion, + isCompatible, + ) +where + +import Data.Word (Word16) +import Simplex.Messaging.Encoding + +pattern VersionRange :: Word16 -> Word16 -> VersionRange +pattern VersionRange v1 v2 <- VRange v1 v2 + +{-# COMPLETE VersionRange #-} + +data VersionRange = VRange + { minVersion :: Word16, + maxVersion :: Word16 + } + deriving (Eq, Show) + +-- | construct valid version range, to be used in constants +mkVersionRange :: Word16 -> Word16 -> VersionRange +mkVersionRange v1 v2 + | v1 <= v2 = VRange v1 v2 + | otherwise = error "invalid version range" + +versionRange :: Word16 -> Word16 -> Maybe VersionRange +versionRange v1 v2 + | v1 <= v2 = Just $ VRange v1 v2 + | otherwise = Nothing + +instance Encoding VersionRange where + smpEncode (VRange v1 v2) = smpEncode (v1, v2) + smpP = + maybe (fail "invalid version range") pure + =<< versionRange <$> smpP <*> smpP + +compatibleVersion :: VersionRange -> VersionRange -> Maybe Word16 +compatibleVersion (VersionRange min1 max1) (VersionRange min2 max2) + | min1 <= max2 && min2 <= max1 = Just $ min max1 max2 + | otherwise = Nothing + +isCompatible :: Word16 -> VersionRange -> Bool +isCompatible v (VersionRange v1 v2) = v1 <= v && v <= v2 diff --git a/tests/AgentTests/DoubleRatchetTests.hs b/tests/AgentTests/DoubleRatchetTests.hs index 5f8c24433..be64dd0b6 100644 --- a/tests/AgentTests/DoubleRatchetTests.hs +++ b/tests/AgentTests/DoubleRatchetTests.hs @@ -17,6 +17,7 @@ import qualified Data.ByteString.Char8 as B import Simplex.Messaging.Crypto (Algorithm (..), AlgorithmI, CryptoError, DhAlgorithm) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet +import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (parseAll) import Test.Hspec @@ -45,7 +46,7 @@ testMessageHeader :: Expectation testMessageHeader = do (k, _) <- C.generateKeyPair' @X25519 let hdr = MsgHeader {msgVersion = 1, msgLatestVersion = 1, msgDHRs = k, msgPN = 0, msgNs = 0} - parseAll (msgHeaderP' @X25519) (serializeMsgHeader' hdr) `shouldBe` Right hdr + parseAll (smpP @(MsgHeader 'X25519)) (smpEncode hdr) `shouldBe` Right hdr pattern Decrypted :: ByteString -> Either CryptoError (Either CryptoError ByteString) pattern Decrypted msg <- Right (Right msg) diff --git a/tests/CoreTests/EncodingTests.hs b/tests/CoreTests/EncodingTests.hs new file mode 100644 index 000000000..52ed73807 --- /dev/null +++ b/tests/CoreTests/EncodingTests.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module CoreTests.EncodingTests where + +import Data.Bits (shiftR) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Internal (w2c) +import Data.Int (Int64) +import Data.Time.Clock.System (SystemTime (..), getSystemTime, utcToSystemTime) +import Data.Time.ISO8601 (parseISO8601) +import Simplex.Messaging.Encoding +import Simplex.Messaging.Parsers (parseAll) +import Test.Hspec +import Test.Hspec.QuickCheck (modifyMaxSuccess) +import Test.QuickCheck + +int64 :: Int64 +int64 = 1234567890123456789 + +s64 :: ByteString +s64 = B.pack $ map (w2c . fromIntegral . (int64 `shiftR`)) [56, 48, 40, 32, 24, 16, 8, 0] + +encodingTests :: Spec +encodingTests = modifyMaxSuccess (const 1000) $ do + describe "Encoding Int64" $ do + it "should encode and decode Int64 example" $ do + s64 `shouldBe` "\17\34\16\244\125\233\129\21" + smpEncode int64 `shouldBe` s64 + parseAll smpP s64 `shouldBe` Right int64 + it "parse(encode(Int64) should equal the same Int64" . property $ + \i -> parseAll smpP (smpEncode i) == Right (i :: Int64) + describe "Encoding SystemTime" $ do + it "should encode and decode SystemTime" $ do + t <- getSystemTime + testSystemTime t + Just t' <- pure $ utcToSystemTime <$> parseISO8601 "2022-01-01T10:24:05.000Z" + systemSeconds t' `shouldBe` 1641032645 + testSystemTime t' + it "parse(encode(SystemTime) should equal the same Int64" . property $ + \i -> parseAll smpP (smpEncode i) == Right (i :: Int64) + where + testSystemTime :: SystemTime -> Expectation + testSystemTime t = do + smpEncode t `shouldBe` smpEncode (systemSeconds t) + parseAll smpP (smpEncode t) `shouldBe` Right t {systemNanoseconds = 0} diff --git a/tests/ProtocolErrorTests.hs b/tests/CoreTests/ProtocolErrorTests.hs similarity index 73% rename from tests/ProtocolErrorTests.hs rename to tests/CoreTests/ProtocolErrorTests.hs index 0c9477211..2a673714a 100644 --- a/tests/ProtocolErrorTests.hs +++ b/tests/CoreTests/ProtocolErrorTests.hs @@ -1,8 +1,8 @@ -module ProtocolErrorTests where +module CoreTests.ProtocolErrorTests where -import Simplex.Messaging.Agent.Protocol (AgentErrorType, agentErrorTypeP, serializeAgentError) +import Simplex.Messaging.Agent.Protocol (AgentErrorType, agentErrorTypeP, serializeAgentError, serializeSmpErrorType, smpErrorTypeP) import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Protocol (ErrorType, errorTypeP, serializeErrorType) +import Simplex.Messaging.Protocol (ErrorType) import Test.Hspec import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck @@ -11,7 +11,7 @@ protocolErrorTests :: Spec protocolErrorTests = modifyMaxSuccess (const 1000) $ do describe "errors parsing / serializing" $ do it "should parse SMP protocol errors" . property $ \err -> - parseAll errorTypeP (serializeErrorType err) + parseAll smpErrorTypeP (serializeSmpErrorType err) == Right (err :: ErrorType) it "should parse SMP agent errors" . property $ \err -> parseAll agentErrorTypeP (serializeAgentError err) diff --git a/tests/CoreTests/VersionRangeTests.hs b/tests/CoreTests/VersionRangeTests.hs new file mode 100644 index 000000000..d2d67b802 --- /dev/null +++ b/tests/CoreTests/VersionRangeTests.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module CoreTests.VersionRangeTests where + +import GHC.Generics (Generic) +import Generic.Random (genericArbitraryU) +import Simplex.Messaging.Version +import Test.Hspec +import Test.Hspec.QuickCheck (modifyMaxSuccess) +import Test.QuickCheck + +data V = V1 | V2 | V3 | V4 | V5 deriving (Eq, Enum, Ord, Generic, Show) + +instance Arbitrary V where arbitrary = genericArbitraryU + +versionRangeTests :: Spec +versionRangeTests = modifyMaxSuccess (const 1000) $ do + describe "VersionRange construction" $ do + it "should fail on invalid range" $ do + vr 1 1 `shouldBe` vr 1 1 + vr 1 2 `shouldBe` vr 1 2 + (pure $! vr 2 1) `shouldThrow` anyErrorCall + describe "compatible version" $ do + it "should choose mutually compatible max version" $ do + (vr 1 1, vr 1 1) `compatible` Just 1 + (vr 1 1, vr 1 2) `compatible` Just 1 + (vr 1 2, vr 1 2) `compatible` Just 2 + (vr 1 2, vr 2 3) `compatible` Just 2 + (vr 1 3, vr 2 3) `compatible` Just 3 + (vr 1 3, vr 2 4) `compatible` Just 3 + (vr 1 2, vr 3 4) `compatible` Nothing + it "should check if version is compatible" $ do + isCompatible 1 (vr 1 2) `shouldBe` True + isCompatible 2 (vr 1 2) `shouldBe` True + isCompatible 2 (vr 1 1) `shouldBe` False + isCompatible 1 (vr 2 2) `shouldBe` False + it "compatibleVersion should pass isCompatible check" . property $ + \((min1, max1) :: (V, V)) ((min2, max2) :: (V, V)) -> + min1 > max1 || min2 > max2 -- one of ranges is invalid, skip testing it + || let w = fromIntegral . fromEnum + vr1 = mkVersionRange (w min1) (w max1) + vr2 = mkVersionRange (w min2) (w max2) + in case compatibleVersion vr1 vr2 of + Just v -> v `isCompatible` vr1 && v `isCompatible` vr2 + _ -> True + where + vr = mkVersionRange + (vr1, vr2) `compatible` v = do + compatibleVersion vr1 vr2 `shouldBe` v + compatibleVersion vr2 vr1 `shouldBe` v diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 97236922b..0967522be 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -191,7 +191,7 @@ testSMPAgentClientOn :: (Transport c, MonadUnliftIO m) => ServiceName -> (c -> m testSMPAgentClientOn port' client = do runTransportClient agentTestHost port' testKeyHash $ \h -> do line <- liftIO $ getLn h - if line == "Welcome to SMP agent v" <> currentSMPVersionStr + if line == "Welcome to SMP agent v" <> B.pack simplexMQVersion then client h else do error $ "wrong welcome message: " <> B.unpack line diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 06f1bd99d..c27f2a3a2 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,15 +9,13 @@ module SMPClient where -import Control.Monad (void) import Control.Monad.Except (runExceptT) import Control.Monad.IO.Unlift import Crypto.Random -import Data.ByteString.Base64 (encode) import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B import Network.Socket import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Server (runSMPServerBlocking) import Simplex.Messaging.Server.Env.STM @@ -111,8 +110,21 @@ runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients [] run 0 hs = test hs run n hs = testSMPClient $ \h -> run (n - 1) (h : hs) -smpServerTest :: forall c. Transport c => TProxy c -> SignedRawTransmission -> IO SignedRawTransmission -smpServerTest _ t = runSmpTest $ \(h :: THandle c) -> tPutRaw h t >> tGetRaw h +smpServerTest :: + forall c smp. + (Transport c, Encoding smp) => + TProxy c -> + (Maybe C.ASignature, ByteString, ByteString, smp) -> + IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) +smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h + where + tPut' h (sig, corrId, queueId, smp) = do + let t' = smpEncode (sessionId (h :: THandle c), corrId, queueId, smp) + Right () <- tPut h (sig, t') + pure () + tGet' h = do + (Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet h + pure (Nothing, corrId, qId, cmd) smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation smpTest _ test' = runSmpTest test' `shouldReturn` () @@ -137,13 +149,3 @@ smpTest4 _ test' = smpTestN 4 _test where _test [h1, h2, h3, h4] = test' h1 h2 h3 h4 _test _ = error "expected 4 handles" - -tPutRaw :: Transport c => THandle c -> SignedRawTransmission -> IO () -tPutRaw h@THandle {sessionId} (sig, corrId, queueId, command) = do - let t = B.unwords [sessionId, corrId, queueId, command] - void $ tPut h (sig, t) - -tGetRaw :: Transport c => THandle c -> IO SignedRawTransmission -tGetRaw h = do - (Nothing, _, (CorrId corrId, qId, Right cmd)) <- tGet fromServer h - pure (Nothing, corrId, encode qId, serializeCommand cmd) diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index acfc93ca9..d5923e2df 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module ServerTests where @@ -17,6 +18,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import SMPClient import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Transport import System.Directory (removeFile) @@ -25,9 +27,6 @@ import System.Timeout import Test.HUnit import Test.Hspec -rsaKeySize :: Int -rsaKeySize = 2048 `div` 8 - serverTests :: ATransport -> Spec serverTests t = do describe "SMP syntax" $ syntaxTests t @@ -42,25 +41,24 @@ serverTests t = do describe "Timing of AUTH error" $ testTiming t describe "Message notifications" $ testMessageNotifications t -pattern Resp :: CorrId -> QueueId -> Command 'Broker -> SignedTransmission (Command 'Broker) +pattern Resp :: CorrId -> QueueId -> BrokerMsg -> SignedTransmission BrokerMsg pattern Resp corrId queueId command <- (_, _, (corrId, queueId, Right command)) -pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> Command 'Broker +pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> BrokerMsg pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh) -sendRecv :: Transport c => THandle c -> (Maybe C.ASignature, ByteString, ByteString, ByteString) -> IO (SignedTransmission (Command 'Broker)) -sendRecv h (sgn, corrId, qId, cmd) = - tPutRaw h (sgn, corrId, encode qId, cmd) >> tGet fromServer h +sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg) +sendRecv h@THandle {sessionId} (sgn, corrId, qId, cmd) = do + let t = encodeTransmission sessionId (CorrId corrId, qId, cmd) + Right () <- tPut h (sgn, t) + tGet h -signSendRecv :: Transport c => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, ByteString) -> IO (SignedTransmission (Command 'Broker)) +signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission BrokerMsg) signSendRecv h@THandle {sessionId} pk (corrId, qId, cmd) = do - let t = B.intercalate " " [sessionId, corrId, encode qId, cmd] + let t = encodeTransmission sessionId (CorrId corrId, qId, cmd) Right sig <- runExceptT $ C.sign pk t - _ <- tPut h (Just sig, t) - tGet fromServer h - -cmdSEND :: ByteString -> ByteString -cmdSEND msg = serializeCommand (Cmd SSender . SEND $ msg) + Right () <- tPut h (Just sig, t) + tGet h (#==) :: (HasCallStack, Eq a, Show a) => (a, a) -> String -> Assertion (actual, expected) #== message = assertEqual message expected actual @@ -71,52 +69,51 @@ testCreateSecure (ATransport t) = smpTest t $ \h -> do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", B.unwords ["NEW", C.serializePubKey rPub, C.serializePubKey dhPub]) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub) let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce) (rId1, "") #== "creates queue" - Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND hello") + Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, SEND "hello") (ok1, OK) #== "accepts unsigned SEND" (sId1, sId) #== "same queue ID in response 1" - Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer h + Resp "" _ (MSG mId1 _ msg1) <- tGet h (dec mId1 msg1, Right "hello") #== "delivers message" - Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, "ACK") + Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK) (ok4, OK) #== "replies OK when message acknowledged if no more messages" - Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, "ACK") + Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, ACK) (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" (sPub, sKey) <- C.generateSignatureKeyPair C.SEd448 - Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND hello") + Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, SEND "hello") (err1, ERR AUTH) #== "rejects signed SEND" (sId2, sId) #== "same queue ID in response 2" - let keyCmd = "KEY " <> C.serializePubKey sPub - Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, keyCmd) + Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, KEY sPub) (err2, ERR AUTH) #== "rejects KEY with wrong signature" - Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, keyCmd) + Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, KEY sPub) (err3, ERR AUTH) #== "rejects KEY with sender's ID" - Resp "dabc" rId2 ok2 <- signSendRecv h rKey ("dabc", rId, keyCmd) + Resp "dabc" rId2 ok2 <- signSendRecv h rKey ("dabc", rId, KEY sPub) (ok2, OK) #== "secures queue" (rId2, rId) #== "same queue ID in response 3" - Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, keyCmd) + Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub) (err4, ERR AUTH) #== "rejects KEY if already secured" - Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, "SEND hello again") + Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, SEND "hello again") (ok3, OK) #== "accepts signed SEND" - Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer h + Resp "" _ (MSG mId2 _ msg2) <- tGet h (dec mId2 msg2, Right "hello again") #== "delivers message 2" - Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, "ACK") + Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK) (ok5, OK) #== "replies OK when message acknowledged 2" - Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, "SEND hello") + Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, SEND "hello") (err5, ERR AUTH) #== "rejects unsigned SEND" testCreateDelete :: ATransport -> Spec @@ -125,68 +122,68 @@ testCreateDelete (ATransport t) = smpTest2 t $ \rh sh -> do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519 (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", B.unwords ["NEW", C.serializePubKey rPub, C.serializePubKey dhPub]) + Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub) let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce) (rId1, "") #== "creates queue" (sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519 - Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializePubKey sPub) + Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub) (ok1, OK) #== "secures queue" - Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND hello") + Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, SEND "hello") (ok2, OK) #== "accepts signed SEND" - Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, "SEND hello 2") + Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, SEND "hello 2") (ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed" - Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer rh + Resp "" _ (MSG mId1 _ msg1) <- tGet rh (dec mId1 msg1, Right "hello") #== "delivers message" - Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, "OFF") + Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, OFF) (err1, ERR AUTH) #== "rejects OFF with wrong signature" - Resp "bcda" _ err2 <- signSendRecv rh rKey ("bcda", sId, "OFF") + Resp "bcda" _ err2 <- signSendRecv rh rKey ("bcda", sId, OFF) (err2, ERR AUTH) #== "rejects OFF with sender's ID" - Resp "cdab" rId2 ok3 <- signSendRecv rh rKey ("cdab", rId, "OFF") + Resp "cdab" rId2 ok3 <- signSendRecv rh rKey ("cdab", rId, OFF) (ok3, OK) #== "suspends queue" (rId2, rId) #== "same queue ID in response 2" - Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, "SEND hello") + Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, SEND "hello") (err3, ERR AUTH) #== "rejects signed SEND" - Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, "SEND hello") + Resp "abcd" _ err4 <- sendRecv sh ("", "abcd", sId, SEND "hello") (err4, ERR AUTH) #== "reject unsigned SEND too" - Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, "OFF") + Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, OFF) (ok4, OK) #== "accepts OFF when suspended" - Resp "cdab" _ (MSG mId2 _ msg2) <- signSendRecv rh rKey ("cdab", rId, "SUB") + Resp "cdab" _ (MSG mId2 _ msg2) <- signSendRecv rh rKey ("cdab", rId, SUB) (dec mId2 msg2, Right "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)" - Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, "DEL") + Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, DEL) (err5, ERR AUTH) #== "rejects DEL with wrong signature" - Resp "abcd" _ err6 <- signSendRecv rh rKey ("abcd", sId, "DEL") + Resp "abcd" _ err6 <- signSendRecv rh rKey ("abcd", sId, DEL) (err6, ERR AUTH) #== "rejects DEL with sender's ID" - Resp "bcda" rId3 ok6 <- signSendRecv rh rKey ("bcda", rId, "DEL") + Resp "bcda" rId3 ok6 <- signSendRecv rh rKey ("bcda", rId, DEL) (ok6, OK) #== "deletes queue" (rId3, rId) #== "same queue ID in response 3" - Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, "SEND hello") + Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, SEND "hello") (err7, ERR AUTH) #== "rejects signed SEND when deleted" - Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, "SEND hello") + Resp "dabc" _ err8 <- sendRecv sh ("", "dabc", sId, SEND "hello") (err8, ERR AUTH) #== "rejects unsigned SEND too when deleted" - Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, "ACK") + Resp "abcd" _ err11 <- signSendRecv rh rKey ("abcd", rId, ACK) (err11, ERR AUTH) #== "rejects ACK when conn deleted - the second message is deleted" - Resp "bcda" _ err9 <- signSendRecv rh rKey ("bcda", rId, "OFF") + Resp "bcda" _ err9 <- signSendRecv rh rKey ("bcda", rId, OFF) (err9, ERR AUTH) #== "rejects OFF when deleted" - Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, "SUB") + Resp "cdab" _ err10 <- signSendRecv rh rKey ("cdab", rId, SUB) (err10, ERR AUTH) #== "rejects SUB when deleted" stressTest :: ATransport -> Spec @@ -196,10 +193,10 @@ stressTest (ATransport t) = (rPub, rKey) <- C.generateSignatureKeyPair C.SEd25519 (dhPub, _ :: C.PrivateKeyX25519) <- C.generateKeyPair' rIds <- forM [1 .. 50 :: Int] . const $ do - Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", B.unwords ["NEW", C.serializePubKey rPub, C.serializePubKey dhPub]) + Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub) pure rId let subscribeQueues h = forM_ rIds $ \rId -> do - Resp "" rId' OK <- signSendRecv h rKey ("", rId, "SUB") + Resp "" rId' OK <- signSendRecv h rKey ("", rId, SUB) rId' `shouldBe` rId closeConnection $ connection h1 subscribeQueues h2 @@ -212,52 +209,52 @@ testDuplex (ATransport t) = smpTest2 t $ \alice bob -> do (arPub, arKey) <- C.generateSignatureKeyPair C.SEd448 (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", B.unwords ["NEW", C.serializePubKey arPub, C.serializePubKey aDhPub]) + Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub) let aDec nonce = C.cbDecrypt (C.dh' aSrvDh aDhPriv) (C.cbNonce nonce) -- aSnd ID is passed to Bob out-of-band (bsPub, bsKey) <- C.generateSignatureKeyPair C.SEd448 - Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, cmdSEND $ "key " <> C.serializePubKey bsPub) - -- "key ..." is ad-hoc, different from SMP protocol + Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, SEND $ "key " <> C.serializePubKey bsPub) + -- "key ..." is ad-hoc, not a part of SMP protocol - Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer alice - Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK") + Resp "" _ (MSG mId1 _ msg1) <- tGet alice + Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK) Right ["key", bobKey] <- pure $ B.words <$> aDec mId1 msg1 (bobKey, C.serializePubKey bsPub) #== "key received from Bob" - Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "KEY " <> bobKey) + Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub) (brPub, brKey) <- C.generateSignatureKeyPair C.SEd448 (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", B.unwords ["NEW", C.serializePubKey brPub, C.serializePubKey bDhPub]) + Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub) let bDec nonce = C.cbDecrypt (C.dh' bSrvDh bDhPriv) (C.cbNonce nonce) - Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, cmdSEND $ "reply_id " <> encode bSnd) - -- "reply_id ..." is ad-hoc, it is not a part of SMP protocol + Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, SEND $ "reply_id " <> encode bSnd) + -- "reply_id ..." is ad-hoc, not a part of SMP protocol - Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer alice - Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK") + Resp "" _ (MSG mId2 _ msg2) <- tGet alice + Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK) Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2 (bId, encode bSnd) #== "reply queue ID received from Bob" (asPub, asKey) <- C.generateSignatureKeyPair C.SEd448 - Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, cmdSEND $ "key " <> C.serializePubKey asPub) - -- "key ..." is ad-hoc, different from SMP protocol + Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, SEND $ "key " <> C.serializePubKey asPub) + -- "key ..." is ad-hoc, not a part of SMP protocol - Resp "" _ (MSG mId3 _ msg3) <- tGet fromServer bob - Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, "ACK") + Resp "" _ (MSG mId3 _ msg3) <- tGet bob + Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, ACK) Right ["key", aliceKey] <- pure $ B.words <$> bDec mId3 msg3 (aliceKey, C.serializePubKey asPub) #== "key received from Alice" - Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "KEY " <> aliceKey) + Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, KEY asPub) - Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND hi alice") + Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, SEND "hi alice") - Resp "" _ (MSG mId4 _ msg4) <- tGet fromServer alice - Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "ACK") + Resp "" _ (MSG mId4 _ msg4) <- tGet alice + Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, ACK) (aDec mId4 msg4, Right "hi alice") #== "message received from Bob" - Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, cmdSEND "how are you bob") + Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, SEND "how are you bob") - Resp "" _ (MSG mId5 _ msg5) <- tGet fromServer bob - Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "ACK") + Resp "" _ (MSG mId5 _ msg5) <- tGet bob + Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, ACK) (bDec mId5 msg5, Right "how are you bob") #== "message received from alice" testSwitchSub :: ATransport -> Spec @@ -266,37 +263,37 @@ testSwitchSub (ATransport t) = smpTest3 t $ \rh1 rh2 sh -> do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", B.unwords ["NEW", C.serializePubKey rPub, C.serializePubKey dhPub]) + Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub) let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce) - Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, "SEND test1") + Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, SEND "test1") (ok1, OK) #== "sent test message 1" - Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, cmdSEND "test2, no ACK") + Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, SEND "test2, no ACK") (ok2, OK) #== "sent test message 2" - Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer rh1 + Resp "" _ (MSG mId1 _ msg1) <- tGet rh1 (dec mId1 msg1, Right "test1") #== "test message 1 delivered to the 1st TCP connection" - Resp "abcd" _ (MSG mId2 _ msg2) <- signSendRecv rh1 rKey ("abcd", rId, "ACK") + Resp "abcd" _ (MSG mId2 _ msg2) <- signSendRecv rh1 rKey ("abcd", rId, ACK) (dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK" - Resp "bcda" _ (MSG mId2' _ msg2') <- signSendRecv rh2 rKey ("bcda", rId, "SUB") + Resp "bcda" _ (MSG mId2' _ msg2') <- signSendRecv rh2 rKey ("bcda", rId, SUB) (dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)" - Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, "ACK") + Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, ACK) - Resp "" _ end <- tGet fromServer rh1 + Resp "" _ end <- tGet rh1 (end, END) #== "unsubscribed the 1st TCP connection" - Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND test3") + Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, SEND "test3") - Resp "" _ (MSG mId3 _ msg3) <- tGet fromServer rh2 + Resp "" _ (MSG mId3 _ msg3) <- tGet rh2 (dec mId3 msg3, Right "test3") #== "delivered to the 2nd TCP connection" - Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, "ACK") + Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, ACK) (err, ERR NO_MSG) #== "rejects ACK from the 1st TCP connection" - Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, "ACK") + Resp "bcda" _ ok3 <- signSendRecv rh2 rKey ("bcda", rId, ACK) (ok3, OK) #== "accepts ACK from the 2nd TCP connection" - 1000 `timeout` tGet fromServer rh1 >>= \case + 1000 `timeout` tGet @BrokerMsg rh1 >>= \case Nothing -> return () Just _ -> error "nothing else is delivered to the 1st TCP connection" @@ -315,26 +312,26 @@ testWithStoreLog at@(ATransport t) = withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1 - Resp "abcd" _ (NID nId) <- signSendRecv h rKey1 ("abcd", rId1, "NKEY " <> C.serializePubKey nPub) + Resp "abcd" _ (NID nId) <- signSendRecv h rKey1 ("abcd", rId1, NKEY nPub) atomically $ do writeTVar recipientId1 rId1 writeTVar recipientKey1 $ Just rKey1 writeTVar dhShared1 $ Just dhShared writeTVar senderId1 sId1 writeTVar notifierId nId - Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, "NSUB") - Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND hello") - Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer h + Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB) + Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, SEND "hello") + Resp "" _ (MSG mId1 _ msg1) <- tGet h (C.cbDecrypt dhShared (C.cbNonce mId1) msg1, Right "hello") #== "delivered from queue 1" - Resp "" _ NMSG <- tGet fromServer h1 + Resp "" _ NMSG <- tGet h1 (sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2 atomically $ writeTVar senderId2 sId2 - Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, "SEND hello too") - Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer h + Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, SEND "hello too") + Resp "" _ (MSG mId2 _ msg2) <- tGet h (C.cbDecrypt dhShared2 (C.cbNonce mId2) msg2, Right "hello too") #== "delivered from queue 2" - Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, "DEL") + Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, DEL) pure () logSize `shouldReturn` 6 @@ -342,7 +339,7 @@ testWithStoreLog at@(ATransport t) = withSmpServerThreadOn at testPort . runTest t $ \h -> do sId1 <- readTVarIO senderId1 -- fails if store log is disabled - Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, "SEND hello") + Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, SEND "hello") pure () withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do @@ -352,14 +349,14 @@ testWithStoreLog at@(ATransport t) = Just dh1 <- readTVarIO dhShared1 sId1 <- readTVarIO senderId1 nId <- readTVarIO notifierId - Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, "NSUB") - Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND hello") - Resp "cdab" _ (MSG mId3 _ msg3) <- signSendRecv h rKey1 ("cdab", rId1, "SUB") + Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, NSUB) + Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, SEND "hello") + Resp "cdab" _ (MSG mId3 _ msg3) <- signSendRecv h rKey1 ("cdab", rId1, SUB) (C.cbDecrypt dh1 (C.cbNonce mId3) msg3, Right "hello") #== "delivered from restored queue" - Resp "" _ NMSG <- tGet fromServer h1 + Resp "" _ NMSG <- tGet h1 -- this queue is removed - not restored sId2 <- readTVarIO senderId2 - Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, "SEND hello too") + Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, SEND "hello too") pure () logSize `shouldReturn` 1 @@ -383,10 +380,9 @@ createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (Se createAndSecureQueue h sPub = do (rPub, rKey) <- C.generateSignatureKeyPair C.SEd448 (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", B.unwords ["NEW", C.serializePubKey rPub, C.serializePubKey dhPub]) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub) let dhShared = C.dh' srvDh dhPriv - let keyCmd = "KEY " <> C.serializePubKey sPub - Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, keyCmd) + Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, KEY sPub) (rId', rId) #== "same queue ID" pure (sId, rId, rKey, dhShared) @@ -408,22 +404,21 @@ testTiming (ATransport t) = testSameTiming rh sh (goodKeySize, badKeySize, n) = do (rPub, rKey) <- generateKeys goodKeySize (dhPub, dhPriv :: C.PrivateKeyX25519) <- C.generateKeyPair' - Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", B.unwords ["NEW", C.serializePubKey rPub, C.serializePubKey dhPub]) + Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub) let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce) - Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, "SUB") + Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) (_, badKey) <- generateKeys badKeySize -- runTimingTest rh badKey rId "SUB" (sPub, sKey) <- generateKeys goodKeySize - let keyCmd = "KEY " <> C.serializePubKey sPub - Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, keyCmd) + Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub) - Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, "SEND hello") - Resp "" _ (MSG mId _ msg) <- tGet fromServer rh + Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, SEND "hello") + Resp "" _ (MSG mId _ msg) <- tGet rh (dec mId msg, Right "hello") #== "delivered from queue" - runTimingTest sh badKey sId "SEND hello" + runTimingTest sh badKey sId $ SEND "hello" where generateKeys = \case 32 -> C.generateSignatureKeyPair C.SEd25519 @@ -453,65 +448,68 @@ testMessageNotifications (ATransport t) = smpTest4 t $ \rh sh nh1 nh2 -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub let dec nonce = C.cbDecrypt dhShared (C.cbNonce nonce) - Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, "NKEY " <> C.serializePubKey nPub) - Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, "NSUB") - Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, "SEND hello") - Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer rh + Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, NKEY nPub) + Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, NSUB) + Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, SEND "hello") + Resp "" _ (MSG mId1 _ msg1) <- tGet rh (dec mId1 msg1, Right "hello") #== "delivered from queue" - Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, "ACK") - Resp "" _ NMSG <- tGet fromServer nh1 - Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, "NSUB") - Resp "" _ END <- tGet fromServer nh1 - Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, "SEND hello again") - Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer rh + Resp "3a" _ OK <- signSendRecv rh rKey ("3a", rId, ACK) + Resp "" _ NMSG <- tGet nh1 + Resp "4" _ OK <- signSendRecv nh2 nKey ("4", nId, NSUB) + Resp "" _ END <- tGet nh1 + Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, SEND "hello again") + Resp "" _ (MSG mId2 _ msg2) <- tGet rh (dec mId2 msg2, Right "hello again") #== "delivered from queue again" - Resp "" _ NMSG <- tGet fromServer nh2 - 1000 `timeout` tGet fromServer nh1 >>= \case + Resp "" _ NMSG <- tGet nh2 + 1000 `timeout` tGet @BrokerMsg nh1 >>= \case Nothing -> return () Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection" -samplePubKey :: ByteString -samplePubKey = "ed25519:MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY=" +samplePubKey :: C.APublicVerifyKey +samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY=" -sampleDhPubKey :: ByteString -sampleDhPubKey = "x25519:MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ=" +sampleDhPubKey :: C.PublicKey 'C.X25519 +sampleDhPubKey = "MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ=" sampleSig :: Maybe C.ASignature sampleSig = "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA==" syntaxTests :: ATransport -> Spec syntaxTests (ATransport t) = do - it "unknown command" $ ("", "abcd", "1234", "HELLO") >#> ("", "abcd", "1234", "ERR CMD SYNTAX") + it "unknown command" $ ("", "abcd", "1234", ('H', 'E', 'L', 'L', 'O')) >#> ("", "abcd", "1234", ERR $ CMD UNKNOWN) describe "NEW" $ do - it "no parameters" $ (sampleSig, "bcda", "", "NEW") >#> ("", "bcda", "", "ERR CMD SYNTAX") - it "many parameters" $ (sampleSig, "cdab", "", B.unwords ["NEW 1", samplePubKey, sampleDhPubKey]) >#> ("", "cdab", "", "ERR CMD SYNTAX") - it "no signature" $ ("", "dabc", "", B.unwords ["NEW", samplePubKey, sampleDhPubKey]) >#> ("", "dabc", "", "ERR CMD NO_AUTH") - it "queue ID" $ (sampleSig, "abcd", "12345678", B.unwords ["NEW", samplePubKey, sampleDhPubKey]) >#> ("", "abcd", "12345678", "ERR CMD HAS_AUTH") + it "no parameters" $ (sampleSig, "bcda", "", NEW_) >#> ("", "bcda", "", ERR $ CMD SYNTAX) + it "many parameters" $ (sampleSig, "cdab", "", (NEW_, ' ', ('\x01', 'A'), samplePubKey, sampleDhPubKey)) >#> ("", "cdab", "", ERR $ CMD SYNTAX) + it "no signature" $ ("", "dabc", "", (NEW_, ' ', samplePubKey, sampleDhPubKey)) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) + it "queue ID" $ (sampleSig, "abcd", "12345678", (NEW_, ' ', samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", ERR $ CMD HAS_AUTH) describe "KEY" $ do - it "valid syntax" $ (sampleSig, "bcda", "12345678", "KEY " <> samplePubKey) >#> ("", "bcda", "12345678", "ERR AUTH") - it "no parameters" $ (sampleSig, "cdab", "12345678", "KEY") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX") - it "many parameters" $ (sampleSig, "dabc", "12345678", "KEY 1 " <> samplePubKey) >#> ("", "dabc", "12345678", "ERR CMD SYNTAX") - it "no signature" $ ("", "abcd", "12345678", "KEY " <> samplePubKey) >#> ("", "abcd", "12345678", "ERR CMD NO_AUTH") - it "no queue ID" $ (sampleSig, "bcda", "", "KEY " <> samplePubKey) >#> ("", "bcda", "", "ERR CMD NO_AUTH") - noParamsSyntaxTest "SUB" - noParamsSyntaxTest "ACK" - noParamsSyntaxTest "OFF" - noParamsSyntaxTest "DEL" + it "valid syntax" $ (sampleSig, "bcda", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "12345678", ERR AUTH) + it "no parameters" $ (sampleSig, "cdab", "12345678", KEY_) >#> ("", "cdab", "12345678", ERR $ CMD SYNTAX) + it "many parameters" $ (sampleSig, "dabc", "12345678", (KEY_, ' ', ('\x01', 'A'), samplePubKey)) >#> ("", "dabc", "12345678", ERR $ CMD SYNTAX) + it "no signature" $ ("", "abcd", "12345678", (KEY_, ' ', samplePubKey)) >#> ("", "abcd", "12345678", ERR $ CMD NO_AUTH) + it "no queue ID" $ (sampleSig, "bcda", "", (KEY_, ' ', samplePubKey)) >#> ("", "bcda", "", ERR $ CMD NO_AUTH) + noParamsSyntaxTest "SUB" SUB_ + noParamsSyntaxTest "ACK" ACK_ + noParamsSyntaxTest "OFF" OFF_ + noParamsSyntaxTest "DEL" DEL_ describe "SEND" $ do - it "valid syntax 1" $ (sampleSig, "cdab", "12345678", "SEND hello") >#> ("", "cdab", "12345678", "ERR AUTH") - it "valid syntax 2" $ (sampleSig, "dabc", "12345678", "SEND hello there") >#> ("", "dabc", "12345678", "ERR AUTH") - it "no parameters" $ (sampleSig, "abcd", "12345678", "SEND") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX") - it "no queue ID" $ (sampleSig, "bcda", "", "SEND hello") >#> ("", "bcda", "", "ERR CMD NO_QUEUE") + it "valid syntax" $ (sampleSig, "cdab", "12345678", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "cdab", "12345678", ERR AUTH) + it "no parameters" $ (sampleSig, "abcd", "12345678", SEND_) >#> ("", "abcd", "12345678", ERR $ CMD SYNTAX) + it "no queue ID" $ (sampleSig, "bcda", "", (SEND_, ' ', "hello" :: ByteString)) >#> ("", "bcda", "", ERR $ CMD NO_QUEUE) describe "PING" $ do - it "valid syntax" $ ("", "abcd", "", "PING") >#> ("", "abcd", "", "PONG") + it "valid syntax" $ ("", "abcd", "", PING_) >#> ("", "abcd", "", PONG) describe "broker response not allowed" $ do - it "OK" $ (sampleSig, "bcda", "12345678", "OK") >#> ("", "bcda", "12345678", "ERR CMD PROHIBITED") + it "OK" $ (sampleSig, "bcda", "12345678", OK_) >#> ("", "bcda", "12345678", ERR $ CMD UNKNOWN) where - noParamsSyntaxTest :: ByteString -> Spec - noParamsSyntaxTest cmd = describe (B.unpack cmd) $ do - it "valid syntax" $ (sampleSig, "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", "ERR AUTH") - it "wrong terminator" $ (sampleSig, "bcda", "12345678", cmd <> "=") >#> ("", "bcda", "12345678", "ERR CMD SYNTAX") - it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", "ERR CMD NO_AUTH") - it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", "ERR CMD NO_AUTH") - (>#>) :: SignedRawTransmission -> SignedRawTransmission -> Expectation + noParamsSyntaxTest :: PartyI p => String -> CommandTag p -> Spec + noParamsSyntaxTest description cmd = describe description $ do + it "valid syntax" $ (sampleSig, "abcd", "12345678", cmd) >#> ("", "abcd", "12345678", ERR AUTH) + it "wrong terminator" $ (sampleSig, "bcda", "12345678", (cmd, '=')) >#> ("", "bcda", "12345678", ERR $ CMD UNKNOWN) + it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH) + it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) + (>#>) :: + Encoding smp => + (Maybe C.ASignature, ByteString, ByteString, smp) -> + (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) -> + Expectation command >#> response = smpServerTest t command `shouldReturn` response diff --git a/tests/Test.hs b/tests/Test.hs index 25cfa3f3d..bdb26894d 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,7 +1,9 @@ {-# LANGUAGE TypeApplications #-} import AgentTests (agentTests) -import ProtocolErrorTests +import CoreTests.EncodingTests +import CoreTests.ProtocolErrorTests +import CoreTests.VersionRangeTests import ServerTests import Simplex.Messaging.Transport (TLS, Transport (..)) import Simplex.Messaging.Transport.WebSockets (WS) @@ -12,7 +14,10 @@ main :: IO () main = do createDirectoryIfMissing False "tests/tmp" hspec $ do - describe "Protocol errors" protocolErrorTests + describe "Core tests" $ do + describe "Encoding tests" encodingTests + describe "Protocol error tests" protocolErrorTests + describe "Version range" versionRangeTests describe "SMP server via TLS 1.3" $ serverTests (transport @TLS) describe "SMP server via WebSockets" $ serverTests (transport @WS) describe "SMP client agent" $ agentTests (transport @TLS)