mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-15 01:57:29 +00:00
simple per-queue e2e encryption with NaCl crypto_box (#242)
* simple per-queue e2e encryption with NaCl crypto_box * add e2e keys and DH secrets to schema * agree and save shared DH secret per queue (not used yet) * protocol changes for uniform padding and message part lengths * correct message structure diagrams * make per-queue E2E encryption non-optional * refactor crypto keys * use NaCl crypto_box for per-queue E2E encryption, remove RSA keys from queues * remove RSA support * merge migration with E2E DH keys * clean up * remove unused methods * parsing/serializing agent messages * remove sender timestamp from DB and code * clean up * slean up * s/SMPConfMsg/SMPConfirmation/ * serializeAgentMessage = serializeClientMessage . agentToClientMsg * simplify error handling * update protocol docs
This commit is contained in:
Evgeny Poberezkin
@@ -39,7 +39,6 @@ serverConfig =
|
||||
msgQueueQuota = 256,
|
||||
queueIdBytes = 24,
|
||||
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
|
||||
blockSize = 16 * 1024, -- TODO move to Protocol
|
||||
-- below parameters are set based on ini file /etc/opt/simplex/smp-server.ini
|
||||
transports = undefined,
|
||||
storeLog = undefined,
|
||||
|
||||
@@ -11,10 +11,11 @@ CREATE TABLE IF NOT EXISTS rcv_queues(
|
||||
rcv_id BLOB NOT NULL,
|
||||
conn_alias BLOB NOT NULL,
|
||||
rcv_private_key BLOB NOT NULL,
|
||||
e2e_priv_key BLOB NOT NULL,
|
||||
e2e_snd_pub_key BLOB,
|
||||
e2e_dh_secret BLOB,
|
||||
snd_id BLOB NOT NULL,
|
||||
snd_key BLOB,
|
||||
decrypt_key BLOB NOT NULL,
|
||||
verify_key BLOB,
|
||||
status TEXT NOT NULL,
|
||||
PRIMARY KEY (host, port, rcv_id),
|
||||
FOREIGN KEY (host, port) REFERENCES servers (host, port),
|
||||
@@ -31,8 +32,8 @@ CREATE TABLE IF NOT EXISTS snd_queues(
|
||||
snd_id BLOB NOT NULL,
|
||||
conn_alias BLOB NOT NULL,
|
||||
snd_private_key BLOB NOT NULL,
|
||||
encrypt_key BLOB NOT NULL,
|
||||
sign_key BLOB NOT NULL,
|
||||
e2e_pub_key BLOB NOT NULL,
|
||||
e2e_dh_secret BLOB NOT NULL,
|
||||
status TEXT NOT NULL,
|
||||
PRIMARY KEY (host, port, snd_id),
|
||||
FOREIGN KEY (host, port) REFERENCES servers (host, port),
|
||||
@@ -87,7 +88,6 @@ CREATE TABLE IF NOT EXISTS rcv_messages(
|
||||
internal_rcv_id INTEGER NOT NULL,
|
||||
internal_id INTEGER NOT NULL,
|
||||
external_snd_id INTEGER NOT NULL,
|
||||
external_snd_ts TEXT NOT NULL,
|
||||
broker_id BLOB NOT NULL,
|
||||
broker_ts TEXT NOT NULL,
|
||||
rcv_status TEXT NOT NULL,
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
CREATE TABLE conn_confirmations (
|
||||
confirmation_id BLOB NOT NULL PRIMARY KEY,
|
||||
conn_alias BLOB NOT NULL REFERENCES connections ON DELETE CASCADE,
|
||||
e2e_snd_pub_key BLOB NOT NULL,
|
||||
sender_key BLOB NOT NULL,
|
||||
sender_conn_info BLOB NOT NULL,
|
||||
accepted INTEGER NOT NULL,
|
||||
|
||||
@@ -142,17 +142,15 @@ agentMessage = helloMsg / replyQueueMsg /
|
||||
|
||||
msgPadding = *OCTET ; optional random bytes to get messages to the same size (as defined in SMP message size)
|
||||
|
||||
helloMsg = %s"HELLO" SP signatureVerificationKey [SP %s"NO_ACK"]
|
||||
; NO_ACK means that acknowledgements to client messages will NOT be sent in this connection by the agent that sent `HELLO` message.
|
||||
signatureVerificationKey = encoded
|
||||
helloMsg = %s"HELLO"
|
||||
|
||||
replyQueueMsg = %s"REPLY" SP connectionRequest ; `connectionRequest` is defined below
|
||||
; this message can only be sent by the second connection party
|
||||
|
||||
clientMsg = %s"MSG" SP size CRLF clientMsgBody CRLF ; CRLF is in addition to CRLF in decryptedSmpMessageBody
|
||||
size = 1*DIGIT
|
||||
clientMsg = %s"MSG" SP clientMsgBody
|
||||
clientMsgBody = *OCTET
|
||||
|
||||
; TODO remove and move to "public" header
|
||||
invitationMsg = %s"INV" SP connReqInvitation SP connInfo
|
||||
; `connReqInvitation` and `connInfo` are defined below
|
||||
|
||||
@@ -303,7 +301,7 @@ messageError = %s"MERR" SP agentMsgId SP <errorType>
|
||||
message = %s"MSG" SP msgIntegrity SP recipientMeta SP brokerMeta SP senderMeta SP binaryMsg
|
||||
recipientMeta = %s"R=" agentMsgId "," agentTimestamp ; receiving agent message metadata
|
||||
brokerMeta = %s"B=" brokerMsgId "," brokerTimestamp ; broker (server) message metadata
|
||||
senderMeta = %s"S=" agentMsgId "," agentTimestamp ; sending agent message metadata
|
||||
senderMeta = %s"S=" agentMsgId ; sending agent message ID
|
||||
brokerMsgId = encoded
|
||||
brokerTimestamp = <date-time>
|
||||
msgIntegrity = ok / msgIntegrityError
|
||||
|
||||
+142
-35
@@ -14,6 +14,7 @@
|
||||
- [Simplex queue IDs](#simplex-queue-ids)
|
||||
- [Server security requirements](#server-security-requirements)
|
||||
- [Message delivery notifications](#message-delivery-notifications)
|
||||
- [SMP Transmission structure](#smp-transmission-structure)
|
||||
- [SMP commands](#smp-commands)
|
||||
- [Correlating responses with commands](#correlating-responses-with-commands)
|
||||
- [Command authentication](#command-authentication)
|
||||
@@ -116,13 +117,22 @@ The SMP queue URIs MUST include server identity, queue hostname, an optional por
|
||||
The [ABNF][8] syntax of the queue URI is:
|
||||
|
||||
```abnf
|
||||
queueURI = %s"smp://" smpServer "/" queueId ["#"]
|
||||
smpServer = serverIdentity "@" srvHost [":" port]
|
||||
queueURI = %s"smp://" smpServer "/" queueId "#" recipientDhPublicKey
|
||||
smpServer = serverIdentity "@" srvHost [":" port]
|
||||
srvHost = <hostname> ; RFC1123, RFC5891
|
||||
port = 1*DIGIT
|
||||
serverIdentity = base64url
|
||||
queueId = base64url
|
||||
base64url = <base64url encoded binary> ; RFC4648, section 5
|
||||
recipientDhPublicKey = dhPublicKey
|
||||
dhPublicKey = encryptionScheme ":" x509UrlEncoded
|
||||
; the recipient's 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).
|
||||
|
||||
x509UrlEncoded = <base64url X509 key encoding>
|
||||
```
|
||||
|
||||
`hostname` can be IP address or domain name, as defined in RFC 1123, section 2.1.
|
||||
@@ -345,24 +355,35 @@ The clients can optionally instruct a dedicated push notification server to subs
|
||||
- `subscribeNotifications` (`"NSUB"`) - see [Subscribe to queue notifications](#subscribe-to-queue-notifications).
|
||||
- `messageNotification` (`"NMSG"`) - see [Deliver message notification](#deliver-message-notification).
|
||||
|
||||
## SMP commands
|
||||
## SMP Transmission structure
|
||||
|
||||
Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
|
||||
Each transport block (SMP transmission) has a fixed size of 16384 bytes for traffic uniformity.
|
||||
|
||||
Each transmission between the client and the server must have this format/syntax (after the decryption):
|
||||
Some parts of SMP transmission are padded to a fixed size; this padding is uniformly added as a word16 encoded in network byte order - see `paddedString` syntax.
|
||||
|
||||
```abnf
|
||||
transmission = [signature] SP signedSize SP signed SP pad ; pad to the fixed block size
|
||||
signedSize = 1*DIGIT
|
||||
signed = sessionIdentifier SP [corrId] SP [queueId] SP cmd ; corrId is required in client commands and server responses,
|
||||
; corrId is empty in server notifications.
|
||||
cmd = ping / recipientCmd / send / subscribeNotifications / serverMsg
|
||||
recipientCmd = create / subscribe / secure / enableNotifications /
|
||||
acknowledge / suspend / delete
|
||||
serverMsg = queueIds / message / notifierId / messageNotification /
|
||||
unsubscribed / ok / error
|
||||
corrId = 1*(%x21-7F) ; any characters other than control/whitespace
|
||||
queueId = encoded ; empty queue ID is used with "create" command
|
||||
In places where some part of the transmission should be padded, the syntax for `paddedNotation` is used:
|
||||
|
||||
```
|
||||
paddedString = originalLength string pad
|
||||
originalLength = 2*2 OCTET
|
||||
pad = N*N"#" ; where N = paddedLength - originalLength - 2
|
||||
|
||||
paddedNotation = <padded(string, paddedLength)>
|
||||
; string - un-padded string
|
||||
; paddedLength - required length after padding, including 2 bytes for originalLength
|
||||
```
|
||||
|
||||
Each transmission between the client and the server must have this format/syntax:
|
||||
|
||||
```
|
||||
paddedTransmission = <padded(transmission), 16384>
|
||||
transmission = [signature] SP signed
|
||||
signed = sessionIdentifier SP [corrId] SP [queueId] SP smpCommand
|
||||
; corrId is required in client commands and server responses,
|
||||
; it is empty in server notifications.
|
||||
corrId = 1*32(%x21-7F) ; any characters other than control/whitespace
|
||||
queueId = encoded ; max 32 bytes when decoded (24 bytes is used),
|
||||
; empty queue ID is used with "create" command and in some server responses
|
||||
signature = encoded
|
||||
; empty signature can be used with "send" before the queue is secured with secure command
|
||||
; signature is always empty with "ping" and "serverMsg"
|
||||
@@ -371,6 +392,18 @@ encoded = <base64 encoded binary>
|
||||
|
||||
`base64` encoding should be used with padding, as defined in section 4 of [RFC 4648][9]
|
||||
|
||||
## SMP commands
|
||||
|
||||
Commands syntax below is provided using [ABNF][8] with [case-sensitive strings extension][8a].
|
||||
|
||||
```abnf
|
||||
smpCommand = ping / recipientCmd / send / subscribeNotifications / serverMsg
|
||||
recipientCmd = create / subscribe / secure / enableNotifications /
|
||||
acknowledge / suspend / delete
|
||||
serverMsg = queueIds / message / notifierId / messageNotification /
|
||||
unsubscribed / ok / error
|
||||
```
|
||||
|
||||
The syntax of specific commands and responses is defined below.
|
||||
|
||||
### Correlating responses with commands
|
||||
@@ -534,10 +567,16 @@ 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 size SP msgBody SP
|
||||
; the last SP is in addition to SP in the transmission
|
||||
size = 1*DIGIT ; size in bytes
|
||||
msgBody = *OCTET ; any binary content of specified size
|
||||
send = %s"SEND" SP smpEncMessage
|
||||
smpEncMessage = smpPubHeader sentMsgBody ; message up to 15968 bytes
|
||||
smpPubHeader = smpClientVersion encodedLenKey
|
||||
smpClientVersion = word16
|
||||
encodedLenKey = keyLen x509binary
|
||||
keyLen = word16
|
||||
x509binary = <binary X509 key encoding>
|
||||
sentMsgBody = 15842*15842 OCTET
|
||||
; E2E-encrypted smpClientMessage padded to 15842 bytes before encryption
|
||||
word16 = 2*2 OCTET
|
||||
```
|
||||
|
||||
The first message is sent to confirm the queue - it should contain sender's server key (see decrypted message syntax below) - this first message must be sent without signature.
|
||||
@@ -555,15 +594,85 @@ Until the queue is secured, the server should accept any number of unsigned mess
|
||||
The body should be encrypted with the recipient's "public" key (`EK`); once decrypted it must have this format:
|
||||
|
||||
```abnf
|
||||
decryptedBody = [clientHeader] CRLF clientBody CRLF
|
||||
clientHeader = senderKeyMsg
|
||||
senderKeyMsg = %s"KEY" SP senderKey
|
||||
senderKey = signatureScheme ":" x509encoded ; the sender's public key to sign SEND commands for this queue
|
||||
clientBody = *OCTET
|
||||
sentMsgBody = <encrypted padded(smpClientMessage, 15842)>
|
||||
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
|
||||
clientMsgBody = *OCTET ; up to 15784 in case of emptyHeader
|
||||
```
|
||||
|
||||
`clientHeader` in the initial unsigned message is used to transmit sender's server key and can be used in the future revisions of SMP protocol for other purposes.
|
||||
|
||||
SMP transmission structure for sent messages:
|
||||
|
||||
```
|
||||
------- transmission (= 16384 bytes)
|
||||
2 | originalLength
|
||||
398- | signature SP sessionId SP corrId SP queueId SP %s"SEND" SP
|
||||
....... smpEncMessage (= 15968 bytes)
|
||||
126- | smpPubHeader
|
||||
24 | nonce for smpClientMessage
|
||||
------- smpClientMessage (E2E encrypted, = 15842 bytes)
|
||||
2 | originalLength
|
||||
16- | smpPrivHeader
|
||||
.......
|
||||
| clientMsgBody (<= 15784 bytes)
|
||||
.......
|
||||
0+ | smpClientMessage pad
|
||||
------- smpClientMessage end
|
||||
16 | auth tag for smpClientMessage
|
||||
....... smpEncMessage end
|
||||
16+ | transmission pad
|
||||
------- transmission end
|
||||
```
|
||||
|
||||
SMP transmission structure for received messages:
|
||||
|
||||
```
|
||||
------- transmission (= 16384 bytes)
|
||||
2 | originalLength
|
||||
398- | signature SP sessionId SP corrId SP queueId SP %s"MSG" SP msgId SP timestamp SP
|
||||
------- serverEncryptedMsg (= 15986 bytes)
|
||||
2 | originalLength
|
||||
....... smpEncMessage (= 15968 bytes)
|
||||
126- | smpPubHeader
|
||||
24 | nonce for smpClientMessage
|
||||
------- smpClientMessage (E2E encrypted, = 15842 bytes)
|
||||
2 | originalLength
|
||||
16- | smpPrivHeader
|
||||
....... clientMsgBody (<= 15784 bytes)
|
||||
-- TODO move internal structure to agent protocol
|
||||
16- | agentPublicHeader
|
||||
....... E2E double-ratchet encrypted (= 15768)
|
||||
96 | double-ratchet header
|
||||
16 | double-ratchet header auth tag
|
||||
24 | double-ratchet header iv
|
||||
------- encrypted agent message (= 15616 bytes)
|
||||
2 | originalLength
|
||||
122 (90) | agentHeader
|
||||
4 | %s"MSG" SP
|
||||
.......
|
||||
| application message (<= 15488 bytes)
|
||||
.......
|
||||
0+ | encrypted agent message pad
|
||||
------- encrypted agent message end
|
||||
16 | auth tag (IV generated from chain ratchet)
|
||||
....... E2E double-ratchet encrypted end
|
||||
|
|
||||
....... clientMsgBody end
|
||||
0+ | smpClientMessage pad
|
||||
------- smpClientMessage end
|
||||
16 | auth tag for smpClientMessage
|
||||
....... smpEncMessage end
|
||||
16 | auth tag (msgId is used as nonce)
|
||||
0+ | serverEncryptedMsg pad
|
||||
------- serverEncryptedMsg end
|
||||
0+ | transmission pad
|
||||
------- transmission end
|
||||
```
|
||||
|
||||
### Notifier commands
|
||||
|
||||
#### Subscribe to queue notifications
|
||||
@@ -591,9 +700,9 @@ 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 encryptedMessage
|
||||
encryptedMessage = <encrypt sentMessage>
|
||||
sentMessage = msgId SP timestamp SP size SP msgBody SP
|
||||
message = %s"MSG" SP msgId SP timestamp SP encryptedMsgBody
|
||||
encryptedMsgBody = <encrypt paddedSentMsgBody> ; server-encrypted padded sent msgBody
|
||||
paddedSentMsgBody = <padded(sentMsgBody, maxMessageLength + 2)> ; maxMessageLength = 15968
|
||||
msgId = encoded
|
||||
timestamp = <date-time defined in RFC3339>
|
||||
```
|
||||
@@ -602,8 +711,6 @@ timestamp = <date-time defined in RFC3339>
|
||||
|
||||
`timestamp` - the UTC time when the server received the message from the sender, must be in date-time format defined by [RFC 3339][10]
|
||||
|
||||
`msgBody` - see syntax in [Send message](#send-message)
|
||||
|
||||
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.
|
||||
|
||||
This is done to prevent the possibility of correlation of incoming and outgoing traffic of SMP server inside transport protocol.
|
||||
@@ -637,24 +744,24 @@ No further messages should be delivered to unsubscribed transport connection.
|
||||
#### Error responses
|
||||
|
||||
- incorrect block format, encoding or signature size (`BLOCK`).
|
||||
- missing or different session ID - tls-unique binding of TLS transport (`SESSION`)
|
||||
- command errors (`CMD`):
|
||||
- error parsing command (`SYNTAX`)
|
||||
- prohibited command (`PROHIBITED`) - any server response sent from client or `ACK` sent without active subscription or without message delivery.
|
||||
- incorrect RSA key size in `NEW` or `KEY` commands - only 1024, 2048 and 4096-bit keys are allowed (`KEY_SIZE`).
|
||||
- transmission has no required signature or queue ID (`NO_AUTH`)
|
||||
- transmission has unexpected credentials (`HAS_AUTH`)
|
||||
- transmission has no required queue ID (`NO_QUEUE`)
|
||||
- authentication error (`AUTH`) - incorrect signature, unknown (or suspended) queue, sender's ID is used in place of recipient's and vice versa, and some other cases (see [Send message](#send-message) command).
|
||||
- message queue quota exceeded error (`QUOTA`) - too many messages were sent to the message queue. Further messages can only be sent after the recipient retrieves the messages.
|
||||
- incorrect message body size (`SIZE`).
|
||||
- sent message is too large (> 15968) to be delivered (`LARGE_MSG`).
|
||||
- internal server error (`INTERNAL`).
|
||||
|
||||
The syntax for error responses:
|
||||
|
||||
```abnf
|
||||
error = %s"ERR" SP errorType
|
||||
errorType = %s"BLOCK" / %s"CMD" SP cmdError / %s"AUTH" / %s"SIZE" /%s"INTERNAL"
|
||||
cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"KEY_SIZE" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_QUEUE"
|
||||
errorType = %s"BLOCK" / %s"SESSION" / %s"CMD" SP cmdError / %s"AUTH" / %s"LARGE_MSG" /%s"INTERNAL"
|
||||
cmdError = %s"SYNTAX" / %s"PROHIBITED" / %s"NO_AUTH" / %s"HAS_AUTH" / %s"NO_QUEUE"
|
||||
```
|
||||
|
||||
Server implementations must aim to respond within the same time for each command in all cases when `"ERR AUTH"` response is required to prevent timing attacks (e.g., the server should perform signature verification even when the queue does not exist on the server or the signature of different size is sent, using any RSA key with the same size as the signature size).
|
||||
|
||||
+115
-98
@@ -62,7 +62,7 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift (MonadUnliftIO)
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (MonadRandom)
|
||||
import Data.Bifunctor (first, second)
|
||||
import Data.Bifunctor (second)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Composition ((.:), (.:.))
|
||||
@@ -83,7 +83,8 @@ 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.Protocol (MsgBody, SndPublicVerifyKey)
|
||||
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.Util (bshow, tryError, unlessM)
|
||||
@@ -265,50 +266,50 @@ processCommand c (connId, cmd) = case cmd of
|
||||
newConn :: AgentMonad m => AgentClient -> ConnId -> SConnectionMode c -> m (ConnId, ConnectionRequest c)
|
||||
newConn c connId cMode = do
|
||||
srv <- getSMPServer
|
||||
(rq, qUri, encryptKey) <- newRcvQueue c srv
|
||||
(rq, qUri) <- newRcvQueue c srv
|
||||
g <- asks idsDrg
|
||||
let cData = ConnData {connId}
|
||||
connId' <- withStore $ \st -> createRcvConn st g cData rq cMode
|
||||
addSubscription c rq connId'
|
||||
let crData = ConnReqData simplexChat [qUri] encryptKey
|
||||
let crData = ConnReqData simplexChat [qUri] ConnectionEncryption
|
||||
pure . (connId',) $ case cMode of
|
||||
SCMInvitation -> CRInvitation crData
|
||||
SCMContact -> CRContact crData
|
||||
|
||||
joinConn :: AgentMonad m => AgentClient -> ConnId -> ConnectionRequest c -> ConnInfo -> m ConnId
|
||||
joinConn c connId (CRInvitation (ConnReqData _ (qUri :| _) encryptKey)) cInfo = do
|
||||
(sq, senderKey, verifyKey) <- newSndQueue qUri encryptKey
|
||||
joinConn c connId (CRInvitation (ConnReqData _ (qUri :| _) _)) cInfo = do
|
||||
(sq, smpConf) <- newSndQueue qUri cInfo
|
||||
g <- asks idsDrg
|
||||
cfg <- asks config
|
||||
let cData = ConnData {connId}
|
||||
connId' <- withStore $ \st -> createSndConn st g cData sq
|
||||
confirmQueue c sq senderKey cInfo
|
||||
activateQueueJoining c connId' sq verifyKey $ retryInterval cfg
|
||||
confirmQueue c sq smpConf
|
||||
activateQueueJoining c connId' sq $ retryInterval cfg
|
||||
pure connId'
|
||||
joinConn c connId (CRContact (ConnReqData _ (qUri :| _) encryptKey)) cInfo = do
|
||||
joinConn c connId (CRContact (ConnReqData _ (qUri :| _) _)) cInfo = do
|
||||
(connId', cReq) <- newConn c connId SCMInvitation
|
||||
sendInvitation c qUri encryptKey cReq cInfo
|
||||
sendInvitation c qUri cReq cInfo
|
||||
pure connId'
|
||||
|
||||
activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m ()
|
||||
activateQueueJoining c connId sq verifyKey retryInterval =
|
||||
activateQueue c connId sq verifyKey retryInterval createReplyQueue
|
||||
activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> RetryInterval -> m ()
|
||||
activateQueueJoining c connId sq retryInterval =
|
||||
activateQueue c connId sq retryInterval createReplyQueue
|
||||
where
|
||||
createReplyQueue :: m ()
|
||||
createReplyQueue = do
|
||||
srv <- getSMPServer
|
||||
(rq, qUri', encryptKey) <- newRcvQueue c srv
|
||||
(rq, qUri') <- newRcvQueue c srv
|
||||
addSubscription c rq connId
|
||||
withStore $ \st -> upgradeSndConnToDuplex st connId rq
|
||||
sendControlMessage c sq . REPLY $ CRInvitation $ ConnReqData CRSSimplex [qUri'] encryptKey
|
||||
sendControlMessage c sq . REPLY $ CRInvitation $ ConnReqData CRSSimplex [qUri'] ConnectionEncryption
|
||||
|
||||
-- | Approve confirmation (LET command) in Reader monad
|
||||
allowConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()
|
||||
allowConnection' c connId confId ownConnInfo = do
|
||||
withStore (`getConn` connId) >>= \case
|
||||
SomeConn _ (RcvConnection _ rq) -> do
|
||||
AcceptedConfirmation {senderKey} <- withStore $ \st -> acceptConfirmation st confId ownConnInfo
|
||||
processConfirmation c rq senderKey
|
||||
AcceptedConfirmation {senderConf} <- withStore $ \st -> acceptConfirmation st confId ownConnInfo
|
||||
processConfirmation c rq senderConf
|
||||
_ -> throwError $ CMD PROHIBITED
|
||||
|
||||
-- | Accept contact (ACPT command) in Reader monad
|
||||
@@ -326,10 +327,11 @@ rejectContact' :: AgentMonad m => AgentClient -> ConnId -> InvitationId -> m ()
|
||||
rejectContact' _ contactConnId invId =
|
||||
withStore $ \st -> deleteInvitation st contactConnId invId
|
||||
|
||||
processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
|
||||
processConfirmation c rq sndKey = do
|
||||
withStore $ \st -> setRcvQueueStatus st rq Confirmed
|
||||
secureQueue c rq sndKey
|
||||
processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SMPConfirmation -> m ()
|
||||
processConfirmation c rq@RcvQueue {e2ePrivKey} SMPConfirmation {senderKey, e2ePubKey} = do
|
||||
let dhSecret = C.dh' e2ePubKey e2ePrivKey
|
||||
withStore $ \st -> setRcvQueueConfirmedE2E st rq e2ePubKey dhSecret
|
||||
secureQueue c rq senderKey
|
||||
withStore $ \st -> setRcvQueueStatus st rq Secured
|
||||
|
||||
-- | Subscribe to receive connection messages (SUB command) in Reader monad
|
||||
@@ -340,8 +342,9 @@ subscribeConnection' c connId =
|
||||
resumeMsgDelivery c connId sq
|
||||
case status (sq :: SndQueue) of
|
||||
Confirmed -> do
|
||||
conf <- withStore (`getAcceptedConfirmation` connId)
|
||||
secureQueue c rq $ senderKey (conf :: AcceptedConfirmation)
|
||||
AcceptedConfirmation {senderConf = SMPConfirmation {senderKey}} <-
|
||||
withStore (`getAcceptedConfirmation` connId)
|
||||
secureQueue c rq senderKey
|
||||
withStore $ \st -> setRcvQueueStatus st rq Secured
|
||||
activateSecuredQueue rq sq
|
||||
Secured -> activateSecuredQueue rq sq
|
||||
@@ -350,17 +353,15 @@ subscribeConnection' c connId =
|
||||
SomeConn _ (SndConnection _ sq) -> do
|
||||
resumeMsgDelivery c connId sq
|
||||
case status (sq :: SndQueue) of
|
||||
Confirmed -> activateQueueJoining c connId sq (verifyKey sq) =<< resumeInterval
|
||||
Confirmed -> activateQueueJoining c connId sq =<< resumeInterval
|
||||
Active -> throwError $ CONN SIMPLEX
|
||||
_ -> throwError $ INTERNAL "unexpected queue status"
|
||||
SomeConn _ (RcvConnection _ rq) -> subscribeQueue c rq connId
|
||||
SomeConn _ (ContactConnection _ rq) -> subscribeQueue c rq connId
|
||||
where
|
||||
verifyKey :: SndQueue -> C.APublicVerifyKey
|
||||
verifyKey = C.publicKey . signKey
|
||||
activateSecuredQueue :: RcvQueue -> SndQueue -> m ()
|
||||
activateSecuredQueue rq sq = do
|
||||
activateQueueInitiating c connId sq (verifyKey sq) =<< resumeInterval
|
||||
activateQueueInitiating c connId sq =<< resumeInterval
|
||||
subscribeQueue c rq connId
|
||||
resumeInterval :: m RetryInterval
|
||||
resumeInterval = do
|
||||
@@ -386,15 +387,10 @@ sendMessage' c connId msg =
|
||||
storeSentMsg = do
|
||||
internalTs <- liftIO getCurrentTime
|
||||
withStore $ \st -> do
|
||||
(internalId, internalSndId, previousMsgHash) <- updateSndIds st connId
|
||||
(internalId, internalSndId, prevMsgHash) <- updateSndIds st connId
|
||||
let msgBody =
|
||||
serializeSMPMessage
|
||||
SMPMessage
|
||||
{ senderMsgId = unSndId internalSndId,
|
||||
senderTimestamp = internalTs,
|
||||
previousMsgHash,
|
||||
agentMessage = A_MSG msg
|
||||
}
|
||||
serializeAgentMessage $
|
||||
AgentMessage (AHeader (unSndId internalSndId) prevMsgHash) (A_MSG msg)
|
||||
internalHash = C.sha256Hash msgBody
|
||||
msgData = SndMsgData {..}
|
||||
createSndMsg st connId msgData
|
||||
@@ -505,14 +501,8 @@ getSMPServer =
|
||||
|
||||
sendControlMessage :: AgentMonad m => AgentClient -> SndQueue -> AMessage -> m ()
|
||||
sendControlMessage c sq agentMessage = do
|
||||
senderTimestamp <- liftIO getCurrentTime
|
||||
sendAgentMessage c sq . serializeSMPMessage $
|
||||
SMPMessage
|
||||
{ senderMsgId = 0,
|
||||
senderTimestamp,
|
||||
previousMsgHash = "",
|
||||
agentMessage
|
||||
}
|
||||
sendAgentMessage c sq . serializeAgentMessage $
|
||||
AgentMessage (AHeader 0 "") agentMessage
|
||||
|
||||
subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m ()
|
||||
subscriber c@AgentClient {msgQ} = forever $ do
|
||||
@@ -530,22 +520,39 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
|
||||
_ -> atomically $ writeTBQueue subQ ("", "", ERR $ CONN NOT_FOUND)
|
||||
where
|
||||
processSMP :: SConnType c -> ConnData -> RcvQueue -> m ()
|
||||
processSMP cType ConnData {connId} rq@RcvQueue {rcvDhSecret, status} =
|
||||
processSMP cType ConnData {connId} rq@RcvQueue {rcvDhSecret, e2ePrivKey, e2eShared, status} =
|
||||
case cmd of
|
||||
SMP.MSG srvMsgId srvTs msgBody' -> do
|
||||
SMP.MSG srvMsgId srvTs msgBody' -> handleNotifyAck $ do
|
||||
-- TODO deduplicate with previously received
|
||||
msgBody <- liftEither . first cryptoError $ C.cbDecrypt rcvDhSecret (C.cbNonce srvMsgId) msgBody'
|
||||
msg <- decryptAndVerify rq msgBody
|
||||
let msgHash = C.sha256Hash msg
|
||||
case parseSMPMessage msg of
|
||||
Left e -> notify (ERR e) >> sendAck c rq
|
||||
Right (SMPConfirmation senderKey cInfo) -> smpConfirmation senderKey cInfo >> sendAck c rq
|
||||
Right SMPMessage {agentMessage, senderMsgId, senderTimestamp, previousMsgHash} ->
|
||||
msgBody <- agentCbDecrypt rcvDhSecret (C.cbNonce srvMsgId) msgBody'
|
||||
encMessage@SMP.EncMessage {emHeader = SMP.PubHeader v e2ePubKey} <-
|
||||
liftEither $ parse SMP.encMessageP (AGENT A_MESSAGE) msgBody
|
||||
case e2eShared of
|
||||
Nothing -> do
|
||||
let e2eDhSecret = C.dh' e2ePubKey e2ePrivKey
|
||||
(_, agentMessage) <-
|
||||
decryptAgentMessage e2eDhSecret encMessage
|
||||
case agentMessage of
|
||||
HELLO verifyKey _ -> helloMsg verifyKey msgBody >> sendAck c rq
|
||||
REPLY cReq -> replyMsg cReq >> sendAck c rq
|
||||
A_MSG body -> agentClientMsg previousMsgHash (senderMsgId, senderTimestamp) (srvMsgId, srvTs) body msgHash
|
||||
A_INV cReq cInfo -> smpInvitation cReq cInfo >> sendAck c rq
|
||||
AgentConfirmation senderKey connInfo -> do
|
||||
smpConfirmation SMPConfirmation {senderKey, e2ePubKey, connInfo}
|
||||
ack
|
||||
AgentInvitation cReq cInfo -> smpInvitation cReq cInfo >> ack
|
||||
_ -> prohibited >> ack
|
||||
Just (e2eSndPubKey, e2eDhSecret)
|
||||
| e2eSndPubKey /= e2ePubKey -> prohibited >> ack
|
||||
| otherwise -> do
|
||||
(msg, agentMessage) <-
|
||||
decryptAgentMessage e2eDhSecret encMessage
|
||||
case agentMessage of
|
||||
AgentMessage AHeader {sndMsgId, prevMsgHash} aMsg -> case aMsg of
|
||||
HELLO -> helloMsg >> ack
|
||||
REPLY cReq -> replyMsg cReq >> ack
|
||||
A_MSG body -> 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
|
||||
_ -> prohibited >> ack
|
||||
SMP.END -> do
|
||||
removeSubscription c connId
|
||||
logServer "<--" c srv rId "END"
|
||||
@@ -557,60 +564,72 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
|
||||
notify :: ACommand 'Agent -> m ()
|
||||
notify msg = atomically $ writeTBQueue subQ ("", connId, msg)
|
||||
|
||||
handleNotifyAck :: m () -> m ()
|
||||
handleNotifyAck m = m `catchError` \e -> notify (ERR e) >> ack
|
||||
|
||||
prohibited :: m ()
|
||||
prohibited = notify . ERR $ AGENT A_PROHIBITED
|
||||
|
||||
smpConfirmation :: SndPublicVerifyKey -> ConnInfo -> m ()
|
||||
smpConfirmation senderKey cInfo = do
|
||||
ack :: m ()
|
||||
ack = sendAck c rq
|
||||
|
||||
decryptAgentMessage :: C.DhSecretX25519 -> SMP.EncMessage -> m (ByteString, AgentMessage)
|
||||
decryptAgentMessage e2eDhSecret SMP.EncMessage {emNonce, emBody} = do
|
||||
msg <- agentCbDecrypt e2eDhSecret emNonce emBody
|
||||
agentMessage <-
|
||||
liftEither $ clientToAgentMsg =<< parse SMP.clientMessageP (AGENT A_MESSAGE) msg
|
||||
pure (msg, agentMessage)
|
||||
|
||||
smpConfirmation :: SMPConfirmation -> m ()
|
||||
smpConfirmation senderConf@SMPConfirmation {connInfo} = do
|
||||
logServer "<--" c srv rId "MSG <KEY>"
|
||||
case status of
|
||||
New -> case cType of
|
||||
SCRcv -> do
|
||||
g <- asks idsDrg
|
||||
let newConfirmation = NewConfirmation {connId, senderKey, senderConnInfo = cInfo}
|
||||
let newConfirmation = NewConfirmation {connId, senderConf}
|
||||
confId <- withStore $ \st -> createConfirmation st g newConfirmation
|
||||
notify $ CONF confId cInfo
|
||||
notify $ CONF confId connInfo
|
||||
SCDuplex -> do
|
||||
notify $ INFO cInfo
|
||||
processConfirmation c rq senderKey
|
||||
notify $ INFO connInfo
|
||||
processConfirmation c rq senderConf
|
||||
_ -> prohibited
|
||||
_ -> prohibited
|
||||
|
||||
helloMsg :: SndPublicVerifyKey -> ByteString -> m ()
|
||||
helloMsg verifyKey msgBody = do
|
||||
helloMsg :: m ()
|
||||
helloMsg = do
|
||||
logServer "<--" c srv rId "MSG <HELLO>"
|
||||
case status of
|
||||
Active -> prohibited
|
||||
_ -> do
|
||||
void $ verifyMessage (Just verifyKey) msgBody
|
||||
withStore $ \st -> setRcvQueueActive st rq verifyKey
|
||||
withStore $ \st -> setRcvQueueStatus st rq Active
|
||||
case cType of
|
||||
SCDuplex -> notifyConnected c connId
|
||||
_ -> pure ()
|
||||
|
||||
replyMsg :: ConnectionRequest 'CMInvitation -> m ()
|
||||
replyMsg (CRInvitation (ConnReqData _ (qUri :| _) encryptKey)) = do
|
||||
replyMsg (CRInvitation (ConnReqData _ (qUri :| _) _)) = do
|
||||
logServer "<--" c srv rId "MSG <REPLY>"
|
||||
case cType of
|
||||
SCRcv -> do
|
||||
AcceptedConfirmation {ownConnInfo} <- withStore (`getAcceptedConfirmation` connId)
|
||||
(sq, senderKey, verifyKey) <- newSndQueue qUri encryptKey
|
||||
(sq, smpConf) <- newSndQueue qUri ownConnInfo
|
||||
withStore $ \st -> upgradeRcvConnToDuplex st connId sq
|
||||
confirmQueue c sq senderKey ownConnInfo
|
||||
confirmQueue c sq smpConf
|
||||
withStore (`removeConfirmations` connId)
|
||||
cfg <- asks config
|
||||
activateQueueInitiating c connId sq verifyKey $ retryInterval cfg
|
||||
activateQueueInitiating c connId sq $ retryInterval cfg
|
||||
_ -> prohibited
|
||||
|
||||
agentClientMsg :: PrevRcvMsgHash -> (ExternalSndId, ExternalSndTs) -> (BrokerId, BrokerTs) -> MsgBody -> MsgHash -> m ()
|
||||
agentClientMsg externalPrevSndHash sender broker msgBody internalHash = do
|
||||
agentClientMsg :: PrevRcvMsgHash -> ExternalSndId -> (BrokerId, BrokerTs) -> MsgBody -> MsgHash -> m ()
|
||||
agentClientMsg externalPrevSndHash sndMsgId broker msgBody internalHash = do
|
||||
logServer "<--" c srv rId "MSG <MSG>"
|
||||
internalTs <- liftIO getCurrentTime
|
||||
(internalId, internalRcvId, prevExtSndId, prevRcvMsgHash) <- withStore (`updateRcvIds` connId)
|
||||
let integrity = checkMsgIntegrity prevExtSndId (fst sender) prevRcvMsgHash externalPrevSndHash
|
||||
let integrity = checkMsgIntegrity prevExtSndId sndMsgId prevRcvMsgHash externalPrevSndHash
|
||||
recipient = (unId internalId, internalTs)
|
||||
msgMeta = MsgMeta {integrity, recipient, sender, broker}
|
||||
rcvMsg = RcvMsgData {..}
|
||||
msgMeta = MsgMeta {integrity, recipient, broker, sndMsgId}
|
||||
rcvMsg = RcvMsgData {msgMeta, msgBody, internalRcvId, internalHash, externalPrevSndHash}
|
||||
withStore $ \st -> createRcvMsg st connId rcvMsg
|
||||
notify $ MSG msgMeta msgBody
|
||||
|
||||
@@ -634,24 +653,24 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
|
||||
| internalPrevMsgHash /= receivedPrevMsgHash = MsgError MsgBadHash
|
||||
| otherwise = MsgError MsgDuplicate -- this case is not possible
|
||||
|
||||
confirmQueue :: AgentMonad m => AgentClient -> SndQueue -> SndPublicVerifyKey -> ConnInfo -> m ()
|
||||
confirmQueue c sq senderKey cInfo = do
|
||||
sendConfirmation c sq senderKey cInfo
|
||||
confirmQueue :: AgentMonad m => AgentClient -> SndQueue -> SMPConfirmation -> m ()
|
||||
confirmQueue c sq smpConf = do
|
||||
sendConfirmation c sq smpConf
|
||||
withStore $ \st -> setSndQueueStatus st sq Confirmed
|
||||
|
||||
activateQueueInitiating :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m ()
|
||||
activateQueueInitiating c connId sq verifyKey retryInterval =
|
||||
activateQueue c connId sq verifyKey retryInterval $ notifyConnected c connId
|
||||
activateQueueInitiating :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> RetryInterval -> m ()
|
||||
activateQueueInitiating c connId sq retryInterval =
|
||||
activateQueue c connId sq retryInterval $ notifyConnected c connId
|
||||
|
||||
activateQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m () -> m ()
|
||||
activateQueue c connId sq verifyKey retryInterval afterActivation =
|
||||
activateQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> RetryInterval -> m () -> m ()
|
||||
activateQueue c connId sq retryInterval afterActivation =
|
||||
getActivation c connId >>= \case
|
||||
Nothing -> async runActivation >>= addActivation c connId
|
||||
Just _ -> pure ()
|
||||
where
|
||||
runActivation :: m ()
|
||||
runActivation = do
|
||||
sendHello c sq verifyKey retryInterval
|
||||
sendHello c sq retryInterval
|
||||
withStore $ \st -> setSndQueueStatus st sq Active
|
||||
removeActivation c connId
|
||||
afterActivation
|
||||
@@ -659,29 +678,27 @@ activateQueue c connId sq verifyKey retryInterval afterActivation =
|
||||
notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m ()
|
||||
notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON)
|
||||
|
||||
newSndQueue ::
|
||||
(MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> C.APublicEncryptKey -> m (SndQueue, SndPublicVerifyKey, C.APublicVerifyKey)
|
||||
newSndQueue qUri encryptKey =
|
||||
newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> ConnInfo -> m (SndQueue, SMPConfirmation)
|
||||
newSndQueue qUri cInfo =
|
||||
asks (cmdSignAlg . config) >>= \case
|
||||
C.SignAlg a -> newSndQueue_ a qUri encryptKey
|
||||
C.SignAlg a -> newSndQueue_ a qUri cInfo
|
||||
|
||||
newSndQueue_ ::
|
||||
(C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m, MonadReader Env m) =>
|
||||
(C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m) =>
|
||||
C.SAlgorithm a ->
|
||||
SMPQueueUri ->
|
||||
C.APublicEncryptKey ->
|
||||
m (SndQueue, SndPublicVerifyKey, C.APublicVerifyKey)
|
||||
newSndQueue_ a (SMPQueueUri smpServer senderId) encryptKey = do
|
||||
size <- asks $ rsaKeySize . config
|
||||
(senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a
|
||||
(verifyKey, signKey) <- liftIO $ C.generateSignatureKeyPair size C.SRSA
|
||||
ConnInfo ->
|
||||
m (SndQueue, SMPConfirmation)
|
||||
newSndQueue_ a (SMPQueueUri smpServer senderId rcvE2ePubDhKey) cInfo = do
|
||||
(senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
|
||||
(e2ePubKey, e2ePrivKey) <- liftIO C.generateKeyPair'
|
||||
let sndQueue =
|
||||
SndQueue
|
||||
{ server = smpServer,
|
||||
sndId = senderId,
|
||||
sndPrivateKey,
|
||||
encryptKey,
|
||||
signKey,
|
||||
e2ePubKey,
|
||||
e2eDhSecret = C.dh' rcvE2ePubDhKey e2ePrivKey,
|
||||
status = New
|
||||
}
|
||||
return (sndQueue, senderKey, verifyKey)
|
||||
pure (sndQueue, SMPConfirmation senderKey e2ePubKey cInfo)
|
||||
|
||||
@@ -22,14 +22,12 @@ module Simplex.Messaging.Agent.Client
|
||||
sendHello,
|
||||
secureQueue,
|
||||
sendAgentMessage,
|
||||
decryptAndVerify,
|
||||
verifyMessage,
|
||||
agentCbDecrypt,
|
||||
sendAck,
|
||||
suspendQueue,
|
||||
deleteQueue,
|
||||
logServer,
|
||||
removeSubscription,
|
||||
cryptoError,
|
||||
addActivation,
|
||||
getActivation,
|
||||
removeActivation,
|
||||
@@ -43,6 +41,7 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Base64
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
@@ -52,7 +51,6 @@ import Data.Maybe (isNothing)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text.Encoding
|
||||
import Data.Time.Clock
|
||||
import Simplex.Messaging.Agent.Env.SQLite
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.RetryInterval
|
||||
@@ -60,6 +58,7 @@ import Simplex.Messaging.Agent.Store
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
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 UnliftIO.Exception (IOException)
|
||||
import qualified UnliftIO.Exception as E
|
||||
@@ -224,7 +223,7 @@ smpClientError = \case
|
||||
SMPTransportError e -> BROKER $ TRANSPORT e
|
||||
e -> INTERNAL $ show e
|
||||
|
||||
newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri, C.APublicEncryptKey)
|
||||
newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri)
|
||||
newRcvQueue c srv =
|
||||
asks (cmdSignAlg . config) >>= \case
|
||||
C.SignAlg a -> newRcvQueue_ a c srv
|
||||
@@ -234,28 +233,27 @@ newRcvQueue_ ::
|
||||
C.SAlgorithm a ->
|
||||
AgentClient ->
|
||||
SMPServer ->
|
||||
m (RcvQueue, SMPQueueUri, C.APublicEncryptKey)
|
||||
m (RcvQueue, SMPQueueUri)
|
||||
newRcvQueue_ a c srv = do
|
||||
size <- asks $ rsaKeySize . config
|
||||
(recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a
|
||||
(dhKey, privDhKey) <- liftIO $ C.generateKeyPair' 0
|
||||
(recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
|
||||
(dhKey, privDhKey) <- liftIO C.generateKeyPair'
|
||||
(e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
|
||||
logServer "-->" c srv "" "NEW"
|
||||
QIK {rcvId, sndId, rcvPublicDHKey} <-
|
||||
QIK {rcvId, sndId, rcvPublicDhKey} <-
|
||||
withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
|
||||
logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
|
||||
(encryptKey, decryptKey) <- liftIO $ C.generateEncryptionKeyPair size C.SRSA
|
||||
let rq =
|
||||
RcvQueue
|
||||
{ server = srv,
|
||||
rcvId,
|
||||
rcvPrivateKey,
|
||||
rcvDhSecret = C.dh' rcvPublicDHKey privDhKey,
|
||||
rcvDhSecret = C.dh' rcvPublicDhKey privDhKey,
|
||||
e2ePrivKey,
|
||||
e2eShared = Nothing,
|
||||
sndId = Just sndId,
|
||||
decryptKey,
|
||||
verifyKey = Nothing,
|
||||
status = New
|
||||
}
|
||||
pure (rq, SMPQueueUri srv sndId, encryptKey)
|
||||
pure (rq, SMPQueueUri srv sndId e2eDhKey)
|
||||
|
||||
subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
|
||||
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
|
||||
@@ -304,51 +302,41 @@ showServer srv = B.pack $ host srv <> maybe "" (":" <>) (port srv)
|
||||
logSecret :: ByteString -> ByteString
|
||||
logSecret bs = encode $ B.take 3 bs
|
||||
|
||||
sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SndPublicVerifyKey -> ConnInfo -> m ()
|
||||
sendConfirmation c sq@SndQueue {server, sndId} senderKey cInfo =
|
||||
sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SMPConfirmation -> m ()
|
||||
sendConfirmation c sq@SndQueue {server, sndId} SMPConfirmation {senderKey, connInfo} =
|
||||
withLogSMP_ c server sndId "SEND <KEY>" $ \smp -> do
|
||||
msg <- mkConfirmation smp
|
||||
msg <- mkConfirmation
|
||||
liftSMP $ sendSMPMessage smp Nothing sndId msg
|
||||
where
|
||||
mkConfirmation :: SMPClient -> m MsgBody
|
||||
mkConfirmation smp = encryptAndSign smp sq . serializeSMPMessage $ SMPConfirmation senderKey cInfo
|
||||
mkConfirmation :: m MsgBody
|
||||
mkConfirmation =
|
||||
agentCbEncrypt sq . serializeAgentMessage $
|
||||
AgentConfirmation senderKey connInfo
|
||||
|
||||
sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m ()
|
||||
sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey ri =
|
||||
sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> RetryInterval -> m ()
|
||||
sendHello c sq@SndQueue {server, sndId, sndPrivateKey} ri =
|
||||
withLogSMP_ c server sndId "SEND <HELLO> (retrying)" $ \smp -> do
|
||||
msg <- mkHello smp $ AckMode On
|
||||
msg <- mkHello
|
||||
liftSMP . withRetryInterval ri $ \loop ->
|
||||
sendSMPMessage smp (Just sndPrivateKey) sndId msg `catchE` \case
|
||||
SMPServerError AUTH -> loop
|
||||
e -> throwE e
|
||||
where
|
||||
mkHello :: SMPClient -> AckMode -> m ByteString
|
||||
mkHello smp ackMode = do
|
||||
senderTimestamp <- liftIO getCurrentTime
|
||||
encryptAndSign smp sq . serializeSMPMessage $
|
||||
SMPMessage
|
||||
{ senderMsgId = 0,
|
||||
senderTimestamp,
|
||||
previousMsgHash = "",
|
||||
agentMessage = HELLO verifyKey ackMode
|
||||
}
|
||||
mkHello :: m ByteString
|
||||
mkHello = do
|
||||
agentCbEncrypt sq . serializeAgentMessage $
|
||||
AgentMessage (AHeader 0 "") HELLO
|
||||
|
||||
sendInvitation :: forall m. AgentMonad m => AgentClient -> SMPQueueUri -> C.APublicEncryptKey -> ConnectionRequest 'CMInvitation -> ConnInfo -> m ()
|
||||
sendInvitation c SMPQueueUri {smpServer, senderId} encryptKey cReq connInfo = do
|
||||
sendInvitation :: forall m. AgentMonad m => AgentClient -> SMPQueueUri -> ConnectionRequest 'CMInvitation -> ConnInfo -> m ()
|
||||
sendInvitation c SMPQueueUri {smpServer, senderId, dhPublicKey} cReq connInfo = do
|
||||
withLogSMP_ c smpServer senderId "SEND <INV>" $ \smp -> do
|
||||
msg <- mkInvitation smp
|
||||
msg <- mkInvitation
|
||||
liftSMP $ sendSMPMessage smp Nothing senderId msg
|
||||
where
|
||||
mkInvitation :: SMPClient -> m ByteString
|
||||
mkInvitation smp = do
|
||||
senderTimestamp <- liftIO getCurrentTime
|
||||
encryptUnsigned smp encryptKey . serializeSMPMessage $
|
||||
SMPMessage
|
||||
{ senderMsgId = 0,
|
||||
senderTimestamp,
|
||||
previousMsgHash = "",
|
||||
agentMessage = A_INV cReq connInfo
|
||||
}
|
||||
mkInvitation :: m ByteString
|
||||
mkInvitation =
|
||||
agentCbEncryptOnce dhPublicKey . serializeAgentMessage $
|
||||
AgentInvitation cReq connInfo
|
||||
|
||||
secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
|
||||
secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =
|
||||
@@ -373,49 +361,40 @@ deleteQueue c RcvQueue {server, rcvId, rcvPrivateKey} =
|
||||
sendAgentMessage :: AgentMonad m => AgentClient -> SndQueue -> ByteString -> m ()
|
||||
sendAgentMessage c sq@SndQueue {server, sndId, sndPrivateKey} msg =
|
||||
withLogSMP_ c server sndId "SEND <message>" $ \smp -> do
|
||||
msg' <- encryptAndSign smp sq msg
|
||||
msg' <- agentCbEncrypt sq msg
|
||||
liftSMP $ sendSMPMessage smp (Just sndPrivateKey) sndId msg'
|
||||
|
||||
encryptAndSign :: AgentMonad m => SMPClient -> SndQueue -> ByteString -> m ByteString
|
||||
encryptAndSign smp SndQueue {encryptKey, signKey} msg = do
|
||||
paddedSize <- asks $ (blockSize smp -) . reservedMsgSize
|
||||
liftError cryptoError $ do
|
||||
enc <- C.encrypt encryptKey paddedSize msg
|
||||
sig <- C.sign signKey enc
|
||||
pure $ C.signatureBytes sig <> enc
|
||||
agentCbEncrypt :: AgentMonad m => SndQueue -> ByteString -> m ByteString
|
||||
agentCbEncrypt SndQueue {e2ePubKey, e2eDhSecret} msg = do
|
||||
emNonce <- liftIO C.randomCbNonce
|
||||
emBody <-
|
||||
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}
|
||||
|
||||
decryptAndVerify :: AgentMonad m => RcvQueue -> MsgBody -> m ByteString
|
||||
decryptAndVerify RcvQueue {decryptKey, verifyKey} msg =
|
||||
verifyMessage verifyKey msg
|
||||
>>= liftError cryptoError . C.decrypt decryptKey
|
||||
agentCbEncryptOnce :: AgentMonad m => C.PublicKeyX25519 -> ByteString -> m ByteString
|
||||
agentCbEncryptOnce dhRcvPubKey msg = do
|
||||
(dhSndPubKey, dhSndPrivKey) <- liftIO C.generateKeyPair'
|
||||
let e2eDhSecret = C.dh' dhRcvPubKey dhSndPrivKey
|
||||
emNonce <- liftIO C.randomCbNonce
|
||||
emBody <-
|
||||
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}
|
||||
|
||||
encryptUnsigned :: AgentMonad m => SMPClient -> C.APublicEncryptKey -> ByteString -> m ByteString
|
||||
encryptUnsigned smp encryptKey msg = do
|
||||
paddedSize <- asks $ (blockSize smp -) . reservedMsgSize
|
||||
size <- asks $ rsaKeySize . config
|
||||
liftError cryptoError $ do
|
||||
enc <- C.encrypt encryptKey paddedSize msg
|
||||
let sig = B.replicate size ' '
|
||||
pure $ sig <> enc
|
||||
|
||||
verifyMessage :: AgentMonad m => Maybe C.APublicVerifyKey -> ByteString -> m ByteString
|
||||
verifyMessage verifyKey msg = do
|
||||
sigSize <- asks $ rsaKeySize . config
|
||||
let (s, enc) = B.splitAt sigSize msg
|
||||
case verifyKey of
|
||||
Nothing -> pure enc
|
||||
Just k ->
|
||||
case C.decodeSignature $ B.take (C.signatureSize k) s of
|
||||
Left _ -> throwError $ AGENT A_SIGNATURE
|
||||
Right sig ->
|
||||
if C.verify k sig enc
|
||||
then pure enc
|
||||
else throwError $ AGENT A_SIGNATURE
|
||||
agentCbDecrypt :: AgentMonad m => C.DhSecretX25519 -> C.CbNonce -> ByteString -> m ByteString
|
||||
agentCbDecrypt dhSecret nonce msg =
|
||||
liftEither . first cryptoError $
|
||||
C.cbDecrypt dhSecret nonce msg
|
||||
|
||||
cryptoError :: C.CryptoError -> AgentErrorType
|
||||
cryptoError = \case
|
||||
C.CryptoLargeMsgError -> CMD LARGE
|
||||
C.RSADecryptError _ -> AGENT A_ENCRYPTION
|
||||
C.CryptoHeaderError _ -> AGENT A_ENCRYPTION
|
||||
C.AESDecryptError -> AGENT A_ENCRYPTION
|
||||
C.CBDecryptError -> AGENT A_ENCRYPTION
|
||||
e -> INTERNAL $ show e
|
||||
|
||||
@@ -23,7 +23,6 @@ import UnliftIO.STM
|
||||
data AgentConfig = AgentConfig
|
||||
{ tcpPort :: ServiceName,
|
||||
smpServers :: NonEmpty SMPServer,
|
||||
rsaKeySize :: Int,
|
||||
cmdSignAlg :: C.SignAlg,
|
||||
connIdBytes :: Int,
|
||||
tbqSize :: Natural,
|
||||
@@ -45,7 +44,6 @@ defaultAgentConfig =
|
||||
AgentConfig
|
||||
{ tcpPort = "5224",
|
||||
smpServers = undefined,
|
||||
rsaKeySize = 2048 `div` 8,
|
||||
cmdSignAlg = C.SignAlg C.SEd448,
|
||||
connIdBytes = 12,
|
||||
tbqSize = 16,
|
||||
@@ -75,7 +73,6 @@ data Env = Env
|
||||
store :: SQLiteStore,
|
||||
idsDrg :: TVar ChaChaDRG,
|
||||
clientCounter :: TVar Int,
|
||||
reservedMsgSize :: Int,
|
||||
randomServer :: TVar StdGen
|
||||
}
|
||||
|
||||
@@ -85,10 +82,4 @@ newSMPAgentEnv cfg = do
|
||||
store <- liftIO $ createSQLiteStore (dbFile cfg) (dbPoolSize cfg) Migrations.app
|
||||
clientCounter <- newTVarIO 0
|
||||
randomServer <- newTVarIO =<< liftIO newStdGen
|
||||
return Env {config = cfg, store, idsDrg, clientCounter, reservedMsgSize, randomServer}
|
||||
where
|
||||
-- 1st rsaKeySize is used by the RSA signature in each command,
|
||||
-- 2nd - by encrypted message body header
|
||||
-- 3rd - by message signature
|
||||
-- smpCommandSize - is the estimated max size for SMP command, queueId, corrId
|
||||
reservedMsgSize = 3 * rsaKeySize cfg + smpCommandSize (smpCfg cfg)
|
||||
return Env {config = cfg, store, idsDrg, clientCounter, randomServer}
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
@@ -35,7 +36,9 @@ module Simplex.Messaging.Agent.Protocol
|
||||
SAParty (..),
|
||||
MsgHash,
|
||||
MsgMeta (..),
|
||||
SMPMessage (..),
|
||||
SMPConfirmation (..),
|
||||
AgentMessage (..),
|
||||
AHeader (..),
|
||||
AMessage (..),
|
||||
SMPServer (..),
|
||||
SMPQueueUri (..),
|
||||
@@ -49,6 +52,7 @@ module Simplex.Messaging.Agent.Protocol
|
||||
AConnectionRequest (..),
|
||||
ConnReqData (..),
|
||||
ConnReqScheme (..),
|
||||
ConnectionEncryption (..),
|
||||
simplexChat,
|
||||
AgentErrorType (..),
|
||||
CommandErrorType (..),
|
||||
@@ -61,8 +65,6 @@ module Simplex.Messaging.Agent.Protocol
|
||||
ConnId,
|
||||
ConfirmationId,
|
||||
InvitationId,
|
||||
AckMode (..),
|
||||
OnOff (..),
|
||||
MsgIntegrity (..),
|
||||
MsgErrorType (..),
|
||||
QueueStatus (..),
|
||||
@@ -71,11 +73,10 @@ module Simplex.Messaging.Agent.Protocol
|
||||
|
||||
-- * Parse and serialize
|
||||
serializeCommand,
|
||||
serializeSMPMessage,
|
||||
clientToAgentMsg,
|
||||
serializeAgentMessage,
|
||||
serializeMsgIntegrity,
|
||||
serializeServer,
|
||||
serializeSMPQueueUri,
|
||||
reservedServerKey, -- TODO remove
|
||||
serializeConnMode,
|
||||
serializeConnMode',
|
||||
connMode,
|
||||
@@ -84,7 +85,6 @@ module Simplex.Messaging.Agent.Protocol
|
||||
serializeConnReq',
|
||||
serializeAgentError,
|
||||
commandP,
|
||||
parseSMPMessage,
|
||||
smpServerP,
|
||||
smpQueueUriP,
|
||||
connModeT,
|
||||
@@ -92,7 +92,6 @@ module Simplex.Messaging.Agent.Protocol
|
||||
connReqP',
|
||||
msgIntegrityP,
|
||||
agentErrorTypeP,
|
||||
agentMessageP,
|
||||
|
||||
-- * TCP transport functions
|
||||
tPut,
|
||||
@@ -104,7 +103,6 @@ where
|
||||
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Crypto.PubKey.RSA as R
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Base64
|
||||
@@ -130,10 +128,13 @@ import Network.Socket (HostName, ServiceName)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol
|
||||
( ErrorType,
|
||||
( ClientMessage (..),
|
||||
ErrorType,
|
||||
MsgBody,
|
||||
MsgId,
|
||||
PrivHeader (..),
|
||||
SndPublicVerifyKey,
|
||||
serializeClientMessage,
|
||||
)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
|
||||
@@ -261,93 +262,87 @@ data MsgMeta = MsgMeta
|
||||
{ integrity :: MsgIntegrity,
|
||||
recipient :: (AgentMsgId, UTCTime),
|
||||
broker :: (MsgId, UTCTime),
|
||||
sender :: (AgentMsgId, UTCTime)
|
||||
sndMsgId :: AgentMsgId
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | SMP message formats.
|
||||
data SMPMessage
|
||||
= -- | SMP confirmation
|
||||
-- (see <https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message SMP protocol>)
|
||||
SMPConfirmation
|
||||
{ -- | sender's public key to use for authentication of sender's commands at the recepient's server
|
||||
senderKey :: SndPublicVerifyKey,
|
||||
-- | sender's information to be associated with the connection, e.g. sender's profile information
|
||||
connInfo :: ConnInfo
|
||||
}
|
||||
| -- | Agent message header and envelope for client messages
|
||||
-- (see <https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents SMP agent protocol>)
|
||||
SMPMessage
|
||||
{ -- | sequential ID assigned by the sending agent
|
||||
senderMsgId :: AgentMsgId,
|
||||
-- | timestamp from the sending agent
|
||||
senderTimestamp :: SenderTimestamp,
|
||||
-- | digest of the previous message
|
||||
previousMsgHash :: MsgHash,
|
||||
-- | messages sent between agents once queue is secured
|
||||
agentMessage :: AMessage
|
||||
}
|
||||
data SMPConfirmation = SMPConfirmation
|
||||
{ -- | sender's public key to use for authentication of sender's commands at the recepient's server
|
||||
senderKey :: SndPublicVerifyKey,
|
||||
-- | sender's DH public key for simple per-queue e2e encryption
|
||||
e2ePubKey :: C.PublicKeyX25519,
|
||||
-- | sender's information to be associated with the connection, e.g. sender's profile information
|
||||
connInfo :: ConnInfo
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- SMP agent message formats
|
||||
data AgentMessage
|
||||
= AgentConfirmation C.APublicVerifyKey ConnInfo -- TODO add double ratchet E2E settings
|
||||
| AgentInvitation (ConnectionRequest CMInvitation) ConnInfo
|
||||
| AgentMessage AHeader AMessage
|
||||
|
||||
data AHeader = AHeader
|
||||
{ -- | sequential ID assigned by the sending agent
|
||||
sndMsgId :: AgentMsgId,
|
||||
-- | digest of the previous message
|
||||
prevMsgHash :: MsgHash
|
||||
}
|
||||
|
||||
serializeAHeader :: AHeader -> ByteString
|
||||
serializeAHeader AHeader {sndMsgId, prevMsgHash} =
|
||||
bshow sndMsgId <> " " <> encode prevMsgHash <> "\n"
|
||||
|
||||
emptyAHeader :: ByteString
|
||||
emptyAHeader = "\n"
|
||||
|
||||
aHeaderP :: Parser AHeader
|
||||
aHeaderP = AHeader <$> A.decimal <* A.space <*> (base64P <|> pure "") <* A.endOfLine
|
||||
|
||||
emptyAHeaderP :: Parser ()
|
||||
emptyAHeaderP = A.endOfLine $> ()
|
||||
|
||||
-- | Messages sent between SMP agents once SMP queue is secured.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents
|
||||
data AMessage where
|
||||
-- | the first message in the queue to validate it is secured
|
||||
HELLO :: C.APublicVerifyKey -> AckMode -> AMessage
|
||||
-- | reply queue information
|
||||
REPLY :: ConnectionRequest CMInvitation -> AMessage
|
||||
-- | agent envelope for the client message
|
||||
A_MSG :: MsgBody -> AMessage
|
||||
-- | connection request with the invitation to connect
|
||||
A_INV :: ConnectionRequest CMInvitation -> ConnInfo -> AMessage
|
||||
data AMessage
|
||||
= -- | the first message in the queue to validate it is secured
|
||||
HELLO
|
||||
| -- | reply queue information
|
||||
REPLY (ConnectionRequest CMInvitation)
|
||||
| -- | agent envelope for the client message
|
||||
A_MSG MsgBody
|
||||
deriving (Show)
|
||||
|
||||
-- | Parse SMP message.
|
||||
parseSMPMessage :: ByteString -> Either AgentErrorType SMPMessage
|
||||
parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE
|
||||
serializeAgentMessage :: AgentMessage -> ByteString
|
||||
serializeAgentMessage = serializeClientMessage . agentToClientMsg
|
||||
|
||||
agentToClientMsg :: AgentMessage -> ClientMessage
|
||||
agentToClientMsg = \case
|
||||
AgentConfirmation senderKey cInfo ->
|
||||
ClientMessage (PHConfirmation senderKey) $ emptyAHeader <> cInfo
|
||||
AgentInvitation cReq cInfo ->
|
||||
ClientMessage PHEmpty $ emptyAHeader <> serializeConnReq' cReq <> "\n" <> cInfo
|
||||
AgentMessage header aMsg ->
|
||||
ClientMessage PHEmpty $ serializeAHeader header <> serializeAMessage aMsg
|
||||
|
||||
clientToAgentMsg :: ClientMessage -> Either AgentErrorType AgentMessage
|
||||
clientToAgentMsg (ClientMessage header body) = parse parser (AGENT A_MESSAGE) body
|
||||
where
|
||||
smpMessageP :: Parser SMPMessage
|
||||
smpMessageP = A.endOfLine *> smpClientMessageP <|> smpConfirmationP
|
||||
parser = case header of
|
||||
PHConfirmation senderKey -> AgentConfirmation senderKey <$> (emptyAHeaderP *> A.takeByteString)
|
||||
PHEmpty -> invitationP <|> messageP
|
||||
invitationP = AgentInvitation <$> (emptyAHeaderP *> connReqP' <* A.endOfLine) <*> A.takeByteString
|
||||
messageP = AgentMessage <$> aHeaderP <*> aMessageP
|
||||
|
||||
smpConfirmationP :: Parser SMPMessage
|
||||
smpConfirmationP = "KEY " *> (SMPConfirmation <$> C.strKeyP <* A.endOfLine <* A.endOfLine <*> binaryBodyP <* A.endOfLine)
|
||||
|
||||
smpClientMessageP :: Parser SMPMessage
|
||||
smpClientMessageP =
|
||||
SMPMessage
|
||||
<$> A.decimal <* A.space
|
||||
<*> tsISO8601P <* A.space
|
||||
-- TODO previous message hash should become mandatory when we support HELLO and REPLY
|
||||
-- (for HELLO it would be the hash of SMPConfirmation)
|
||||
<*> (base64P <|> pure "") <* A.endOfLine
|
||||
<*> agentMessageP
|
||||
|
||||
-- | Serialize SMP message.
|
||||
serializeSMPMessage :: SMPMessage -> ByteString
|
||||
serializeSMPMessage = \case
|
||||
SMPConfirmation sKey cInfo -> smpMessage ("KEY " <> C.serializeKey sKey) "" (serializeBinary cInfo) <> "\n"
|
||||
SMPMessage {senderMsgId, senderTimestamp, previousMsgHash, agentMessage} ->
|
||||
let header = messageHeader senderMsgId senderTimestamp previousMsgHash
|
||||
body = serializeAgentMessage agentMessage
|
||||
in smpMessage "" header body
|
||||
where
|
||||
messageHeader msgId ts prevMsgHash =
|
||||
B.unwords [bshow msgId, B.pack $ formatISO8601Millis ts, encode prevMsgHash]
|
||||
smpMessage smpHeader aHeader aBody = B.intercalate "\n" [smpHeader, aHeader, aBody, ""]
|
||||
|
||||
agentMessageP :: Parser AMessage
|
||||
agentMessageP =
|
||||
"HELLO " *> hello
|
||||
aMessageP :: Parser AMessage
|
||||
aMessageP =
|
||||
"HELLO" $> HELLO
|
||||
<|> "REPLY " *> reply
|
||||
<|> "MSG " *> a_msg
|
||||
<|> "INV " *> a_inv
|
||||
where
|
||||
hello = HELLO <$> C.strKeyP <*> ackMode
|
||||
reply = REPLY <$> connReqP'
|
||||
a_msg = A_MSG <$> binaryBodyP <* A.endOfLine
|
||||
a_inv = A_INV <$> connReqP' <* A.space <*> binaryBodyP <* A.endOfLine
|
||||
ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On)
|
||||
a_msg = A_MSG <$> A.takeByteString
|
||||
|
||||
-- | SMP server location parser.
|
||||
smpServerP :: Parser SMPServer
|
||||
@@ -357,25 +352,21 @@ smpServerP = SMPServer <$> server <*> optional port <*> kHash
|
||||
port = A.char ':' *> (B.unpack <$> A.takeWhile1 A.isDigit)
|
||||
kHash = Just . C.KeyHash <$> (A.char '#' *> base64P)
|
||||
|
||||
serializeAgentMessage :: AMessage -> ByteString
|
||||
serializeAgentMessage = \case
|
||||
HELLO verifyKey ackMode -> "HELLO " <> C.serializeKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else ""
|
||||
serializeAMessage :: AMessage -> ByteString
|
||||
serializeAMessage = \case
|
||||
HELLO -> "HELLO"
|
||||
REPLY cReq -> "REPLY " <> serializeConnReq' cReq
|
||||
A_MSG body -> "MSG " <> serializeBinary body <> "\n"
|
||||
A_INV cReq cInfo -> B.unwords ["INV", serializeConnReq' cReq, serializeBinary cInfo] <> "\n"
|
||||
A_MSG body -> "MSG " <> body
|
||||
|
||||
-- | Serialize SMP queue information that is sent out-of-band.
|
||||
serializeSMPQueueUri :: SMPQueueUri -> ByteString
|
||||
serializeSMPQueueUri (SMPQueueUri srv qId) =
|
||||
serializeServerUri srv <> "/" <> U.encode qId <> "#"
|
||||
serializeSMPQueueUri (SMPQueueUri srv qId dhKey) =
|
||||
serializeServerUri srv <> "/" <> U.encode qId <> "#" <> C.serializePubKeyUri' dhKey
|
||||
|
||||
-- | SMP queue information parser.
|
||||
smpQueueUriP :: Parser SMPQueueUri
|
||||
smpQueueUriP =
|
||||
SMPQueueUri <$> smpServerUriP <* "/" <*> base64UriP <* optional "#"
|
||||
|
||||
reservedServerKey :: C.APublicVerifyKey
|
||||
reservedServerKey = C.APublicVerifyKey C.SRSA (C.PublicKeyRSA $ R.PublicKey 1 0 0)
|
||||
SMPQueueUri <$> smpServerUriP <* A.char '/' <*> base64UriP <* A.char '#' <*> C.strPubKeyUriP
|
||||
|
||||
serializeConnReq :: AConnectionRequest -> ByteString
|
||||
serializeConnReq (ACR _ cr) = serializeConnReq' cr
|
||||
@@ -385,7 +376,7 @@ serializeConnReq' = \case
|
||||
CRInvitation crData -> serialize CMInvitation crData
|
||||
CRContact crData -> serialize CMContact crData
|
||||
where
|
||||
serialize crMode ConnReqData {crScheme, crSmpQueues, crEncryptKey} =
|
||||
serialize crMode ConnReqData {crScheme, crSmpQueues, crEncryption = _} =
|
||||
sch <> "/" <> m <> "#/" <> queryStr
|
||||
where
|
||||
sch = case crScheme of
|
||||
@@ -394,9 +385,8 @@ serializeConnReq' = \case
|
||||
m = case crMode of
|
||||
CMInvitation -> "invitation"
|
||||
CMContact -> "contact"
|
||||
queryStr = renderSimpleQuery True [("smp", queues), ("e2e", key)]
|
||||
queryStr = renderSimpleQuery True [("smp", queues), ("e2e", "")]
|
||||
queues = B.intercalate "," . map serializeSMPQueueUri $ L.toList crSmpQueues
|
||||
key = C.serializeKeyUri crEncryptKey
|
||||
|
||||
connReqP' :: forall m. ConnectionModeI m => Parser (ConnectionRequest m)
|
||||
connReqP' = do
|
||||
@@ -411,8 +401,8 @@ connReqP = do
|
||||
crMode <- "/" *> mode <* "#/?"
|
||||
query <- parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')
|
||||
crSmpQueues <- paramP "smp" smpQueues query
|
||||
crEncryptKey <- paramP "e2e" C.strKeyUriP query
|
||||
let cReq = ConnReqData {crScheme, crSmpQueues, crEncryptKey}
|
||||
let crEncryption = ConnectionEncryption
|
||||
cReq = ConnReqData {crScheme, crSmpQueues, crEncryption}
|
||||
pure $ case crMode of
|
||||
CMInvitation -> ACR SCMInvitation $ CRInvitation cReq
|
||||
CMContact -> ACR SCMContact $ CRContact cReq
|
||||
@@ -429,11 +419,7 @@ connReqP = do
|
||||
=<< (smpQueue `A.sepBy1'` A.char ',')
|
||||
smpQueue = parseAll smpQueueUriP <$?> A.takeTill (== ',')
|
||||
|
||||
-- | Serialize SMP server location.
|
||||
serializeServer :: SMPServer -> ByteString
|
||||
serializeServer SMPServer {host, port, keyHash} =
|
||||
B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack . encode . C.unKeyHash) keyHash
|
||||
|
||||
-- | Serialize SMP server URI.
|
||||
serializeServerUri :: SMPServer -> ByteString
|
||||
serializeServerUri SMPServer {host, port, keyHash} = "smp://" <> kh <> B.pack host <> p
|
||||
where
|
||||
@@ -486,18 +472,13 @@ type ConfirmationId = ByteString
|
||||
|
||||
type InvitationId = ByteString
|
||||
|
||||
-- | Connection modes.
|
||||
data OnOff = On | Off deriving (Eq, Show, Read)
|
||||
|
||||
-- | Message acknowledgement mode of the connection.
|
||||
newtype AckMode = AckMode OnOff deriving (Eq, Show)
|
||||
|
||||
-- | SMP queue information sent out-of-band.
|
||||
--
|
||||
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages
|
||||
data SMPQueueUri = SMPQueueUri
|
||||
{ smpServer :: SMPServer,
|
||||
senderId :: SMP.SenderId
|
||||
senderId :: SMP.SenderId,
|
||||
dhPublicKey :: C.PublicKeyX25519
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -521,13 +502,17 @@ deriving instance Show AConnectionRequest
|
||||
data ConnReqData = ConnReqData
|
||||
{ crScheme :: ConnReqScheme,
|
||||
crSmpQueues :: L.NonEmpty SMPQueueUri,
|
||||
crEncryptKey :: C.APublicEncryptKey
|
||||
crEncryption :: ConnectionEncryption
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ConnReqScheme = CRSSimplex | CRSAppServer HostName (Maybe ServiceName)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- TODO this is a stub for double ratchet E2E encryption parameters (2 public DH keys)
|
||||
data ConnectionEncryption = ConnectionEncryption
|
||||
deriving (Eq, Show)
|
||||
|
||||
simplexChat :: ConnReqScheme
|
||||
simplexChat = CRSAppServer "simplex.chat" Nothing
|
||||
|
||||
@@ -549,8 +534,6 @@ data QueueStatus
|
||||
|
||||
type AgentMsgId = Int64
|
||||
|
||||
type SenderTimestamp = UTCTime
|
||||
|
||||
-- | Result of received message integrity validation.
|
||||
data MsgIntegrity = MsgOk | MsgError MsgErrorType
|
||||
deriving (Eq, Show)
|
||||
@@ -615,14 +598,12 @@ data BrokerErrorType
|
||||
|
||||
-- | Errors of another SMP agent.
|
||||
data SMPAgentError
|
||||
= -- | possibly should include bytestring that failed to parse
|
||||
= -- | client or agent message that failed to parse
|
||||
A_MESSAGE
|
||||
| -- | possibly should include the prohibited SMP/agent message
|
||||
| -- | prohibited SMP/agent message
|
||||
A_PROHIBITED
|
||||
| -- | cannot RSA/AES-decrypt or parse decrypted header
|
||||
| -- | cannot decrypt message
|
||||
A_ENCRYPTION
|
||||
| -- | invalid signature
|
||||
A_SIGNATURE
|
||||
deriving (Eq, Generic, Read, Show, Exception)
|
||||
|
||||
instance Arbitrary AgentErrorType where arbitrary = genericArbitraryU
|
||||
@@ -682,8 +663,8 @@ commandP =
|
||||
integrity <- msgIntegrityP
|
||||
recipient <- " R=" *> partyMeta A.decimal
|
||||
broker <- " B=" *> partyMeta base64P
|
||||
sender <- " S=" *> partyMeta A.decimal
|
||||
pure MsgMeta {integrity, recipient, broker, sender}
|
||||
sndMsgId <- " S=" *> A.decimal
|
||||
pure MsgMeta {integrity, recipient, broker, sndMsgId}
|
||||
partyMeta idParser = (,) <$> idParser <* "," <*> tsISO8601P
|
||||
agentError = ACmd SAgent . ERR <$> agentErrorTypeP
|
||||
|
||||
@@ -731,12 +712,12 @@ serializeCommand = \case
|
||||
showTs :: UTCTime -> ByteString
|
||||
showTs = B.pack . formatISO8601Millis
|
||||
serializeMsgMeta :: MsgMeta -> ByteString
|
||||
serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sender = (smId, sTs)} =
|
||||
serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} =
|
||||
B.unwords
|
||||
[ serializeMsgIntegrity integrity,
|
||||
"R=" <> bshow rmId <> "," <> showTs rTs,
|
||||
"B=" <> encode bmId <> "," <> showTs bTs,
|
||||
"S=" <> bshow smId <> "," <> showTs sTs
|
||||
"S=" <> bshow sndMsgId
|
||||
]
|
||||
|
||||
-- | Serialize message integrity validation result.
|
||||
@@ -768,11 +749,6 @@ serializeAgentError = \case
|
||||
BROKER (TRANSPORT e) -> "BROKER TRANSPORT " <> serializeTransportError e
|
||||
e -> bshow e
|
||||
|
||||
binaryBodyP :: Parser ByteString
|
||||
binaryBodyP = do
|
||||
size :: Int <- A.decimal <* A.endOfLine
|
||||
A.take size
|
||||
|
||||
serializeBinary :: ByteString -> ByteString
|
||||
serializeBinary body = bshow (B.length body) <> "\n" <> body
|
||||
|
||||
|
||||
@@ -25,7 +25,6 @@ import Simplex.Messaging.Protocol
|
||||
RcvDhSecret,
|
||||
RcvPrivateSignKey,
|
||||
SndPrivateSignKey,
|
||||
SndPublicVerifyKey,
|
||||
)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
|
||||
@@ -43,7 +42,7 @@ class Monad m => MonadAgentStore s m where
|
||||
upgradeRcvConnToDuplex :: s -> ConnId -> SndQueue -> m ()
|
||||
upgradeSndConnToDuplex :: s -> ConnId -> RcvQueue -> m ()
|
||||
setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m ()
|
||||
setRcvQueueActive :: s -> RcvQueue -> C.APublicVerifyKey -> m ()
|
||||
setRcvQueueConfirmedE2E :: s -> RcvQueue -> C.PublicKeyX25519 -> C.DhSecretX25519 -> m ()
|
||||
setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m ()
|
||||
|
||||
-- Confirmations
|
||||
@@ -81,11 +80,13 @@ data RcvQueue = RcvQueue
|
||||
rcvPrivateKey :: RcvPrivateSignKey,
|
||||
-- | shared DH secret used to encrypt/decrypt message bodies from server to recipient
|
||||
rcvDhSecret :: RcvDhSecret,
|
||||
-- | private DH key related to public sent to sender out-of-band (to agree simple per-queue e2e)
|
||||
e2ePrivKey :: C.PrivateKeyX25519,
|
||||
-- | public sender's DH key and agreed shared DH secret for simple per-queue e2e
|
||||
e2eShared :: Maybe (C.PublicKeyX25519, C.DhSecretX25519),
|
||||
-- | sender queue ID
|
||||
sndId :: Maybe SMP.SenderId,
|
||||
-- | TODO keys used for E2E encryption - these will change with double ratchet
|
||||
decryptKey :: C.APrivateDecryptKey,
|
||||
verifyKey :: Maybe C.APublicVerifyKey,
|
||||
-- | queue status
|
||||
status :: QueueStatus
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -93,10 +94,15 @@ data RcvQueue = RcvQueue
|
||||
-- | A send queue. SMP queue through which the agent sends messages to a recipient.
|
||||
data SndQueue = SndQueue
|
||||
{ server :: SMPServer,
|
||||
-- | sender queue ID
|
||||
sndId :: SMP.SenderId,
|
||||
-- | key used by the sender to sign transmissions
|
||||
sndPrivateKey :: SndPrivateSignKey,
|
||||
encryptKey :: C.APublicEncryptKey,
|
||||
signKey :: C.APrivateSignKey,
|
||||
-- | public DH key that was (or needs to be) sent to the recipient in SMP confirmation (to agree simple per-queue e2e)
|
||||
e2ePubKey :: C.PublicKeyX25519,
|
||||
-- | shared DH secret agreed for simple per-queue e2e encryption
|
||||
e2eDhSecret :: C.DhSecretX25519,
|
||||
-- | queue status
|
||||
status :: QueueStatus
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@@ -167,15 +173,13 @@ newtype ConnData = ConnData {connId :: ConnId}
|
||||
|
||||
data NewConfirmation = NewConfirmation
|
||||
{ connId :: ConnId,
|
||||
senderKey :: SndPublicVerifyKey,
|
||||
senderConnInfo :: ConnInfo
|
||||
senderConf :: SMPConfirmation
|
||||
}
|
||||
|
||||
data AcceptedConfirmation = AcceptedConfirmation
|
||||
{ confirmationId :: ConfirmationId,
|
||||
connId :: ConnId,
|
||||
senderKey :: SndPublicVerifyKey,
|
||||
senderConnInfo :: ConnInfo,
|
||||
senderConf :: SMPConfirmation,
|
||||
ownConnInfo :: ConnInfo
|
||||
}
|
||||
|
||||
@@ -225,7 +229,7 @@ data SndMsgData = SndMsgData
|
||||
internalTs :: InternalTs,
|
||||
msgBody :: MsgBody,
|
||||
internalHash :: MsgHash,
|
||||
previousMsgHash :: MsgHash
|
||||
prevMsgHash :: MsgHash
|
||||
}
|
||||
|
||||
data PendingMsg = PendingMsg
|
||||
@@ -234,10 +238,6 @@ data PendingMsg = PendingMsg
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- * Broadcast types
|
||||
|
||||
type BroadcastId = ByteString
|
||||
|
||||
-- * Message types
|
||||
|
||||
-- | A message in either direction that is stored by the agent.
|
||||
|
||||
@@ -250,19 +250,21 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
|
||||
|]
|
||||
[":status" := status, ":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId]
|
||||
|
||||
setRcvQueueActive :: SQLiteStore -> RcvQueue -> C.APublicVerifyKey -> m ()
|
||||
setRcvQueueActive st RcvQueue {rcvId, server = SMPServer {host, port}} verifyKey =
|
||||
-- ? throw error if queue does not exist?
|
||||
setRcvQueueConfirmedE2E :: SQLiteStore -> RcvQueue -> C.PublicKeyX25519 -> C.DhSecretX25519 -> m ()
|
||||
setRcvQueueConfirmedE2E st RcvQueue {rcvId, server = SMPServer {host, port}} e2eSndPubKey e2eDhSecret =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.executeNamed
|
||||
db
|
||||
[sql|
|
||||
UPDATE rcv_queues
|
||||
SET verify_key = :verify_key, status = :status
|
||||
WHERE host = :host AND port = :port AND rcv_id = :rcv_id;
|
||||
SET e2e_snd_pub_key = :e2e_snd_pub_key,
|
||||
e2e_dh_secret = :e2e_dh_secret,
|
||||
status = :status
|
||||
WHERE host = :host AND port = :port AND rcv_id = :rcv_id
|
||||
|]
|
||||
[ ":verify_key" := Just verifyKey,
|
||||
":status" := Active,
|
||||
[ ":status" := Confirmed,
|
||||
":e2e_snd_pub_key" := e2eSndPubKey,
|
||||
":e2e_dh_secret" := e2eDhSecret,
|
||||
":host" := host,
|
||||
":port" := serializePort_ port,
|
||||
":rcv_id" := rcvId
|
||||
@@ -282,16 +284,16 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
|
||||
[":status" := status, ":host" := host, ":port" := serializePort_ port, ":snd_id" := sndId]
|
||||
|
||||
createConfirmation :: SQLiteStore -> TVar ChaChaDRG -> NewConfirmation -> m ConfirmationId
|
||||
createConfirmation st gVar NewConfirmation {connId, senderKey, senderConnInfo} =
|
||||
createConfirmation st gVar NewConfirmation {connId, senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo}} =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
createWithRandomId gVar $ \confirmationId ->
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO conn_confirmations
|
||||
(confirmation_id, conn_alias, sender_key, sender_conn_info, accepted) VALUES (?, ?, ?, ?, 0);
|
||||
(confirmation_id, conn_alias, sender_key, e2e_snd_pub_key, sender_conn_info, accepted) VALUES (?, ?, ?, ?, ?, 0);
|
||||
|]
|
||||
(confirmationId, connId, senderKey, senderConnInfo)
|
||||
(confirmationId, connId, senderKey, e2ePubKey, connInfo)
|
||||
|
||||
acceptConfirmation :: SQLiteStore -> ConfirmationId -> ConnInfo -> m AcceptedConfirmation
|
||||
acceptConfirmation st confirmationId ownConnInfo =
|
||||
@@ -311,14 +313,20 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_alias, sender_key, sender_conn_info
|
||||
SELECT conn_alias, sender_key, e2e_snd_pub_key, sender_conn_info
|
||||
FROM conn_confirmations
|
||||
WHERE confirmation_id = ?;
|
||||
|]
|
||||
(Only confirmationId)
|
||||
where
|
||||
confirmation [(connId, senderKey, senderConnInfo)] =
|
||||
Right $ AcceptedConfirmation {confirmationId, connId, senderKey, senderConnInfo, ownConnInfo}
|
||||
confirmation [(connId, senderKey, e2ePubKey, connInfo)] =
|
||||
Right
|
||||
AcceptedConfirmation
|
||||
{ confirmationId,
|
||||
connId,
|
||||
senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
|
||||
ownConnInfo
|
||||
}
|
||||
confirmation _ = Left SEConfirmationNotFound
|
||||
|
||||
getAcceptedConfirmation :: SQLiteStore -> ConnId -> m AcceptedConfirmation
|
||||
@@ -328,14 +336,20 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT confirmation_id, sender_key, sender_conn_info, own_conn_info
|
||||
SELECT confirmation_id, sender_key, e2e_snd_pub_key, sender_conn_info, own_conn_info
|
||||
FROM conn_confirmations
|
||||
WHERE conn_alias = ? AND accepted = 1;
|
||||
|]
|
||||
(Only connId)
|
||||
where
|
||||
confirmation [(confirmationId, senderKey, senderConnInfo, ownConnInfo)] =
|
||||
Right $ AcceptedConfirmation {confirmationId, connId, senderKey, senderConnInfo, ownConnInfo}
|
||||
confirmation [(confirmationId, senderKey, e2ePubKey, connInfo, ownConnInfo)] =
|
||||
Right
|
||||
AcceptedConfirmation
|
||||
{ confirmationId,
|
||||
connId,
|
||||
senderConf = SMPConfirmation {senderKey, e2ePubKey, connInfo},
|
||||
ownConnInfo
|
||||
}
|
||||
confirmation _ = Left SEConfirmationNotFound
|
||||
|
||||
removeConfirmations :: SQLiteStore -> ConnId -> m ()
|
||||
@@ -598,6 +612,7 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
|
||||
[ toField a, toField b, toField c, toField d, toField e, toField f,
|
||||
toField g, toField h, toField i, toField j, toField k, toField l
|
||||
]
|
||||
|
||||
{- ORMOLU_ENABLE -}
|
||||
|
||||
-- * Server upsert helper
|
||||
@@ -621,13 +636,15 @@ upsertServer_ dbConn SMPServer {host, port, keyHash} = do
|
||||
insertRcvQueue_ :: DB.Connection -> ConnId -> RcvQueue -> IO ()
|
||||
insertRcvQueue_ dbConn connId RcvQueue {..} = do
|
||||
let port_ = serializePort_ $ port server
|
||||
e2eSndPubKey = fst <$> e2eShared :: Maybe C.PublicKeyX25519
|
||||
e2eDhSecret = snd <$> e2eShared :: Maybe C.DhSecretX25519
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
[sql|
|
||||
INSERT INTO rcv_queues
|
||||
( host, port, rcv_id, conn_alias, rcv_private_key, rcv_dh_secret, snd_id, decrypt_key, verify_key, status)
|
||||
( host, port, rcv_id, conn_alias, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_snd_pub_key, e2e_dh_secret, snd_id, status)
|
||||
VALUES
|
||||
(:host,:port,:rcv_id,:conn_alias,:rcv_private_key,:rcv_dh_secret,:snd_id,:decrypt_key,:verify_key,:status);
|
||||
(:host,:port,:rcv_id,:conn_alias,:rcv_private_key,:rcv_dh_secret,:e2e_priv_key,:e2e_snd_pub_key,:e2e_dh_secret,:snd_id,:status);
|
||||
|]
|
||||
[ ":host" := host server,
|
||||
":port" := port_,
|
||||
@@ -635,9 +652,10 @@ insertRcvQueue_ dbConn connId RcvQueue {..} = do
|
||||
":conn_alias" := connId,
|
||||
":rcv_private_key" := rcvPrivateKey,
|
||||
":rcv_dh_secret" := rcvDhSecret,
|
||||
":e2e_priv_key" := e2ePrivKey,
|
||||
":e2e_snd_pub_key" := e2eSndPubKey,
|
||||
":e2e_dh_secret" := e2eDhSecret,
|
||||
":snd_id" := sndId,
|
||||
":decrypt_key" := decryptKey,
|
||||
":verify_key" := verifyKey,
|
||||
":status" := status
|
||||
]
|
||||
|
||||
@@ -670,17 +688,17 @@ insertSndQueue_ dbConn connId SndQueue {..} = do
|
||||
dbConn
|
||||
[sql|
|
||||
INSERT INTO snd_queues
|
||||
( host, port, snd_id, conn_alias, snd_private_key, encrypt_key, sign_key, status)
|
||||
( host, port, snd_id, conn_alias, snd_private_key, e2e_pub_key, e2e_dh_secret, status)
|
||||
VALUES
|
||||
(:host,:port,:snd_id,:conn_alias,:snd_private_key,:encrypt_key,:sign_key,:status);
|
||||
(:host,:port,:snd_id,:conn_alias,:snd_private_key,:e2e_pub_key,:e2e_dh_secret,:status);
|
||||
|]
|
||||
[ ":host" := host server,
|
||||
":port" := port_,
|
||||
":snd_id" := sndId,
|
||||
":conn_alias" := connId,
|
||||
":snd_private_key" := sndPrivateKey,
|
||||
":encrypt_key" := encryptKey,
|
||||
":sign_key" := signKey,
|
||||
":e2e_pub_key" := e2ePubKey,
|
||||
":e2e_dh_secret" := e2eDhSecret,
|
||||
":status" := status
|
||||
]
|
||||
|
||||
@@ -732,26 +750,17 @@ getRcvQueueByConnAlias_ dbConn connId =
|
||||
dbConn
|
||||
[sql|
|
||||
SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret,
|
||||
q.snd_id, q.decrypt_key, q.verify_key, q.status
|
||||
q.e2e_priv_key, q.e2e_snd_pub_key, q.e2e_dh_secret, q.snd_id, q.status
|
||||
FROM rcv_queues q
|
||||
INNER JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
WHERE q.conn_alias = ?;
|
||||
|]
|
||||
(Only connId)
|
||||
where
|
||||
rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, sndId, decryptKey, verifyKey, status)] =
|
||||
rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eSndPubKey, e2eDhSecret, sndId, status)] =
|
||||
let server = SMPServer host (deserializePort_ port) keyHash
|
||||
in Just $
|
||||
RcvQueue
|
||||
{ server,
|
||||
rcvId,
|
||||
rcvPrivateKey,
|
||||
rcvDhSecret,
|
||||
sndId,
|
||||
decryptKey,
|
||||
verifyKey,
|
||||
status
|
||||
}
|
||||
e2eShared = (,) <$> e2eSndPubKey <*> e2eDhSecret
|
||||
in Just RcvQueue {server, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eShared, sndId, status}
|
||||
rcvQueue _ = Nothing
|
||||
|
||||
getSndQueueByConnAlias_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)
|
||||
@@ -760,16 +769,17 @@ getSndQueueByConnAlias_ dbConn connId =
|
||||
<$> DB.query
|
||||
dbConn
|
||||
[sql|
|
||||
SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key, q.encrypt_key, q.sign_key, q.status
|
||||
SELECT s.key_hash, q.host, q.port, q.snd_id, q.snd_private_key,
|
||||
q.e2e_pub_key, q.e2e_dh_secret, q.status
|
||||
FROM snd_queues q
|
||||
INNER JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
WHERE q.conn_alias = ?;
|
||||
|]
|
||||
(Only connId)
|
||||
where
|
||||
sndQueue [(keyHash, host, port, sndId, sndPrivateKey, encryptKey, signKey, status)] =
|
||||
sndQueue [(keyHash, host, port, sndId, sndPrivateKey, e2ePubKey, e2eDhSecret, status)] =
|
||||
let server = SMPServer host (deserializePort_ port) keyHash
|
||||
in Just $ SndQueue {server, sndId, sndPrivateKey, encryptKey, signKey, status}
|
||||
in Just SndQueue {server, sndId, sndPrivateKey, e2ePubKey, e2eDhSecret, status}
|
||||
sndQueue _ = Nothing
|
||||
|
||||
-- * upgradeRcvConnToDuplex helpers
|
||||
@@ -852,24 +862,23 @@ insertRcvMsgBase_ dbConn connId RcvMsgData {msgMeta, msgBody, internalRcvId} = d
|
||||
|
||||
insertRcvMsgDetails_ :: DB.Connection -> ConnId -> RcvMsgData -> IO ()
|
||||
insertRcvMsgDetails_ dbConn connId RcvMsgData {msgMeta, internalRcvId, internalHash, externalPrevSndHash} = do
|
||||
let MsgMeta {integrity, recipient, sender, broker} = msgMeta
|
||||
let MsgMeta {integrity, recipient, broker, sndMsgId} = msgMeta
|
||||
DB.executeNamed
|
||||
dbConn
|
||||
[sql|
|
||||
INSERT INTO rcv_messages
|
||||
( conn_alias, internal_rcv_id, internal_id, external_snd_id, external_snd_ts,
|
||||
( conn_alias, internal_rcv_id, internal_id, external_snd_id,
|
||||
broker_id, broker_ts, rcv_status, ack_brocker_ts, ack_sender_ts,
|
||||
internal_hash, external_prev_snd_hash, integrity)
|
||||
VALUES
|
||||
(:conn_alias,:internal_rcv_id,:internal_id,:external_snd_id,:external_snd_ts,
|
||||
(:conn_alias,:internal_rcv_id,:internal_id,:external_snd_id,
|
||||
:broker_id,:broker_ts,:rcv_status, NULL, NULL,
|
||||
:internal_hash,:external_prev_snd_hash,:integrity);
|
||||
|]
|
||||
[ ":conn_alias" := connId,
|
||||
":internal_rcv_id" := internalRcvId,
|
||||
":internal_id" := fst recipient,
|
||||
":external_snd_id" := fst sender,
|
||||
":external_snd_ts" := snd sender,
|
||||
":external_snd_id" := sndMsgId,
|
||||
":broker_id" := fst broker,
|
||||
":broker_ts" := snd broker,
|
||||
":rcv_status" := Received,
|
||||
@@ -890,7 +899,7 @@ updateHashRcv_ dbConn connId RcvMsgData {msgMeta, internalHash, internalRcvId} =
|
||||
WHERE conn_alias = :conn_alias
|
||||
AND last_internal_rcv_msg_id = :last_internal_rcv_msg_id;
|
||||
|]
|
||||
[ ":last_external_snd_msg_id" := fst (sender msgMeta),
|
||||
[ ":last_external_snd_msg_id" := sndMsgId (msgMeta :: MsgMeta),
|
||||
":last_rcv_msg_hash" := internalHash,
|
||||
":conn_alias" := connId,
|
||||
":last_internal_rcv_msg_id" := internalRcvId
|
||||
@@ -960,7 +969,7 @@ insertSndMsgDetails_ dbConn connId SndMsgData {..} =
|
||||
":internal_id" := internalId,
|
||||
":snd_status" := SndMsgCreated,
|
||||
":internal_hash" := internalHash,
|
||||
":previous_msg_hash" := previousMsgHash
|
||||
":previous_msg_hash" := prevMsgHash
|
||||
]
|
||||
|
||||
updateHashSnd_ :: DB.Connection -> ConnId -> SndMsgData -> IO ()
|
||||
|
||||
@@ -23,7 +23,7 @@
|
||||
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
|
||||
module Simplex.Messaging.Client
|
||||
( -- * Connect (disconnect) client to (from) SMP server
|
||||
SMPClient (blockSize),
|
||||
SMPClient,
|
||||
getSMPClient,
|
||||
closeSMPClient,
|
||||
|
||||
@@ -85,8 +85,7 @@ data SMPClient = SMPClient
|
||||
sentCommands :: TVar (Map CorrId Request),
|
||||
sndQ :: TBQueue SentRawTransmission,
|
||||
rcvQ :: TBQueue (SignedTransmission (Command 'Broker)),
|
||||
msgQ :: TBQueue SMPServerTransmission,
|
||||
blockSize :: Int
|
||||
msgQ :: TBQueue SMPServerTransmission
|
||||
}
|
||||
|
||||
-- | Type synonym for transmission from some SPM server queue.
|
||||
@@ -101,12 +100,7 @@ data SMPClientConfig = SMPClientConfig
|
||||
-- | timeout of TCP commands (microseconds)
|
||||
tcpTimeout :: Int,
|
||||
-- | period for SMP ping commands (microseconds)
|
||||
smpPing :: Int,
|
||||
-- | SMP transport block size
|
||||
smpBlockSize :: Int,
|
||||
-- | estimated maximum size of SMP command excluding message body,
|
||||
-- determines the maximum allowed message size
|
||||
smpCommandSize :: Int
|
||||
smpPing :: Int
|
||||
}
|
||||
|
||||
-- | Default SMP client configuration.
|
||||
@@ -116,9 +110,7 @@ smpDefaultConfig =
|
||||
{ qSize = 16,
|
||||
defaultTransport = ("5223", transport @TLS),
|
||||
tcpTimeout = 4_000_000,
|
||||
smpPing = 30_000_000,
|
||||
smpBlockSize = 16 * 1024, -- TODO move to Protocol
|
||||
smpCommandSize = 256
|
||||
smpPing = 30_000_000
|
||||
}
|
||||
|
||||
data Request = Request
|
||||
@@ -134,7 +126,7 @@ type Response = Either SMPClientError (Command 'Broker)
|
||||
-- A single queue can be used for multiple 'SMPClient' instances,
|
||||
-- as 'SMPServerTransmission' includes server information.
|
||||
getSMPClient :: SMPServer -> SMPClientConfig -> TBQueue SMPServerTransmission -> IO () -> IO (Either SMPClientError SMPClient)
|
||||
getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlockSize} msgQ disconnected =
|
||||
getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing} msgQ disconnected =
|
||||
atomically mkSMPClient >>= runClient useTransport
|
||||
where
|
||||
mkSMPClient :: STM SMPClient
|
||||
@@ -148,7 +140,6 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlock
|
||||
SMPClient
|
||||
{ action = undefined,
|
||||
sessionId = undefined,
|
||||
blockSize = undefined,
|
||||
connected,
|
||||
smpServer,
|
||||
tcpTimeout,
|
||||
@@ -168,8 +159,7 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlock
|
||||
`finally` atomically (putTMVar thVar $ Left SMPNetworkError)
|
||||
th_ <- tcpTimeout `timeout` atomically (takeTMVar thVar)
|
||||
pure $ case th_ of
|
||||
Just (Right THandle {sessionId, blockSize}) ->
|
||||
Right c {action, sessionId, blockSize}
|
||||
Just (Right THandle {sessionId}) -> Right c {action, sessionId}
|
||||
Just (Left e) -> Left e
|
||||
Nothing -> Left SMPNetworkError
|
||||
|
||||
@@ -181,13 +171,13 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlock
|
||||
|
||||
client :: forall c. Transport c => TProxy c -> SMPClient -> TMVar (Either SMPClientError (THandle c)) -> c -> IO ()
|
||||
client _ c thVar h =
|
||||
runExceptT (clientHandshake h smpBlockSize) >>= \case
|
||||
runExceptT (clientHandshake h) >>= \case
|
||||
Left e -> atomically . putTMVar thVar . Left $ SMPTransportError e
|
||||
Right th@THandle {sessionId, blockSize} -> do
|
||||
Right th@THandle {sessionId} -> do
|
||||
atomically $ do
|
||||
writeTVar (connected c) True
|
||||
putTMVar thVar $ Right th
|
||||
let c' = c {sessionId, blockSize} :: SMPClient
|
||||
let c' = c {sessionId} :: SMPClient
|
||||
raceAny_ [send c' th, process c', receive c' th, ping c']
|
||||
`finally` disconnected
|
||||
|
||||
|
||||
+247
-400
File diff suppressed because it is too large
Load Diff
@@ -22,11 +22,11 @@ import qualified Data.ByteString.Char8 as B
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Word (Word16, Word32)
|
||||
import Network.Transport.Internal (decodeWord16, decodeWord32, encodeWord16, encodeWord32)
|
||||
import Data.Word (Word32)
|
||||
import Network.Transport.Internal (encodeWord16, encodeWord32)
|
||||
import Simplex.Messaging.Crypto
|
||||
import Simplex.Messaging.Parsers (parseAll, parseE, parseE')
|
||||
import Simplex.Messaging.Util (tryE, (<$?>))
|
||||
import Simplex.Messaging.Parsers (parseE, parseE', word16P, word32P)
|
||||
import Simplex.Messaging.Util (tryE)
|
||||
|
||||
data Ratchet a = Ratchet
|
||||
{ -- current ratchet version
|
||||
@@ -77,7 +77,7 @@ newtype RatchetKey = RatchetKey ByteString
|
||||
initSndRatchet' ::
|
||||
forall a. (AlgorithmI a, DhAlgorithm a) => PublicKey a -> PrivateKey a -> ByteString -> ByteString -> IO (Ratchet a)
|
||||
initSndRatchet' rcDHRr sPKey salt rcAD = do
|
||||
rcDHRs@(_, pk) <- generateKeyPair' @a 0
|
||||
rcDHRs@(_, pk) <- generateKeyPair' @a
|
||||
let (sk, rcHKs, rcNHKr) = initKdf salt rcDHRr sPKey
|
||||
-- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr))
|
||||
(rcRK, rcCKs, rcNHKs) = rootKdf sk rcDHRr pk
|
||||
@@ -128,8 +128,7 @@ data MsgHeader a = MsgHeader
|
||||
msgLatestVersion :: E2EEncryptionVersion,
|
||||
msgDHRs :: PublicKey a,
|
||||
msgPN :: Word32,
|
||||
msgNs :: Word32,
|
||||
msgLen :: Word16
|
||||
msgNs :: Word32
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -145,30 +144,21 @@ fullHeaderLen :: Int
|
||||
fullHeaderLen = paddedHeaderLen + authTagSize + ivSize @AES256
|
||||
|
||||
serializeMsgHeader' :: AlgorithmI a => MsgHeader a -> ByteString
|
||||
serializeMsgHeader' MsgHeader {msgVersion, msgLatestVersion, msgDHRs, msgPN, msgNs, msgLen} =
|
||||
serializeMsgHeader' MsgHeader {msgVersion, msgLatestVersion, msgDHRs, msgPN, msgNs} =
|
||||
encodeWord16 msgVersion
|
||||
<> encodeWord16 msgLatestVersion
|
||||
<> encodeWord16 (fromIntegral $ B.length key)
|
||||
<> key
|
||||
<> encodeLenKey msgDHRs
|
||||
<> encodeWord32 msgPN
|
||||
<> encodeWord32 msgNs
|
||||
<> encodeWord16 msgLen
|
||||
where
|
||||
key = encodeKey msgDHRs
|
||||
|
||||
msgHeaderP' :: AlgorithmI a => Parser (MsgHeader a)
|
||||
msgHeaderP' = do
|
||||
msgVersion <- word16
|
||||
msgLatestVersion <- word16
|
||||
keyLen <- fromIntegral <$> word16
|
||||
msgDHRs <- parseAll binaryKeyP <$?> A.take keyLen
|
||||
msgPN <- word32
|
||||
msgNs <- word32
|
||||
msgLen <- word16
|
||||
pure MsgHeader {msgVersion, msgLatestVersion, msgDHRs, msgPN, msgNs, msgLen}
|
||||
where
|
||||
word16 = decodeWord16 <$> A.take 2
|
||||
word32 = decodeWord32 <$> A.take 4
|
||||
msgVersion <- word16P
|
||||
msgLatestVersion <- word16P
|
||||
msgDHRs <- binaryLenKeyP
|
||||
msgPN <- word32P
|
||||
msgNs <- word32P
|
||||
pure MsgHeader {msgVersion, msgLatestVersion, msgDHRs, msgPN, msgNs}
|
||||
|
||||
data EncHeader = EncHeader
|
||||
{ ehBody :: ByteString,
|
||||
@@ -229,8 +219,7 @@ rcEncrypt' rc@Ratchet {rcSnd = Just sr@SndRatchet {rcCKs, rcHKs}, rcNs, rcAD} pa
|
||||
msgLatestVersion = currentE2EVersion,
|
||||
msgDHRs = fst $ rcDHRs rc,
|
||||
msgPN = rcPN rc,
|
||||
msgNs = rcNs,
|
||||
msgLen = fromIntegral $ B.length msg
|
||||
msgNs = rcNs
|
||||
}
|
||||
|
||||
data SkippedMessage a
|
||||
@@ -267,7 +256,7 @@ rcDecrypt' rc@Ratchet {rcRcv, rcMKSkipped, rcAD} msg' = do
|
||||
SMMessage msg rc' -> pure (msg, rc')
|
||||
where
|
||||
decryptRcMessage :: RatchetStep -> MsgHeader a -> EncMessage -> ExceptT CryptoError IO (DecryptResult a)
|
||||
decryptRcMessage rcStep hdr@MsgHeader {msgDHRs, msgPN, msgNs} encMsg = do
|
||||
decryptRcMessage rcStep MsgHeader {msgDHRs, msgPN, msgNs} encMsg = do
|
||||
-- if dh_ratchet:
|
||||
rc' <- ratchetStep rcStep
|
||||
case skipMessageKeys msgNs rc' of
|
||||
@@ -276,7 +265,7 @@ rcDecrypt' rc@Ratchet {rcRcv, rcMKSkipped, rcAD} msg' = do
|
||||
-- state.CKr, mk = KDF_CK(state.CKr)
|
||||
let (rcCKr', mk, iv, _) = chainKdf rcCKr
|
||||
-- return DECRYPT (mk, ciphertext, CONCAT (AD, enc_header))
|
||||
msg <- decryptMessage (MessageKey mk iv) hdr encMsg
|
||||
msg <- decryptMessage (MessageKey mk iv) encMsg
|
||||
-- state . Nr += 1
|
||||
pure (msg, rc'' {rcRcv = Just rr {rcCKr = rcCKr'}, rcNr = rcNr + 1})
|
||||
Right rc'' -> pure (Left CERatchetState, rc'')
|
||||
@@ -289,7 +278,7 @@ rcDecrypt' rc@Ratchet {rcRcv, rcMKSkipped, rcAD} msg' = do
|
||||
Left e -> throwE e
|
||||
Right rc'@Ratchet {rcDHRs, rcRK, rcNHKs, rcNHKr} -> do
|
||||
-- DHRatchetHE(state, header)
|
||||
rcDHRs' <- liftIO $ generateKeyPair' @a 0
|
||||
rcDHRs' <- liftIO $ generateKeyPair' @a
|
||||
-- state.RK, state.CKr, state.NHKr = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))
|
||||
let (rcRK', rcCKr', rcNHKr') = rootKdf rcRK msgDHRs (snd rcDHRs)
|
||||
-- state.RK, state.CKs, state.NHKs = KDF_RK_HE(state.RK, DH(state.DHRs, state.DHRr))
|
||||
@@ -349,7 +338,7 @@ rcDecrypt' rc@Ratchet {rcRcv, rcMKSkipped, rcAD} msg' = do
|
||||
| M.null mks' = M.delete hk rcMKSkipped
|
||||
| otherwise = M.insert hk mks' rcMKSkipped
|
||||
rc' = rc {rcMKSkipped = mksSkipped}
|
||||
msg <- decryptMessage mk hdr encMsg
|
||||
msg <- decryptMessage mk encMsg
|
||||
pure $ SMMessage msg rc'
|
||||
tryDecryptSkipped r _ = pure r
|
||||
decryptRcHeader :: Maybe RcvRatchet -> EncHeader -> ExceptT CryptoError IO (RatchetStep, MsgHeader a)
|
||||
@@ -364,11 +353,11 @@ rcDecrypt' rc@Ratchet {rcRcv, rcMKSkipped, rcAD} msg' = do
|
||||
decryptHeader k EncHeader {ehBody, ehAuthTag, ehIV} = do
|
||||
header <- decryptAEAD k ehIV rcAD ehBody ehAuthTag `catchE` \_ -> throwE CERatchetHeader
|
||||
parseE' CryptoHeaderError msgHeaderP' header
|
||||
decryptMessage :: MessageKey -> MsgHeader a -> EncMessage -> ExceptT CryptoError IO (Either CryptoError ByteString)
|
||||
decryptMessage (MessageKey mk iv) MsgHeader {msgLen} EncMessage {emHeader, emBody, emAuthTag} =
|
||||
decryptMessage :: MessageKey -> EncMessage -> ExceptT CryptoError IO (Either CryptoError ByteString)
|
||||
decryptMessage (MessageKey mk iv) EncMessage {emHeader, emBody, emAuthTag} =
|
||||
-- DECRYPT(mk, ciphertext, CONCAT(AD, enc_header))
|
||||
-- TODO add associated data
|
||||
tryE (B.take (fromIntegral msgLen) <$> decryptAEAD mk iv (rcAD <> emHeader) emBody emAuthTag)
|
||||
tryE $ decryptAEAD mk iv (rcAD <> emHeader) emBody emAuthTag
|
||||
|
||||
initKdf :: (AlgorithmI a, DhAlgorithm a) => ByteString -> PublicKey a -> PrivateKey a -> (RatchetKey, Key, Key)
|
||||
initKdf salt k pk =
|
||||
|
||||
@@ -15,10 +15,12 @@ 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)
|
||||
|
||||
@@ -48,6 +50,12 @@ 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
|
||||
|
||||
|
||||
@@ -27,7 +27,12 @@
|
||||
--
|
||||
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
|
||||
module Simplex.Messaging.Protocol
|
||||
( -- * SMP protocol types
|
||||
( -- * SMP protocol parameters
|
||||
clientVersion,
|
||||
maxMessageLength,
|
||||
e2eEncMessageLength,
|
||||
|
||||
-- * SMP protocol types
|
||||
Command (..),
|
||||
CommandI (..),
|
||||
Party (..),
|
||||
@@ -43,6 +48,10 @@ module Simplex.Messaging.Protocol
|
||||
SignedTransmission,
|
||||
SentRawTransmission,
|
||||
SignedRawTransmission,
|
||||
EncMessage (..),
|
||||
PubHeader (..),
|
||||
ClientMessage (..),
|
||||
PrivHeader (..),
|
||||
CorrId (..),
|
||||
QueueId,
|
||||
RecipientId,
|
||||
@@ -65,6 +74,10 @@ module Simplex.Messaging.Protocol
|
||||
serializeErrorType,
|
||||
transmissionP,
|
||||
errorTypeP,
|
||||
serializeEncMessage,
|
||||
encMessageP,
|
||||
serializeClientMessage,
|
||||
clientMessageP,
|
||||
|
||||
-- * TCP transport functions
|
||||
tPut,
|
||||
@@ -91,15 +104,26 @@ import Data.String
|
||||
import Data.Time.Clock
|
||||
import Data.Time.ISO8601
|
||||
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.Parsers
|
||||
import Simplex.Messaging.Transport (THandle (..), Transport, TransportError (..), tGetBlock, tPutBlock)
|
||||
import Simplex.Messaging.Util
|
||||
import Test.QuickCheck (Arbitrary (..))
|
||||
|
||||
clientVersion :: Word16
|
||||
clientVersion = 1
|
||||
|
||||
maxMessageLength :: Int
|
||||
maxMessageLength = 15968
|
||||
|
||||
e2eEncMessageLength :: Int
|
||||
e2eEncMessageLength = 15842
|
||||
|
||||
-- | SMP protocol participants.
|
||||
data Party = Broker | Recipient | Sender | Notifier
|
||||
deriving (Show)
|
||||
@@ -227,6 +251,59 @@ isClient = \case
|
||||
SNotifier -> Just Dict
|
||||
_ -> Nothing
|
||||
|
||||
-- | SMP message body format
|
||||
data EncMessage = EncMessage
|
||||
{ emHeader :: PubHeader,
|
||||
emNonce :: C.CbNonce,
|
||||
emBody :: ByteString
|
||||
}
|
||||
|
||||
data PubHeader = PubHeader
|
||||
{ phVersion :: Word16,
|
||||
phE2ePubDhKey :: C.PublicKeyX25519
|
||||
}
|
||||
|
||||
serializePubHeader :: PubHeader -> ByteString
|
||||
serializePubHeader (PubHeader v k) = encodeWord16 v <> C.encodeLenKey' k
|
||||
|
||||
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}
|
||||
|
||||
data ClientMessage = ClientMessage PrivHeader ByteString
|
||||
|
||||
data PrivHeader
|
||||
= PHConfirmation C.APublicVerifyKey
|
||||
| PHEmpty
|
||||
|
||||
serializePrivHeader :: PrivHeader -> ByteString
|
||||
serializePrivHeader = \case
|
||||
PHConfirmation k -> "K" <> C.encodeLenKey k
|
||||
PHEmpty -> " "
|
||||
|
||||
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
|
||||
|
||||
@@ -240,7 +317,7 @@ instance IsString CorrId where
|
||||
data QueueIdsKeys = QIK
|
||||
{ rcvId :: RecipientId,
|
||||
sndId :: SenderId,
|
||||
rcvPublicDHKey :: RcvPublicDhKey
|
||||
rcvPublicDhKey :: RcvPublicDhKey
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -253,10 +330,10 @@ type RcvPrivateSignKey = C.APrivateSignKey
|
||||
type RcvPublicVerifyKey = C.APublicVerifyKey
|
||||
|
||||
-- | Public key used for DH exchange to encrypt message bodies from server to recipient
|
||||
type RcvPublicDhKey = C.PublicKey C.X25519
|
||||
type RcvPublicDhKey = C.PublicKeyX25519
|
||||
|
||||
-- | DH Secret used to encrypt message bodies from server to recipient
|
||||
type RcvDhSecret = C.DhSecret C.X25519
|
||||
type RcvDhSecret = C.DhSecretX25519
|
||||
|
||||
-- | Sender's private key used by the recipient to authorize (sign) SMP commands.
|
||||
--
|
||||
@@ -292,6 +369,8 @@ data ErrorType
|
||||
QUOTA
|
||||
| -- | ACK command is sent without message to be acknowledged
|
||||
NO_MSG
|
||||
| -- | sent message is too large (> maxMessageLength = 15968 bytes)
|
||||
LARGE_MSG
|
||||
| -- | internal server error
|
||||
INTERNAL
|
||||
| -- | used internally, never returned by the server (to be removed)
|
||||
@@ -302,8 +381,6 @@ data ErrorType
|
||||
data CommandError
|
||||
= -- | server response sent from client or vice versa
|
||||
PROHIBITED
|
||||
| -- | bad RSA key size in NEW or KEY commands (only 1024, 2048 and 4096 bits keys are allowed)
|
||||
KEY_SIZE
|
||||
| -- | error parsing command
|
||||
SYNTAX
|
||||
| -- | transmission has no required credentials (signature or queue ID)
|
||||
@@ -322,8 +399,7 @@ instance Arbitrary CommandError where arbitrary = genericArbitraryU
|
||||
transmissionP :: Parser RawTransmission
|
||||
transmissionP = do
|
||||
signature <- segment
|
||||
len <- A.decimal <* A.space
|
||||
signed <- A.take len <* A.space
|
||||
signed <- A.takeByteString
|
||||
either fail pure $ parseAll (trn signature signed) signed
|
||||
where
|
||||
segment = A.takeTill (== ' ') <* A.space
|
||||
@@ -356,20 +432,17 @@ instance CommandI Cmd where
|
||||
<|> "ERR " *> serverError
|
||||
<|> "PONG" $> Cmd SBroker PONG
|
||||
where
|
||||
newCmd = Cmd SRecipient <$> (NEW <$> C.strKeyP <* A.space <*> C.strKeyP)
|
||||
newCmd = Cmd SRecipient <$> (NEW <$> C.strPubKeyP <* A.space <*> C.strPubKeyP)
|
||||
idsResp = Cmd SBroker . IDS <$> qik
|
||||
qik = QIK <$> base64P <* A.space <*> base64P <* A.space <*> C.strKeyP
|
||||
qik = QIK <$> base64P <* A.space <*> base64P <* A.space <*> C.strPubKeyP
|
||||
nIdsResp = Cmd SBroker . NID <$> base64P
|
||||
keyCmd = Cmd SRecipient . KEY <$> C.strKeyP
|
||||
nKeyCmd = Cmd SRecipient . NKEY <$> C.strKeyP
|
||||
sendCmd = do
|
||||
size <- A.decimal <* A.space
|
||||
Cmd SSender . SEND <$> A.take size <* A.space
|
||||
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
|
||||
size <- A.decimal <* A.space
|
||||
Cmd SBroker . MSG msgId ts <$> A.take size <* A.space
|
||||
Cmd SBroker . MSG msgId ts <$> A.takeByteString
|
||||
serverError = Cmd SBroker . ERR <$> errorTypeP
|
||||
|
||||
instance CommandI ClientCmd where
|
||||
@@ -393,20 +466,20 @@ instance PartyI p => CommandI (Command p) where
|
||||
Just Refl -> Right cmd
|
||||
_ -> Left "bad command party"
|
||||
serializeCommand = \case
|
||||
NEW rKey dhKey -> B.unwords ["NEW", C.serializeKey rKey, C.serializeKey dhKey]
|
||||
KEY sKey -> "KEY " <> C.serializeKey sKey
|
||||
NKEY nKey -> "NKEY " <> C.serializeKey nKey
|
||||
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 " <> serializeBody msgBody
|
||||
SEND msgBody -> "SEND " <> msgBody
|
||||
PING -> "PING"
|
||||
NSUB -> "NSUB"
|
||||
MSG msgId ts msgBody ->
|
||||
B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts, serializeBody msgBody]
|
||||
B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts, msgBody]
|
||||
IDS (QIK rcvId sndId srvDh) ->
|
||||
B.unwords ["IDS", encode rcvId, encode sndId, C.serializeKey srvDh]
|
||||
B.unwords ["IDS", encode rcvId, encode sndId, C.serializePubKey' srvDh]
|
||||
NID nId -> "NID " <> encode nId
|
||||
ERR err -> "ERR " <> serializeErrorType err
|
||||
NMSG -> "NMSG"
|
||||
@@ -414,9 +487,6 @@ instance PartyI p => CommandI (Command p) where
|
||||
OK -> "OK"
|
||||
PONG -> "PONG"
|
||||
|
||||
serializeBody :: ByteString -> ByteString
|
||||
serializeBody s = bshow (B.length s) <> " " <> s <> " "
|
||||
|
||||
-- | SMP error parser.
|
||||
errorTypeP :: Parser ErrorType
|
||||
errorTypeP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1
|
||||
@@ -427,7 +497,7 @@ serializeErrorType = bshow
|
||||
|
||||
-- | 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 <> " " <> serializeBody t
|
||||
tPut th (sig, t) = tPutBlock th $ C.serializeSignature sig <> " " <> t
|
||||
|
||||
serializeTransmission :: CommandI c => ByteString -> Transmission c -> ByteString
|
||||
serializeTransmission sessionId (CorrId corrId, queueId, command) =
|
||||
@@ -447,7 +517,9 @@ fromServer = \case
|
||||
|
||||
-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
|
||||
tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
|
||||
tGetParse th = first (const TEBadBlock) . A.parseOnly transmissionP <$> tGetBlock th
|
||||
tGetParse th = (parseTransmission =<<) <$> tGetBlock th
|
||||
where
|
||||
parseTransmission = first (const TEBadBlock) . A.parseOnly transmissionP
|
||||
|
||||
-- | Receive client and server transmissions.
|
||||
--
|
||||
|
||||
@@ -118,9 +118,8 @@ runSMPServerBlocking started cfg@ServerConfig {transports} = do
|
||||
atomically . stateTVar (clientSubs c) $ \ss -> (M.lookup qId ss, M.delete qId ss)
|
||||
|
||||
runClient :: (Transport c, MonadUnliftIO m, MonadReader Env m) => TProxy c -> c -> m ()
|
||||
runClient _ h = do
|
||||
ServerConfig {blockSize} <- asks config
|
||||
liftIO (runExceptT $ serverHandshake h blockSize) >>= \case
|
||||
runClient _ h =
|
||||
liftIO (runExceptT $ serverHandshake h) >>= \case
|
||||
Right th -> runClientTransport th
|
||||
Left _ -> pure ()
|
||||
|
||||
@@ -202,12 +201,6 @@ verifyTransmission sig_ signed queueId cmd = do
|
||||
-- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes
|
||||
dummyPublicKey :: C.Signature a -> C.PublicKey a
|
||||
dummyPublicKey = \case
|
||||
C.SignatureRSA s' -> case B.length s' of
|
||||
128 -> dummyKey128
|
||||
256 -> dummyKey256
|
||||
384 -> dummyKey384
|
||||
512 -> dummyKey512
|
||||
_ -> dummyKey256
|
||||
C.SignatureEd25519 _ -> dummyKeyEd25519
|
||||
C.SignatureEd448 _ -> dummyKeyEd448
|
||||
|
||||
@@ -217,18 +210,6 @@ dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs="
|
||||
dummyKeyEd448 :: C.PublicKey 'C.Ed448
|
||||
dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
|
||||
|
||||
dummyKey128 :: C.PublicKey 'C.RSA
|
||||
dummyKey128 = "MIIBIDANBgkqhkiG9w0BAQEFAAOCAQ0AMIIBCAKBgQC2oeA7s4roXN5K2N6022I1/2CTeMKjWH0m00bSZWa4N8LDKeFcShh8YUxZea5giAveViTRNOOVLgcuXbKvR3u24szN04xP0+KnYUuUUIIoT3YSjX0IlomhDhhSyup4BmA0gAZ+D1OaIKZFX6J8yQ1Lr/JGLEfSRsBjw8l+4hs9OwKBgQDKA+YlZvGb3BcpDwKmatiCXN7ZRDWkjXbj8VAW5zV95tSRCCVN48hrFM1H4Ju2QMMUc6kPUVX+eW4ZjdCl5blIqIHMcTmsdcmsDDCg3PjUNrwc6bv/1TcirbAKcmnKt9iurIt6eerxSO7TZUXXMUVsi7eRwb/RUNhpCrpJ/hpIOw=="
|
||||
|
||||
dummyKey256 :: C.PublicKey 'C.RSA
|
||||
dummyKey256 = "MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAxwmTvaqmdTbkfUGNi8Yu0L/T4cxuOlQlx3zGZ9X9Qx0+oZjknWK+QHrdWTcpS+zH4Hi7fP6kanOQoQ90Hj6Ghl57VU1GEdUPywSw4i1/7t0Wv9uT9Q2ktHp2rqVo3xkC9IVIpL7EZAxdRviIN2OsOB3g4a/F1ZpjxcAaZeOMUugiAX1+GtkLuE0Xn4neYjCaOghLxQTdhybN70VtnkiQLx/X9NjkDIl/spYGm3tQFMyYKkP6IWoEpj0926hJ0fmlmhy8tAOhlZsb/baW5cgkEZ3E9jVVrySCgQzoLQgma610FIISRpRJbSyv26jU7MkMxiyuBiDaFOORkXFttoKbtQKBgEbDS9II2brsz+vfI7uP8atFcawkE52cx4M1UWQhqb1H3tBiRl+qO+dMq1pPQF2bW7dlZAWYzS4W/367bTAuALHBDGB8xi1P4Njhh9vaOgTvuqrHG9NJQ85BLy0qGw8rjIWSIXVmVpfrXFJ8po5l04UE258Ll2yocv3QRQmddQW9"
|
||||
|
||||
dummyKey384 :: C.PublicKey 'C.RSA
|
||||
dummyKey384 = "MIICITANBgkqhkiG9w0BAQEFAAOCAg4AMIICCQKCAYEAthExp77lSFBMB0RedjgKIU+oNH5lMGdMqDCG0E5Ly7X49rFpfDMMN08GDIgvzg9kcwV3ScbPcjUE19wmAShX9f9k3w38KM3wmIBKSiuCREQl0V3xAYp1SYwiAkMNSSwxuIkDEeSOR56WdEcZvqbB4lY9MQlUv70KriPDxZaqKCTKslUezXHQuYPQX6eMnGFK7hxz5Kl5MajV52d+5iXsa8CA+m/e1KVnbelCO+xhN89xG8ALt0CJ9k5Wwo3myLgXi4dmNankCmg8jkh+7y2ywkzxMwH1JydDtV/FLzkbZsbPR2w93TNrTq1RJOuqMyh0VtdBSpxNW/Ft988TkkX2BAWzx82INw7W6/QbHGNtHNB995R4sgeYy8QbEpNGBhQnfQh7yRWygLTVXWKApQzzfCeIoDDWUS7dMv/zXoasAnpDBj+6UhHv3BHrps7kBvRyZQ2d/nUuAqiGd43ljJ++n6vNyFLgZoiV7HLia/FOGMkdt7j92CNmFHxiT6Xl7kRHAoGBAPNoWny2O7LBxzAKMLmQVHBAiKp6RMx+7URvtQDHDHPaZ7F3MvtvmYWwGzund3cQFAaV1EkJoYeI3YRuj6xdXgMyMaP54On++btArb6jUtZuvlC98qE8dEEHQNh+7TsCiMU+ivbeKFxS9A/B7OVedoMnPoJWhatbA9zB/6L1GNPh"
|
||||
|
||||
dummyKey512 :: C.PublicKey 'C.RSA
|
||||
dummyKey512 = "MIICoDANBgkqhkiG9w0BAQEFAAOCAo0AMIICiAKCAgEArkCY9DuverJ4mmzDektv9aZMFyeRV46WZK9NsOBKEc+1ncqMs+LhLti9asKNgUBRbNzmbOe0NYYftrUpwnATaenggkTFxxbJ4JGJuGYbsEdFWkXSvrbWGtM8YUmn5RkAGme12xQ89bSM4VoJAGnrYPHwmcQd+KYCPZvTUsxaxgrJTX65ejHN9BsAn8XtGViOtHTDJO9yUMD2WrJvd7wnNa+0ugEteDLzMU++xS98VC+uA1vfauUqi3yXVchdfrLdVUuM+JE0gUEXCgzjuHkaoHiaGNiGhdPYoAJJdOKQOIHAKdk7Th6OPhirPhc9XYNB4O8JDthKhNtfokvFIFlC4QBRzJhpLIENaEBDt08WmgpOnecZB/CuxkqqOrNa8j5K5jNrtXAI67W46VEC2jeQy/gZwb64Zit2A4D00xXzGbQTPGj4ehcEMhLx5LSCygViEf0w0tN3c3TEyUcgPzvECd2ZVpQLr9Z4a07Ebr+YSuxcHhjg4Rg1VyJyOTTvaCBGm5X2B3+tI4NUttmikIHOYpBnsLmHY2BgfH2KcrIsDyAhInXmTFr/L2+erFarUnlfATd2L8Ti43TNHDedO6k6jI5Gyi62yPwjqPLEIIK8l+pIeNfHJ3pPmjhHBfzFcQLMMMXffHWNK8kWklrQXK+4j4HiPcTBvlO1FEtG9nEIZhUCgYA4a6WtI2k5YNli1C89GY5rGUY7RP71T6RWri/D3Lz9T7GvU+FemAyYmsvCQwqijUOur0uLvwSP8VdxpSUcrjJJSWur2hrPWzWlu0XbNaeizxpFeKbQP+zSrWJ1z8RwfAeUjShxt8q1TuqGqY10wQyp3nyiTGvS+KwZVj5h5qx8NQ=="
|
||||
|
||||
client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
|
||||
client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
|
||||
forever $
|
||||
@@ -256,10 +237,10 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
|
||||
DEL -> delQueueAndMsgs st
|
||||
where
|
||||
createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m BrokerTransmission
|
||||
createQueue st recipientKey dhKey = checkKeySize recipientKey $ do
|
||||
(rcvPublicDHKey, privDhKey) <- liftIO $ C.generateKeyPair' 0
|
||||
createQueue st recipientKey dhKey = do
|
||||
(rcvPublicDhKey, privDhKey) <- liftIO C.generateKeyPair'
|
||||
let rcvDhSecret = C.dh' dhKey privDhKey
|
||||
qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDHKey}
|
||||
qik (rcvId, sndId) = QIK {rcvId, sndId, rcvPublicDhKey}
|
||||
qRec (recipientId, senderId) =
|
||||
QueueRec
|
||||
{ recipientId,
|
||||
@@ -270,7 +251,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
|
||||
notifier = Nothing,
|
||||
status = QueueActive
|
||||
}
|
||||
addQueueRetry 3 qik qRec
|
||||
(corrId,queueId,) <$> addQueueRetry 3 qik qRec
|
||||
where
|
||||
addQueueRetry ::
|
||||
Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> ((RecipientId, SenderId) -> QueueRec) -> m (Command 'Broker)
|
||||
@@ -299,10 +280,10 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
|
||||
secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m BrokerTransmission
|
||||
secureQueue_ st sKey = do
|
||||
withLog $ \s -> logSecureQueue s queueId sKey
|
||||
atomically . checkKeySize sKey $ either ERR (const OK) <$> secureQueue st queueId sKey
|
||||
atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey
|
||||
|
||||
addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m BrokerTransmission
|
||||
addQueueNotifier_ st nKey = checkKeySize nKey $ addNotifierRetry 3
|
||||
addQueueNotifier_ st nKey = (corrId,queueId,) <$> addNotifierRetry 3
|
||||
where
|
||||
addNotifierRetry :: Int -> m (Command 'Broker)
|
||||
addNotifierRetry 0 = pure $ ERR INTERNAL
|
||||
@@ -315,13 +296,6 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
|
||||
withLog $ \s -> logAddNotifier s queueId nId nKey
|
||||
pure $ NID nId
|
||||
|
||||
checkKeySize :: Monad m' => C.APublicVerifyKey -> m' (Command 'Broker) -> m' BrokerTransmission
|
||||
checkKeySize key action =
|
||||
(corrId,queueId,)
|
||||
<$> if C.validKeySize key
|
||||
then action
|
||||
else pure . ERR $ CMD KEY_SIZE
|
||||
|
||||
suspendQueue_ :: QueueStore -> m BrokerTransmission
|
||||
suspendQueue_ st = do
|
||||
withLog (`logDeleteQueue` queueId)
|
||||
@@ -361,30 +335,34 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscri
|
||||
withSub rId f = readTVar subscriptions >>= mapM f . M.lookup rId
|
||||
|
||||
sendMessage :: QueueStore -> MsgBody -> m BrokerTransmission
|
||||
sendMessage st msgBody = do
|
||||
qr <- atomically $ getQueue st (CP SSender) queueId
|
||||
either (return . err) storeMessage qr
|
||||
sendMessage st msgBody
|
||||
| B.length msgBody > maxMessageLength = pure $ err LARGE_MSG
|
||||
| otherwise = do
|
||||
qr <- atomically $ getQueue st (CP SSender) queueId
|
||||
either (return . err) storeMessage qr
|
||||
where
|
||||
storeMessage :: QueueRec -> m BrokerTransmission
|
||||
storeMessage qr = case status qr of
|
||||
QueueOff -> return $ err AUTH
|
||||
QueueActive -> do
|
||||
ms <- asks msgStore
|
||||
msg <- mkMessage
|
||||
quota <- asks $ msgQueueQuota . config
|
||||
atomically $ do
|
||||
q <- getMsgQueue ms (recipientId qr) quota
|
||||
ifM (isFull q) (pure $ err QUOTA) $ do
|
||||
trySendNotification
|
||||
writeMsg q msg
|
||||
pure ok
|
||||
QueueActive ->
|
||||
mkMessage >>= \case
|
||||
Left _ -> pure $ err LARGE_MSG
|
||||
Right msg -> do
|
||||
ms <- asks msgStore
|
||||
quota <- asks $ msgQueueQuota . config
|
||||
atomically $ do
|
||||
q <- getMsgQueue ms (recipientId qr) quota
|
||||
ifM (isFull q) (pure $ err QUOTA) $ do
|
||||
trySendNotification
|
||||
writeMsg q msg
|
||||
pure ok
|
||||
where
|
||||
mkMessage :: m Message
|
||||
mkMessage :: m (Either C.CryptoError Message)
|
||||
mkMessage = do
|
||||
msgId <- randomId =<< asks (msgIdBytes . config)
|
||||
ts <- liftIO getCurrentTime
|
||||
let c = C.cbEncrypt (rcvDhSecret qr) (C.cbNonce msgId) msgBody
|
||||
return $ Message {msgId, ts, msgBody = c}
|
||||
let c = C.cbEncrypt (rcvDhSecret qr) (C.cbNonce msgId) msgBody (maxMessageLength + 2)
|
||||
pure $ Message msgId ts <$> c
|
||||
|
||||
trySendNotification :: STM ()
|
||||
trySendNotification =
|
||||
|
||||
@@ -31,7 +31,6 @@ data ServerConfig = ServerConfig
|
||||
queueIdBytes :: Int,
|
||||
msgIdBytes :: Int,
|
||||
storeLog :: Maybe (StoreLog 'ReadMode),
|
||||
blockSize :: Int,
|
||||
caCertificateFile :: FilePath,
|
||||
serverPrivateKeyFile :: FilePath,
|
||||
serverCertificateFile :: FilePath
|
||||
|
||||
@@ -62,36 +62,36 @@ storeLogRecordP =
|
||||
<|> "DELETE " *> (DeleteQueue <$> base64P)
|
||||
where
|
||||
createQueueP = CreateQueue <$> queueRecP
|
||||
secureQueueP = SecureQueue <$> base64P <* A.space <*> C.strKeyP
|
||||
secureQueueP = SecureQueue <$> base64P <* A.space <*> C.strPubKeyP
|
||||
addNotifierP =
|
||||
AddNotifier <$> base64P <* A.space <*> base64P <* A.space <*> C.strKeyP
|
||||
AddNotifier <$> base64P <* A.space <*> base64P <* A.space <*> C.strPubKeyP
|
||||
queueRecP = do
|
||||
recipientId <- "rid=" *> base64P
|
||||
recipientKey <- " rk=" *> C.strKeyP
|
||||
recipientKey <- " rk=" *> C.strPubKeyP
|
||||
rcvDhSecret <- " rdh=" *> C.strDhSecretP
|
||||
senderId <- " sid=" *> base64P
|
||||
senderKey <- " sk=" *> optional C.strKeyP
|
||||
notifier <- optional $ (,) <$> (" nid=" *> base64P) <*> (" nk=" *> C.strKeyP)
|
||||
senderKey <- " sk=" *> optional C.strPubKeyP
|
||||
notifier <- optional $ (,) <$> (" nid=" *> base64P) <*> (" nk=" *> C.strPubKeyP)
|
||||
pure QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier, status = QueueActive}
|
||||
|
||||
serializeStoreLogRecord :: StoreLogRecord -> ByteString
|
||||
serializeStoreLogRecord = \case
|
||||
CreateQueue q -> "CREATE " <> serializeQueue q
|
||||
SecureQueue rId sKey -> "SECURE " <> encode rId <> " " <> C.serializeKey sKey
|
||||
AddNotifier rId nId nKey -> B.unwords ["NOTIFIER", encode rId, encode nId, C.serializeKey nKey]
|
||||
SecureQueue rId sKey -> "SECURE " <> encode rId <> " " <> C.serializePubKey sKey
|
||||
AddNotifier rId nId nKey -> B.unwords ["NOTIFIER", encode rId, encode nId, C.serializePubKey nKey]
|
||||
DeleteQueue rId -> "DELETE " <> encode rId
|
||||
where
|
||||
serializeQueue
|
||||
QueueRec {recipientId, recipientKey, rcvDhSecret, senderId, senderKey, notifier} =
|
||||
B.unwords
|
||||
[ "rid=" <> encode recipientId,
|
||||
"rk=" <> C.serializeKey recipientKey,
|
||||
"rk=" <> C.serializePubKey recipientKey,
|
||||
"rdh=" <> C.serializeDhSecret rcvDhSecret,
|
||||
"sid=" <> encode senderId,
|
||||
"sk=" <> maybe "" C.serializeKey senderKey
|
||||
"sk=" <> maybe "" C.serializePubKey senderKey
|
||||
]
|
||||
<> maybe "" serializeNotifier notifier
|
||||
serializeNotifier (nId, nKey) = " nid=" <> encode nId <> " nk=" <> C.serializeKey nKey
|
||||
serializeNotifier (nId, nKey) = " nid=" <> encode nId <> " nk=" <> C.serializePubKey nKey
|
||||
|
||||
openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode)
|
||||
openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode
|
||||
|
||||
@@ -25,7 +25,10 @@
|
||||
--
|
||||
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
|
||||
module Simplex.Messaging.Transport
|
||||
( -- * Transport connection class
|
||||
( -- * SMP transport parameters
|
||||
smpBlockSize,
|
||||
|
||||
-- * Transport connection class
|
||||
Transport (..),
|
||||
TProxy (..),
|
||||
ATransport (..),
|
||||
@@ -67,6 +70,7 @@ 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
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
@@ -97,6 +101,9 @@ import UnliftIO.Exception (Exception, IOException)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
|
||||
smpBlockSize :: Int
|
||||
smpBlockSize = 16384
|
||||
|
||||
-- * Transport connection class
|
||||
|
||||
class Transport c where
|
||||
@@ -395,8 +402,7 @@ smpVersionP =
|
||||
-- | The handle for SMP encrypted transport connection over Transport .
|
||||
data THandle c = THandle
|
||||
{ connection :: c,
|
||||
sessionId :: ByteString,
|
||||
blockSize :: Int
|
||||
sessionId :: ByteString
|
||||
}
|
||||
|
||||
data Handshake = Handshake
|
||||
@@ -453,25 +459,23 @@ serializeTransportError = \case
|
||||
|
||||
-- | Pad and send block to SMP transport.
|
||||
tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ())
|
||||
tPutBlock THandle {connection = c, blockSize} block
|
||||
| len > blockSize = pure $ Left TELargeMsg
|
||||
| otherwise = Right <$> cPut c (block <> B.replicate (blockSize - len) '#')
|
||||
where
|
||||
len = B.length block
|
||||
tPutBlock THandle {connection = c} block =
|
||||
bimapM (const $ pure TELargeMsg) (cPut c) $
|
||||
C.pad block smpBlockSize
|
||||
|
||||
-- | Receive block from SMP transport.
|
||||
tGetBlock :: Transport c => THandle c -> IO ByteString
|
||||
tGetBlock THandle {connection = c, blockSize} =
|
||||
cGet c blockSize >>= \case
|
||||
tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString)
|
||||
tGetBlock THandle {connection = c} =
|
||||
cGet c smpBlockSize >>= \case
|
||||
"" -> ioe_EOF
|
||||
msg -> pure msg
|
||||
msg -> pure . first (const TELargeMsg) $ C.unPad msg
|
||||
|
||||
-- | Server SMP transport handshake.
|
||||
--
|
||||
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
|
||||
serverHandshake :: Transport c => c -> Int -> ExceptT TransportError IO (THandle c)
|
||||
serverHandshake c blockSize = do
|
||||
let th@THandle {sessionId} = tHandle c blockSize
|
||||
serverHandshake :: Transport c => c -> ExceptT TransportError IO (THandle c)
|
||||
serverHandshake c = do
|
||||
let th@THandle {sessionId} = tHandle c
|
||||
_ <- getPeerHello th
|
||||
sendHelloToPeer th sessionId
|
||||
pure th
|
||||
@@ -479,9 +483,9 @@ serverHandshake c blockSize = do
|
||||
-- | Client SMP transport handshake.
|
||||
--
|
||||
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
|
||||
clientHandshake :: forall c. Transport c => c -> Int -> ExceptT TransportError IO (THandle c)
|
||||
clientHandshake c blockSize = do
|
||||
let th@THandle {sessionId} = tHandle c blockSize
|
||||
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
|
||||
if sessionId == sessId
|
||||
@@ -494,11 +498,11 @@ sendHelloToPeer th sessionId =
|
||||
in ExceptT . tPutBlock th $ serializeHandshake handshake
|
||||
|
||||
getPeerHello :: Transport c => THandle c -> ExceptT TransportError IO Handshake
|
||||
getPeerHello th = ExceptT $ parseHandshake <$> tGetBlock th
|
||||
getPeerHello th = ExceptT $ (parseHandshake =<<) <$> tGetBlock th
|
||||
where
|
||||
parseHandshake :: ByteString -> Either TransportError Handshake
|
||||
parseHandshake = first (const $ TEHandshake PARSE) . A.parseOnly handshakeP
|
||||
|
||||
tHandle :: Transport c => c -> Int -> THandle c
|
||||
tHandle c blockSize =
|
||||
THandle {connection = c, sessionId = encode $ tlsUnique c, blockSize}
|
||||
tHandle :: Transport c => c -> THandle c
|
||||
tHandle c =
|
||||
THandle {connection = c, sessionId = encode $ tlsUnique c}
|
||||
|
||||
+13
-3
@@ -14,8 +14,6 @@ import AgentTests.DoubleRatchetTests (doubleRatchetTests)
|
||||
import AgentTests.FunctionalAPITests (functionalAPITests)
|
||||
import AgentTests.SQLiteTests (storeTests)
|
||||
import Control.Concurrent
|
||||
import Data.ByteString.Base64 (decodeLenient)
|
||||
import qualified Data.ByteString.Base64.URL as U
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Network.HTTP.Types (urlEncode)
|
||||
@@ -354,6 +352,9 @@ connect (h1, name1) (h2, name2) = do
|
||||
samplePublicKey :: ByteString
|
||||
samplePublicKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj-toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP-Tm4sokaFDTIG3QJFzOjC-_9nW4MUjAOFll9PCp9kaEFHJ_YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju_f6kAayvYKW3_lbJNXCmyinAccBosO08_0sUxvtuniIo18kfYJE0UmP1ReCjhMP-O-yOmwZJini_QelJk_Pez8IIDDWnY1qYQsN_q7ocjakOYrpGG7mig6JMFpDJtD6istR"
|
||||
|
||||
sampleDhKey :: ByteString
|
||||
sampleDhKey = "x25519:MCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
|
||||
|
||||
syntaxTests :: forall c. Transport c => TProxy c -> Spec
|
||||
syntaxTests t = do
|
||||
it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX")
|
||||
@@ -370,7 +371,16 @@ syntaxTests t = do
|
||||
-- TODO: ERROR no connection alias in the response (it does not generate it yet if not provided)
|
||||
-- TODO: add tests with defined connection alias
|
||||
it "using same server as in invitation" $
|
||||
("311", "a", "JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2F" <> (U.encode . decodeLenient) "9VjLsOY5ZvB4hoglNdBzJFAUi/vP4GkZnJFahQOXV20=" <> "%40localhost%3A5001%2F3456-w%3D%3D%23&e2e=" <> urlEncode True samplePublicKey <> " 14\nbob's connInfo")
|
||||
( "311",
|
||||
"a",
|
||||
"JOIN https://simpex.chat/invitation#/?smp=smp%3A%2F%2F"
|
||||
<> urlEncode True "9VjLsOY5ZvB4hoglNdBzJFAUi_vP4GkZnJFahQOXV20="
|
||||
<> "%40localhost%3A5001%2F3456-w%3D%3D%23"
|
||||
<> urlEncode True sampleDhKey
|
||||
<> "&e2e="
|
||||
<> urlEncode True samplePublicKey
|
||||
<> " 14\nbob's connInfo"
|
||||
)
|
||||
>#> ("311", "a", "ERR SMP AUTH")
|
||||
describe "invalid" $ do
|
||||
-- TODO: JOIN is not merged yet - to be added
|
||||
|
||||
@@ -1,9 +1,11 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module AgentTests.ConnectionRequestTests where
|
||||
|
||||
import qualified Crypto.PubKey.RSA as R
|
||||
import Data.ByteString (ByteString)
|
||||
import Network.HTTP.Types (urlEncode)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
@@ -24,9 +26,19 @@ queue :: SMPQueueUri
|
||||
queue =
|
||||
SMPQueueUri
|
||||
{ smpServer = srv,
|
||||
senderId = "\223\142z\251"
|
||||
senderId = "\223\142z\251",
|
||||
dhPublicKey = testDhKey
|
||||
}
|
||||
|
||||
testDhKey :: C.PublicKeyX25519
|
||||
testDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
|
||||
|
||||
testDhKeyStr :: ByteString
|
||||
testDhKeyStr = C.serializePubKeyUri' testDhKey
|
||||
|
||||
testDhKeyStrUri :: ByteString
|
||||
testDhKeyStrUri = urlEncode True testDhKeyStr
|
||||
|
||||
appServer :: ConnReqScheme
|
||||
appServer = CRSAppServer "simplex.chat" Nothing
|
||||
|
||||
@@ -36,7 +48,7 @@ connectionRequest =
|
||||
ConnReqData
|
||||
{ crScheme = appServer,
|
||||
crSmpQueues = [queue],
|
||||
crEncryptKey = C.APublicEncryptKey C.SRSA (C.PublicKeyRSA $ R.PublicKey 1 0 0)
|
||||
crEncryption = ConnectionEncryption
|
||||
}
|
||||
|
||||
connectionRequestTests :: Spec
|
||||
@@ -44,17 +56,24 @@ connectionRequestTests =
|
||||
describe "connection request parsing / serializing" $ do
|
||||
it "should serialize SMP queue URIs" $ do
|
||||
serializeSMPQueueUri queue {smpServer = srv {port = Nothing}}
|
||||
`shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#"
|
||||
`shouldBe` "smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr
|
||||
serializeSMPQueueUri queue
|
||||
`shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#"
|
||||
`shouldBe` "smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr
|
||||
it "should parse SMP queue URIs" $ do
|
||||
parseAll smpQueueUriP "smp://1234-w==@smp.simplex.im/3456-w==#"
|
||||
parseAll smpQueueUriP ("smp://1234-w==@smp.simplex.im/3456-w==#" <> testDhKeyStr)
|
||||
`shouldBe` Right queue {smpServer = srv {port = Nothing}}
|
||||
parseAll smpQueueUriP "smp://1234-w==@smp.simplex.im:5223/3456-w==#"
|
||||
parseAll smpQueueUriP ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr)
|
||||
`shouldBe` Right queue
|
||||
it "should serialize connection requests" $ do
|
||||
serializeConnReq connectionRequest
|
||||
`shouldBe` "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23&e2e=rsa%3AMBowDQYJKoZIhvcNAQEBBQADCQAwBgIBAAIBAA%3D%3D"
|
||||
`shouldBe` "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
|
||||
<> testDhKeyStrUri
|
||||
<> "&e2e="
|
||||
it "should parse connection requests" $ do
|
||||
parseAll connReqP "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23&e2e=rsa%3AMBowDQYJKoZIhvcNAQEBBQADCQAwBgIBAAIBAA%3D%3D"
|
||||
parseAll
|
||||
connReqP
|
||||
( "https://simplex.chat/invitation#/?smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23"
|
||||
<> testDhKeyStrUri
|
||||
<> "&e2e="
|
||||
)
|
||||
`shouldBe` Right connectionRequest
|
||||
|
||||
@@ -43,8 +43,8 @@ fullMsgLen = fullHeaderLen + paddedMsgLen + C.authTagSize
|
||||
|
||||
testMessageHeader :: Expectation
|
||||
testMessageHeader = do
|
||||
(k, _) <- C.generateKeyPair' @X25519 0
|
||||
let hdr = MsgHeader {msgVersion = 1, msgLatestVersion = 1, msgDHRs = k, msgPN = 0, msgNs = 0, msgLen = 11}
|
||||
(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
|
||||
|
||||
pattern Decrypted :: ByteString -> Either CryptoError (Either CryptoError ByteString)
|
||||
@@ -152,8 +152,8 @@ withRatchets test = do
|
||||
initRatchets :: (AlgorithmI a, DhAlgorithm a) => IO (Ratchet a, Ratchet a)
|
||||
initRatchets = do
|
||||
salt <- getRandomBytes 16
|
||||
(ak, apk) <- C.generateKeyPair' 0
|
||||
(bk, bpk) <- C.generateKeyPair' 0
|
||||
(ak, apk) <- C.generateKeyPair'
|
||||
(bk, bpk) <- C.generateKeyPair'
|
||||
bob <- initSndRatchet' ak bpk salt "bob -> alice"
|
||||
alice <- initRcvRatchet' bk (ak, apk) salt "bob -> alice"
|
||||
pure (alice, bob)
|
||||
|
||||
@@ -12,7 +12,6 @@ import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (replicateM_)
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import qualified Crypto.PubKey.RSA as R
|
||||
import Crypto.Random (drgNew)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.Text as T
|
||||
@@ -150,38 +149,17 @@ cData1 :: ConnData
|
||||
cData1 = ConnData {connId = "conn1"}
|
||||
|
||||
testPrivateSignKey :: C.APrivateSignKey
|
||||
testPrivateSignKey = C.APrivateSignKey C.SRSA testPrivateKey
|
||||
testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
|
||||
|
||||
testPrivateDecryptKey :: C.APrivateDecryptKey
|
||||
testPrivateDecryptKey = C.APrivateDecryptKey C.SRSA testPrivateKey
|
||||
testPubDhKey :: C.PublicKeyX25519
|
||||
testPubDhKey = "MCowBQYDK2VuAyEAjiswwI3O/NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o="
|
||||
|
||||
testPublicEncryptKey :: C.APublicEncryptKey
|
||||
testPublicEncryptKey = C.APublicEncryptKey C.SRSA testPublicKey
|
||||
testPrivDhKey :: C.PrivateKeyX25519
|
||||
testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk"
|
||||
|
||||
testPublicKey :: C.PublicKey 'C.RSA
|
||||
testPublicKey = C.PublicKeyRSA $ R.PublicKey 1 2 3
|
||||
|
||||
testDhSecret :: C.DhSecret 'C.X25519
|
||||
testDhSecret :: C.DhSecretX25519
|
||||
testDhSecret = "01234567890123456789012345678901"
|
||||
|
||||
testPrivateKey :: C.PrivateKey 'C.RSA
|
||||
testPrivateKey =
|
||||
C.PrivateKeyRSA
|
||||
R.PrivateKey
|
||||
{ private_pub =
|
||||
R.PublicKey
|
||||
{ public_size = 1,
|
||||
public_n = 2,
|
||||
public_e = 0
|
||||
},
|
||||
private_d = 3,
|
||||
private_p = 0,
|
||||
private_q = 0,
|
||||
private_dP = 0,
|
||||
private_dQ = 0,
|
||||
private_qinv = 0
|
||||
}
|
||||
|
||||
rcvQueue1 :: RcvQueue
|
||||
rcvQueue1 =
|
||||
RcvQueue
|
||||
@@ -189,9 +167,9 @@ rcvQueue1 =
|
||||
rcvId = "1234",
|
||||
rcvPrivateKey = testPrivateSignKey,
|
||||
rcvDhSecret = testDhSecret,
|
||||
e2ePrivKey = testPrivDhKey,
|
||||
e2eShared = Nothing,
|
||||
sndId = Just "2345",
|
||||
decryptKey = testPrivateDecryptKey,
|
||||
verifyKey = Nothing,
|
||||
status = New
|
||||
}
|
||||
|
||||
@@ -201,8 +179,8 @@ sndQueue1 =
|
||||
{ server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,
|
||||
sndId = "3456",
|
||||
sndPrivateKey = testPrivateSignKey,
|
||||
encryptKey = testPublicEncryptKey,
|
||||
signKey = testPrivateSignKey,
|
||||
e2ePubKey = testPubDhKey,
|
||||
e2eDhSecret = testDhSecret,
|
||||
status = New
|
||||
}
|
||||
|
||||
@@ -341,8 +319,8 @@ testUpgradeRcvConnToDuplex =
|
||||
{ server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,
|
||||
sndId = "2345",
|
||||
sndPrivateKey = testPrivateSignKey,
|
||||
encryptKey = testPublicEncryptKey,
|
||||
signKey = testPrivateSignKey,
|
||||
e2ePubKey = testPubDhKey,
|
||||
e2eDhSecret = testDhSecret,
|
||||
status = New
|
||||
}
|
||||
upgradeRcvConnToDuplex store "conn1" anotherSndQueue
|
||||
@@ -362,9 +340,9 @@ testUpgradeSndConnToDuplex =
|
||||
rcvId = "3456",
|
||||
rcvPrivateKey = testPrivateSignKey,
|
||||
rcvDhSecret = testDhSecret,
|
||||
e2ePrivKey = testPrivDhKey,
|
||||
e2eShared = Nothing,
|
||||
sndId = Just "4567",
|
||||
decryptKey = testPrivateDecryptKey,
|
||||
verifyKey = Nothing,
|
||||
status = New
|
||||
}
|
||||
upgradeSndConnToDuplex store "conn1" anotherRcvQueue
|
||||
@@ -440,7 +418,7 @@ mkRcvMsgData internalId internalRcvId externalSndId brokerId internalHash =
|
||||
MsgMeta
|
||||
{ integrity = MsgOk,
|
||||
recipient = (unId internalId, ts),
|
||||
sender = (externalSndId, ts),
|
||||
sndMsgId = externalSndId,
|
||||
broker = (brokerId, ts)
|
||||
},
|
||||
msgBody = hw,
|
||||
@@ -474,7 +452,7 @@ mkSndMsgData internalId internalSndId internalHash =
|
||||
internalTs = ts,
|
||||
msgBody = hw,
|
||||
internalHash,
|
||||
previousMsgHash = internalHash
|
||||
prevMsgHash = internalHash
|
||||
}
|
||||
|
||||
testCreateSndMsg' :: SQLiteStore -> PrevSndMsgHash -> ConnId -> SndMsgData -> Expectation
|
||||
|
||||
+1
-5
@@ -40,9 +40,6 @@ testPort2 = "5002"
|
||||
testKeyHashStr :: ByteString
|
||||
testKeyHashStr = "9VjLsOY5ZvB4hoglNdBzJFAUi/vP4GkZnJFahQOXV20="
|
||||
|
||||
testBlockSize :: Int
|
||||
testBlockSize = 16 * 1024 -- TODO move to Protocol
|
||||
|
||||
testKeyHash :: Maybe C.KeyHash
|
||||
testKeyHash = Just "9VjLsOY5ZvB4hoglNdBzJFAUi/vP4GkZnJFahQOXV20="
|
||||
|
||||
@@ -52,7 +49,7 @@ testStoreLogFile = "tests/tmp/smp-server-store.log"
|
||||
testSMPClient :: (Transport c, MonadUnliftIO m) => (THandle c -> m a) -> m a
|
||||
testSMPClient client =
|
||||
runTransportClient testHost testPort testKeyHash $ \h ->
|
||||
liftIO (runExceptT $ clientHandshake h testBlockSize) >>= \case
|
||||
liftIO (runExceptT $ clientHandshake h) >>= \case
|
||||
Right th -> client th
|
||||
Left e -> error $ show e
|
||||
|
||||
@@ -66,7 +63,6 @@ cfg =
|
||||
queueIdBytes = 24,
|
||||
msgIdBytes = 24,
|
||||
storeLog = Nothing,
|
||||
blockSize = testBlockSize,
|
||||
caCertificateFile = "tests/fixtures/ca.crt",
|
||||
serverPrivateKeyFile = "tests/fixtures/server.key",
|
||||
serverCertificateFile = "tests/fixtures/server.crt"
|
||||
|
||||
+84
-108
@@ -69,13 +69,13 @@ testCreateSecure :: ATransport -> Spec
|
||||
testCreateSecure (ATransport t) =
|
||||
it "should create (NEW) and secure (KEY) queue" $
|
||||
smpTest t $ \h -> do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair 0 C.SEd448
|
||||
(dhPub, dhPriv :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub])
|
||||
let dec = C.cbDecrypt $ C.dh' srvDh dhPriv
|
||||
(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])
|
||||
let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)
|
||||
(rId1, "") #== "creates queue"
|
||||
|
||||
Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5 hello ")
|
||||
Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND hello")
|
||||
(ok1, OK) #== "accepts unsigned SEND"
|
||||
(sId1, sId) #== "same queue ID in response 1"
|
||||
|
||||
@@ -88,12 +88,12 @@ testCreateSecure (ATransport t) =
|
||||
Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, "ACK")
|
||||
(err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages"
|
||||
|
||||
(sPub, sKey) <- C.generateSignatureKeyPair 0 C.SEd448
|
||||
Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND 5 hello ")
|
||||
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd448
|
||||
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.serializeKey sPub
|
||||
let keyCmd = "KEY " <> C.serializePubKey sPub
|
||||
Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, keyCmd)
|
||||
(err2, ERR AUTH) #== "rejects KEY with wrong signature"
|
||||
|
||||
@@ -107,7 +107,7 @@ testCreateSecure (ATransport t) =
|
||||
Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, keyCmd)
|
||||
(err4, ERR AUTH) #== "rejects KEY if already secured"
|
||||
|
||||
Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, "SEND 11 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
|
||||
@@ -116,27 +116,27 @@ testCreateSecure (ATransport t) =
|
||||
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 5 hello ")
|
||||
Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, "SEND hello")
|
||||
(err5, ERR AUTH) #== "rejects unsigned SEND"
|
||||
|
||||
testCreateDelete :: ATransport -> Spec
|
||||
testCreateDelete (ATransport t) =
|
||||
it "should create (NEW), suspend (OFF) and delete (DEL) queue" $
|
||||
smpTest2 t $ \rh sh -> do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair 0 C.SEd25519
|
||||
(dhPub, dhPriv :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0
|
||||
Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub])
|
||||
let dec = C.cbDecrypt $ C.dh' srvDh dhPriv
|
||||
(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])
|
||||
let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)
|
||||
(rId1, "") #== "creates queue"
|
||||
|
||||
(sPub, sKey) <- C.generateSignatureKeyPair 0 C.SEd25519
|
||||
Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializeKey sPub)
|
||||
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializePubKey sPub)
|
||||
(ok1, OK) #== "secures queue"
|
||||
|
||||
Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 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 7 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
|
||||
@@ -152,10 +152,10 @@ testCreateDelete (ATransport t) =
|
||||
(ok3, OK) #== "suspends queue"
|
||||
(rId2, rId) #== "same queue ID in response 2"
|
||||
|
||||
Resp "dabc" _ err3 <- signSendRecv sh sKey ("dabc", sId, "SEND 5 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 5 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")
|
||||
@@ -174,10 +174,10 @@ testCreateDelete (ATransport t) =
|
||||
(ok6, OK) #== "deletes queue"
|
||||
(rId3, rId) #== "same queue ID in response 3"
|
||||
|
||||
Resp "cdab" _ err7 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 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 5 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")
|
||||
@@ -193,10 +193,10 @@ stressTest :: ATransport -> Spec
|
||||
stressTest (ATransport t) =
|
||||
it "should create many queues, disconnect and re-connect" $
|
||||
smpTest3 t $ \h1 h2 h3 -> do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair 0 C.SEd25519
|
||||
(dhPub, _ :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0
|
||||
(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.serializeKey rPub, C.serializeKey dhPub])
|
||||
Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", B.unwords ["NEW", C.serializePubKey rPub, C.serializePubKey dhPub])
|
||||
pure rId
|
||||
let subscribeQueues h = forM_ rIds $ \rId -> do
|
||||
Resp "" rId' OK <- signSendRecv h rKey ("", rId, "SUB")
|
||||
@@ -210,26 +210,26 @@ testDuplex :: ATransport -> Spec
|
||||
testDuplex (ATransport t) =
|
||||
it "should create 2 simplex connections and exchange messages" $
|
||||
smpTest2 t $ \alice bob -> do
|
||||
(arPub, arKey) <- C.generateSignatureKeyPair 0 C.SEd448
|
||||
(aDhPub, aDhPriv :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0
|
||||
Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", B.unwords ["NEW", C.serializeKey arPub, C.serializeKey aDhPub])
|
||||
let aDec = C.cbDecrypt $ C.dh' aSrvDh aDhPriv
|
||||
(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])
|
||||
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 0 C.SEd448
|
||||
Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, cmdSEND $ "key " <> C.serializeKey bsPub)
|
||||
(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 "" _ (MSG mId1 _ msg1) <- tGet fromServer alice
|
||||
Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK")
|
||||
Right ["key", bobKey] <- pure $ B.words <$> aDec mId1 msg1
|
||||
(bobKey, C.serializeKey bsPub) #== "key received from Bob"
|
||||
(bobKey, C.serializePubKey bsPub) #== "key received from Bob"
|
||||
Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "KEY " <> bobKey)
|
||||
|
||||
(brPub, brKey) <- C.generateSignatureKeyPair 0 C.SEd448
|
||||
(bDhPub, bDhPriv :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0
|
||||
Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", B.unwords ["NEW", C.serializeKey brPub, C.serializeKey bDhPub])
|
||||
let bDec = C.cbDecrypt $ C.dh' bSrvDh bDhPriv
|
||||
(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])
|
||||
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
|
||||
|
||||
@@ -238,17 +238,17 @@ testDuplex (ATransport t) =
|
||||
Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2
|
||||
(bId, encode bSnd) #== "reply queue ID received from Bob"
|
||||
|
||||
(asPub, asKey) <- C.generateSignatureKeyPair 0 C.SEd448
|
||||
Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, cmdSEND $ "key " <> C.serializeKey asPub)
|
||||
(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 "" _ (MSG mId3 _ msg3) <- tGet fromServer bob
|
||||
Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, "ACK")
|
||||
Right ["key", aliceKey] <- pure $ B.words <$> bDec mId3 msg3
|
||||
(aliceKey, C.serializeKey asPub) #== "key received from Alice"
|
||||
(aliceKey, C.serializePubKey asPub) #== "key received from Alice"
|
||||
Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "KEY " <> aliceKey)
|
||||
|
||||
Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND 8 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")
|
||||
@@ -264,11 +264,11 @@ testSwitchSub :: ATransport -> Spec
|
||||
testSwitchSub (ATransport t) =
|
||||
it "should create simplex connections and switch subscription to another TCP connection" $
|
||||
smpTest3 t $ \rh1 rh2 sh -> do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair 0 C.SEd448
|
||||
(dhPub, dhPriv :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0
|
||||
Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub])
|
||||
let dec = C.cbDecrypt $ C.dh' srvDh dhPriv
|
||||
Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, "SEND 5 test1 ")
|
||||
(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])
|
||||
let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)
|
||||
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")
|
||||
(ok2, OK) #== "sent test message 2"
|
||||
@@ -285,7 +285,7 @@ testSwitchSub (ATransport t) =
|
||||
Resp "" _ end <- tGet fromServer rh1
|
||||
(end, END) #== "unsubscribed the 1st TCP connection"
|
||||
|
||||
Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND 5 test3 ")
|
||||
Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND test3")
|
||||
|
||||
Resp "" _ (MSG mId3 _ msg3) <- tGet fromServer rh2
|
||||
(dec mId3 msg3, Right "test3") #== "delivered to the 2nd TCP connection"
|
||||
@@ -303,9 +303,9 @@ testSwitchSub (ATransport t) =
|
||||
testWithStoreLog :: ATransport -> Spec
|
||||
testWithStoreLog at@(ATransport t) =
|
||||
it "should store simplex queues to log and restore them after server restart" $ do
|
||||
(sPub1, sKey1) <- C.generateSignatureKeyPair 0 C.SEd25519
|
||||
(sPub2, sKey2) <- C.generateSignatureKeyPair 0 C.SEd25519
|
||||
(nPub, nKey) <- C.generateSignatureKeyPair 0 C.SEd25519
|
||||
(sPub1, sKey1) <- C.generateSignatureKeyPair C.SEd25519
|
||||
(sPub2, sKey2) <- C.generateSignatureKeyPair C.SEd25519
|
||||
(nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
recipientId1 <- newTVarIO ""
|
||||
recipientKey1 <- newTVarIO Nothing
|
||||
dhShared1 <- newTVarIO Nothing
|
||||
@@ -315,7 +315,7 @@ 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.serializeKey nPub)
|
||||
Resp "abcd" _ (NID nId) <- signSendRecv h rKey1 ("abcd", rId1, "NKEY " <> C.serializePubKey nPub)
|
||||
atomically $ do
|
||||
writeTVar recipientId1 rId1
|
||||
writeTVar recipientKey1 $ Just rKey1
|
||||
@@ -323,16 +323,16 @@ testWithStoreLog at@(ATransport t) =
|
||||
writeTVar senderId1 sId1
|
||||
writeTVar notifierId nId
|
||||
Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, "NSUB")
|
||||
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ")
|
||||
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND hello")
|
||||
Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer h
|
||||
(C.cbDecrypt dhShared mId1 msg1, Right "hello") #== "delivered from queue 1"
|
||||
(C.cbDecrypt dhShared (C.cbNonce mId1) msg1, Right "hello") #== "delivered from queue 1"
|
||||
Resp "" _ NMSG <- tGet fromServer h1
|
||||
|
||||
(sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2
|
||||
atomically $ writeTVar senderId2 sId2
|
||||
Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, "SEND 9 hello too ")
|
||||
Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, "SEND hello too")
|
||||
Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer h
|
||||
(C.cbDecrypt dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2"
|
||||
(C.cbDecrypt dhShared2 (C.cbNonce mId2) msg2, Right "hello too") #== "delivered from queue 2"
|
||||
|
||||
Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, "DEL")
|
||||
pure ()
|
||||
@@ -342,7 +342,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 5 hello ")
|
||||
Resp "bcda" _ (ERR AUTH) <- signSendRecv h sKey1 ("bcda", sId1, "SEND hello")
|
||||
pure ()
|
||||
|
||||
withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
|
||||
@@ -353,13 +353,13 @@ testWithStoreLog at@(ATransport t) =
|
||||
sId1 <- readTVarIO senderId1
|
||||
nId <- readTVarIO notifierId
|
||||
Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, "NSUB")
|
||||
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ")
|
||||
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND hello")
|
||||
Resp "cdab" _ (MSG mId3 _ msg3) <- signSendRecv h rKey1 ("cdab", rId1, "SUB")
|
||||
(C.cbDecrypt dh1 mId3 msg3, Right "hello") #== "delivered from restored queue"
|
||||
(C.cbDecrypt dh1 (C.cbNonce mId3) msg3, Right "hello") #== "delivered from restored queue"
|
||||
Resp "" _ NMSG <- tGet fromServer h1
|
||||
-- this queue is removed - not restored
|
||||
sId2 <- readTVarIO senderId2
|
||||
Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, "SEND 9 hello too ")
|
||||
Resp "cdab" _ (ERR AUTH) <- signSendRecv h sKey2 ("cdab", sId2, "SEND hello too")
|
||||
pure ()
|
||||
|
||||
logSize `shouldReturn` 1
|
||||
@@ -381,11 +381,11 @@ testWithStoreLog at@(ATransport t) =
|
||||
|
||||
createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)
|
||||
createAndSecureQueue h sPub = do
|
||||
(rPub, rKey) <- C.generateSignatureKeyPair 0 C.SEd448
|
||||
(dhPub, dhPriv :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0
|
||||
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub])
|
||||
(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])
|
||||
let dhShared = C.dh' srvDh dhPriv
|
||||
let keyCmd = "KEY " <> C.serializeKey sPub
|
||||
let keyCmd = "KEY " <> C.serializePubKey sPub
|
||||
Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, keyCmd)
|
||||
(rId', rId) #== "same queue ID"
|
||||
pure (sId, rId, rKey, dhShared)
|
||||
@@ -398,30 +398,8 @@ testTiming (ATransport t) =
|
||||
(testSameTiming rh sh)
|
||||
[ (32, 32, 200),
|
||||
(32, 57, 100),
|
||||
(32, 128, 40),
|
||||
(32, 256, 20),
|
||||
(57, 32, 200),
|
||||
(57, 57, 100),
|
||||
(57, 128, 40),
|
||||
(57, 256, 20),
|
||||
(128, 32, 200),
|
||||
(128, 57, 100),
|
||||
(128, 128, 40),
|
||||
(128, 256, 20),
|
||||
(256, 32, 200),
|
||||
(256, 57, 100),
|
||||
(256, 128, 40),
|
||||
(256, 256, 20)
|
||||
-- (256, 384, 15),
|
||||
-- (256, 512, 10),
|
||||
-- (384, 128, 40),
|
||||
-- (384, 256, 20),
|
||||
-- (384, 384, 15),
|
||||
-- (384, 512, 10),
|
||||
-- (512, 128, 40),
|
||||
-- (512, 256, 20),
|
||||
-- (512, 384, 15),
|
||||
-- (512, 512, 10)
|
||||
(57, 57, 100)
|
||||
]
|
||||
where
|
||||
timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const
|
||||
@@ -429,28 +407,28 @@ testTiming (ATransport t) =
|
||||
testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation
|
||||
testSameTiming rh sh (goodKeySize, badKeySize, n) = do
|
||||
(rPub, rKey) <- generateKeys goodKeySize
|
||||
(dhPub, dhPriv :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0
|
||||
Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub])
|
||||
let dec = C.cbDecrypt $ C.dh' srvDh dhPriv
|
||||
(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])
|
||||
let dec nonce = C.cbDecrypt (C.dh' srvDh dhPriv) (C.cbNonce nonce)
|
||||
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.serializeKey sPub
|
||||
let keyCmd = "KEY " <> C.serializePubKey sPub
|
||||
Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, keyCmd)
|
||||
|
||||
Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, "SEND 5 hello ")
|
||||
Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, "SEND hello")
|
||||
Resp "" _ (MSG mId _ msg) <- tGet fromServer rh
|
||||
(dec mId msg, Right "hello") #== "delivered from queue"
|
||||
|
||||
runTimingTest sh badKey sId "SEND 5 hello "
|
||||
runTimingTest sh badKey sId "SEND hello"
|
||||
where
|
||||
generateKeys = \case
|
||||
32 -> C.generateSignatureKeyPair 0 C.SEd25519
|
||||
57 -> C.generateSignatureKeyPair 0 C.SEd448
|
||||
size -> C.generateSignatureKeyPair size C.SRSA
|
||||
32 -> C.generateSignatureKeyPair C.SEd25519
|
||||
57 -> C.generateSignatureKeyPair C.SEd448
|
||||
_ -> error "unsupported key size"
|
||||
runTimingTest h badKey qId cmd = do
|
||||
timeWrongKey <- timeRepeat n $ do
|
||||
Resp "cdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdab", qId, cmd)
|
||||
@@ -470,22 +448,23 @@ testTiming (ATransport t) =
|
||||
testMessageNotifications :: ATransport -> Spec
|
||||
testMessageNotifications (ATransport t) =
|
||||
it "should create simplex connection, subscribe notifier and deliver notifications" $ do
|
||||
(sPub, sKey) <- C.generateSignatureKeyPair 0 C.SEd25519
|
||||
(nPub, nKey) <- C.generateSignatureKeyPair 0 C.SEd25519
|
||||
(sPub, sKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
(nPub, nKey) <- C.generateSignatureKeyPair C.SEd25519
|
||||
smpTest4 t $ \rh sh nh1 nh2 -> do
|
||||
(sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
|
||||
Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, "NKEY " <> C.serializeKey nPub)
|
||||
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 5 hello ")
|
||||
Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, "SEND hello")
|
||||
Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer rh
|
||||
(C.cbDecrypt dhShared mId1 msg1, Right "hello") #== "delivered from queue"
|
||||
(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 11 hello again ")
|
||||
Resp "5" _ OK <- signSendRecv sh sKey ("5", sId, "SEND hello again")
|
||||
Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer rh
|
||||
(C.cbDecrypt dhShared mId2 msg2, Right "hello again") #== "delivered from queue again"
|
||||
(dec mId2 msg2, Right "hello again") #== "delivered from queue again"
|
||||
Resp "" _ NMSG <- tGet fromServer nh2
|
||||
1000 `timeout` tGet fromServer nh1 >>= \case
|
||||
Nothing -> return ()
|
||||
@@ -498,7 +477,7 @@ sampleDhPubKey :: ByteString
|
||||
sampleDhPubKey = "x25519:MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ="
|
||||
|
||||
sampleSig :: Maybe C.ASignature
|
||||
sampleSig = "gM8qn2Vx3GkhIp2hgrji9uhfXKpgtKDmc0maxdP8GvbORUxMCTlLG8Q/gNcl3pQVOzmbZqTZZfKcGDn9DaquJ3fT5D/NKdeW//d6ETE1EXsIbpENS0QsS+bKZDjpp3w3eQlfUxn4BNisp2S14CmJBm/FaiNj2fPkLqfkzZALcoY="
|
||||
sampleSig = "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA=="
|
||||
|
||||
syntaxTests :: ATransport -> Spec
|
||||
syntaxTests (ATransport t) = do
|
||||
@@ -519,13 +498,10 @@ syntaxTests (ATransport t) = do
|
||||
noParamsSyntaxTest "OFF"
|
||||
noParamsSyntaxTest "DEL"
|
||||
describe "SEND" $ do
|
||||
it "valid syntax 1" $ (sampleSig, "cdab", "12345678", "SEND 5 hello ") >#> ("", "cdab", "12345678", "ERR AUTH")
|
||||
it "valid syntax 2" $ (sampleSig, "dabc", "12345678", "SEND 11 hello there ") >#> ("", "dabc", "12345678", "ERR AUTH")
|
||||
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 5 hello ") >#> ("", "bcda", "", "ERR CMD NO_QUEUE")
|
||||
it "bad message body 1" $ (sampleSig, "cdab", "12345678", "SEND 11 hello ") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX")
|
||||
it "bad message body 2" $ (sampleSig, "dabc", "12345678", "SEND hello ") >#> ("", "dabc", "12345678", "ERR CMD SYNTAX")
|
||||
it "bigger body" $ (sampleSig, "abcd", "12345678", "SEND 4 hello ") >#> ("", "abcd", "12345678", "ERR CMD SYNTAX")
|
||||
it "no queue ID" $ (sampleSig, "bcda", "", "SEND hello") >#> ("", "bcda", "", "ERR CMD NO_QUEUE")
|
||||
describe "PING" $ do
|
||||
it "valid syntax" $ ("", "abcd", "", "PING") >#> ("", "abcd", "", "PONG")
|
||||
describe "broker response not allowed" $ do
|
||||
|
||||
Reference in New Issue
Block a user