dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-03-30 18:35:59 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #221 from simplex-chat/ep/smp-sign-encrypt

Browse Source 
SMP protocol changes: server signature keys (no signing/verification yet), recipient message bodies encryption with crypto_box
This commit is contained in:
Evgeny Poberezkin
2021-12-13 12:49:41 +00:00
committed by GitHub
parent 5f7366b7bd a3101edbb9
commit 7dba734ab8
20 changed files with 486 additions and 218 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
apps/smp-server/Main.hs
View File

@@ -42,8 +42,9 @@ serverConfig =
ServerConfig
{ tbqSize = 16,
msgQueueQuota = 256,
queueIdBytes = 12,
msgIdBytes = 6,
queueIdBytes = 24,
msgIdBytes = 24, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
trnSignAlg = C.SignAlg C.SEd448,
-- below parameters are set based on ini file /etc/opt/simplex/smp-server.ini
transports = undefined,
storeLog = undefined,
@@ -214,7 +215,7 @@ readKey IniOpts {serverKeyFile} = do
createKey :: IniOpts -> IO (C.PrivateKey 'C.RSA)
createKey IniOpts {serverKeyFile} = do
(_, pk) <- C.generateKeyPair' newKeySize C.SRSA
(_, pk) <- C.generateKeyPair' newKeySize
S.writeKeyFile S.TraditionalFormat serverKeyFile [C.privateToX509 pk]
pure pk

5
migrations/20210101_initial.sql
View File

@@ -11,8 +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,
snd_id BLOB,
rcv_srv_verify_key BLOB NOT NULL,
rcv_dh_secret BLOB NOT NULL,
snd_id BLOB NOT NULL,
snd_key BLOB,
snd_srv_verify_key BLOB NOT NULL,
decrypt_key BLOB NOT NULL,
verify_key BLOB,
status TEXT NOT NULL,

9
protocol/simplex-messaging.md
View File

@@ -425,10 +425,11 @@ x509encoded = <base64 X509 key encoding>
If the queue is created successfully, the server must send `queueIds` response with the recipient's and sender's queue IDs and public keys to sign all responses and messages and to encrypt delivered message bodies:
```abnf
queueIds = %s"IDS" SP recipientId SP senderId
SP serverSignaturePublicKey SP serverDhPublicKey
serverSignaturePublicKey = signatureKey
; the server's public key to verify responses and messages for this queue
queueIds = %s"IDS" SP recipientId SP srvRcvPublicVerifyKey SP srvDhPublicKey
SP senderId SP srvSndPublicVerifyKey
srvRcvPublicVerifyKey = signatureKey
srvSndPublicVerifyKey = signatureKey
; the server's public keys to verify responses and messages for this queue
serverDhPublicKey = dhPublicKey
; the server's key for DH exchange to derive the secret
; that the server will use to encrypt delivered message bodies to the recipient

2
simplexmq.cabal
View File

@@ -3,8 +3,6 @@ cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.34.4.
--
-- see: https://github.com/sol/hpack
--
-- hash: 3bdb491a0318dc4b53cba4131f192e4c4e17b42e88043495666d1688a1f95443
name: simplexmq
version: 0.5.0

21
src/Simplex/Messaging/Agent.hs
View File

@@ -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 (second)
import Data.Bifunctor (first, second)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Composition ((.:), (.:.))
@@ -83,7 +83,7 @@ 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, SenderPublicKey)
import Simplex.Messaging.Protocol (MsgBody, SndPublicVerifyKey)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (ATransport (..), TProxy, Transport (..), currentSMPVersionStr, runTransportServer)
import Simplex.Messaging.Util (bshow, tryError, unlessM)
@@ -322,7 +322,7 @@ rejectContact' :: AgentMonad m => AgentClient -> ConnId -> InvitationId -> m ()
rejectContact' _ contactConnId invId =
withStore $ \st -> deleteInvitation st contactConnId invId
processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m ()
processConfirmation :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
processConfirmation c rq sndKey = do
withStore $ \st -> setRcvQueueStatus st rq Confirmed
secureQueue c rq sndKey
@@ -526,10 +526,11 @@ 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 {status} =
processSMP cType ConnData {connId} rq@RcvQueue {rcvDhSecret, status} =
case cmd of
SMP.MSG srvMsgId srvTs msgBody -> do
SMP.MSG srvMsgId srvTs msgBody' -> 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
@@ -555,7 +556,7 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
prohibited :: m ()
prohibited = notify . ERR $ AGENT A_PROHIBITED
smpConfirmation :: SenderPublicKey -> ConnInfo -> m ()
smpConfirmation :: SndPublicVerifyKey -> ConnInfo -> m ()
smpConfirmation senderKey cInfo = do
logServer "<--" c srv rId "MSG <KEY>"
case status of
@@ -571,7 +572,7 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
_ -> prohibited
_ -> prohibited
helloMsg :: SenderPublicKey -> ByteString -> m ()
helloMsg :: SndPublicVerifyKey -> ByteString -> m ()
helloMsg verifyKey msgBody = do
logServer "<--" c srv rId "MSG <HELLO>"
case status of
@@ -629,7 +630,7 @@ 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 -> SenderPublicKey -> ConnInfo -> m ()
confirmQueue :: AgentMonad m => AgentClient -> SndQueue -> SndPublicVerifyKey -> ConnInfo -> m ()
confirmQueue c sq senderKey cInfo = do
sendConfirmation c sq senderKey cInfo
withStore $ \st -> setSndQueueStatus st sq Confirmed
@@ -655,7 +656,7 @@ 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, SenderPublicKey, C.APublicVerifyKey)
(MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> C.APublicEncryptKey -> m (SndQueue, SndPublicVerifyKey, C.APublicVerifyKey)
newSndQueue qUri encryptKey =
asks (cmdSignAlg . config) >>= \case
C.SignAlg a -> newSndQueue_ a qUri encryptKey
@@ -665,7 +666,7 @@ newSndQueue_ ::
C.SAlgorithm a ->
SMPQueueUri ->
C.APublicEncryptKey ->
m (SndQueue, SenderPublicKey, C.APublicVerifyKey)
m (SndQueue, SndPublicVerifyKey, C.APublicVerifyKey)
newSndQueue_ a (SMPQueueUri smpServer senderId _) encryptKey = do
size <- asks $ rsaKeySize . config
(senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a

22
src/Simplex/Messaging/Agent/Client.hs
View File

@@ -59,7 +59,7 @@ import Simplex.Messaging.Agent.RetryInterval
import Simplex.Messaging.Agent.Store
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, SenderPublicKey)
import Simplex.Messaging.Protocol (ErrorType (AUTH), MsgBody, QueueId, QueueIdsKeys (..), SndPublicVerifyKey)
import Simplex.Messaging.Util (bshow, liftEitherError, liftError)
import UnliftIO.Exception (IOException)
import qualified UnliftIO.Exception as E
@@ -238,21 +238,27 @@ newRcvQueue_ ::
newRcvQueue_ a c srv = do
size <- asks $ rsaKeySize . config
(recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a
(dhKey, privDhKey) <- liftIO $ C.generateKeyPair' 0
logServer "-->" c srv "" "NEW"
(rcvId, sId) <- withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey
logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sId]
QIK {rcvId, rcvSrvVerifyKey, rcvPublicDHKey, sndId, sndSrvVerifyKey} <-
withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
let rcvDhSecret = C.dh' rcvPublicDHKey privDhKey
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,
sndId = Just sId,
rcvSrvVerifyKey,
rcvDhSecret,
sndId = Just sndId,
sndSrvVerifyKey,
decryptKey,
verifyKey = Nothing,
status = New
}
pure (rq, SMPQueueUri srv sId reservedServerKey, encryptKey)
pure (rq, SMPQueueUri srv sndId sndSrvVerifyKey, encryptKey)
subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do
@@ -301,7 +307,7 @@ 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 -> SenderPublicKey -> ConnInfo -> m ()
sendConfirmation :: forall m. AgentMonad m => AgentClient -> SndQueue -> SndPublicVerifyKey -> ConnInfo -> m ()
sendConfirmation c sq@SndQueue {server, sndId} senderKey cInfo =
withLogSMP_ c server sndId "SEND <KEY>" $ \smp -> do
msg <- mkConfirmation smp
@@ -347,7 +353,7 @@ sendInvitation c SMPQueueUri {smpServer, senderId} encryptKey cReq connInfo = do
agentMessage = A_INV cReq connInfo
}
secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SenderPublicKey -> m ()
secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m ()
secureQueue c RcvQueue {server, rcvId, rcvPrivateKey} senderKey =
withLogSMP c server rcvId "KEY <key>" $ \smp ->
secureSMPQueue smp rcvPrivateKey rcvId senderKey
@@ -381,7 +387,7 @@ encryptAndSign smp SndQueue {encryptKey, signKey} msg = do
sig <- C.sign signKey enc
pure $ C.signatureBytes sig <> enc
decryptAndVerify :: AgentMonad m => RcvQueue -> ByteString -> m ByteString
decryptAndVerify :: AgentMonad m => RcvQueue -> MsgBody -> m ByteString
decryptAndVerify RcvQueue {decryptKey, verifyKey} msg =
verifyMessage verifyKey msg
>>= liftError cryptoError . C.decrypt decryptKey

4
src/Simplex/Messaging/Agent/Protocol.hs
View File

@@ -133,7 +133,7 @@ import Simplex.Messaging.Protocol
( ErrorType,
MsgBody,
MsgId,
SenderPublicKey,
SndPublicVerifyKey,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.Transport (Transport (..), TransportError, serializeTransportError, transportErrorP)
@@ -271,7 +271,7 @@ data SMPMessage
-- (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 :: SenderPublicKey,
senderKey :: SndPublicVerifyKey,
-- | sender's information to be associated with the connection, e.g. sender's profile information
connInfo :: ConnInfo
}

26
src/Simplex/Messaging/Agent/Store.hs
View File

@@ -22,9 +22,11 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Protocol
( MsgBody,
MsgId,
RecipientPrivateKey,
SenderPrivateKey,
SenderPublicKey,
RcvDhSecret,
RcvPrivateSignKey,
RcvPublicVerifyKey,
SndPrivateSignKey,
SndPublicVerifyKey,
)
import qualified Simplex.Messaging.Protocol as SMP
@@ -74,9 +76,19 @@ class Monad m => MonadAgentStore s m where
-- | A receive queue. SMP queue through which the agent receives messages from a sender.
data RcvQueue = RcvQueue
{ server :: SMPServer,
-- | recipient queue ID
rcvId :: SMP.RecipientId,
rcvPrivateKey :: RecipientPrivateKey,
-- | key used by the recipient to sign transmissions
rcvPrivateKey :: RcvPrivateSignKey,
-- | key used by the recipient to verify server transmissions
rcvSrvVerifyKey :: RcvPublicVerifyKey,
-- | shared DH secret used to encrypt/decrypt message bodies from server to recipient
rcvDhSecret :: RcvDhSecret,
-- | sender queue ID
sndId :: Maybe SMP.SenderId,
-- | key used by the sender to sign transmissions
sndSrvVerifyKey :: SndPublicVerifyKey,
-- | TODO keys used for E2E encryption - these will change with double ratchet
decryptKey :: C.APrivateDecryptKey,
verifyKey :: Maybe C.APublicVerifyKey,
status :: QueueStatus
@@ -87,7 +99,7 @@ data RcvQueue = RcvQueue
data SndQueue = SndQueue
{ server :: SMPServer,
sndId :: SMP.SenderId,
sndPrivateKey :: SenderPrivateKey,
sndPrivateKey :: SndPrivateSignKey,
encryptKey :: C.APublicEncryptKey,
signKey :: C.APrivateSignKey,
status :: QueueStatus
@@ -160,14 +172,14 @@ newtype ConnData = ConnData {connId :: ConnId}
data NewConfirmation = NewConfirmation
{ connId :: ConnId,
senderKey :: SenderPublicKey,
senderKey :: SndPublicVerifyKey,
senderConnInfo :: ConnInfo
}
data AcceptedConfirmation = AcceptedConfirmation
{ confirmationId :: ConfirmationId,
connId :: ConnId,
senderKey :: SenderPublicKey,
senderKey :: SndPublicVerifyKey,
senderConnInfo :: ConnInfo,
ownConnInfo :: ConnInfo
}

33
src/Simplex/Messaging/Agent/Store/SQLite.hs
View File

@@ -625,16 +625,19 @@ insertRcvQueue_ dbConn connId RcvQueue {..} = do
dbConn
[sql|
INSERT INTO rcv_queues
( host, port, rcv_id, conn_alias, rcv_private_key, snd_id, decrypt_key, verify_key, status)
( host, port, rcv_id, conn_alias, rcv_private_key, rcv_srv_verify_key, rcv_dh_secret, snd_id, snd_srv_verify_key, decrypt_key, verify_key, status)
VALUES
(:host,:port,:rcv_id,:conn_alias,:rcv_private_key,:snd_id,:decrypt_key,:verify_key,:status);
(:host,:port,:rcv_id,:conn_alias,:rcv_private_key,:rcv_srv_verify_key,:rcv_dh_secret,:snd_id,:snd_srv_verify_key,:decrypt_key,:verify_key,:status);
|]
[ ":host" := host server,
":port" := port_,
":rcv_id" := rcvId,
":conn_alias" := connId,
":rcv_private_key" := rcvPrivateKey,
":rcv_srv_verify_key" := rcvSrvVerifyKey,
":rcv_dh_secret" := rcvDhSecret,
":snd_id" := sndId,
":snd_srv_verify_key" := sndSrvVerifyKey,
":decrypt_key" := decryptKey,
":verify_key" := verifyKey,
":status" := status
@@ -730,17 +733,29 @@ getRcvQueueByConnAlias_ dbConn connId =
<$> DB.query
dbConn
[sql|
SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key,
q.snd_id, q.decrypt_key, q.verify_key, q.status
SELECT s.key_hash, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_srv_verify_key, q.rcv_dh_secret,
q.snd_id, q.snd_srv_verify_key, q.decrypt_key, q.verify_key, 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, sndId, decryptKey, verifyKey, status)] =
let srv = SMPServer host (deserializePort_ port) keyHash
in Just $ RcvQueue srv rcvId rcvPrivateKey sndId decryptKey verifyKey status
rcvQueue [(keyHash, host, port, rcvId, rcvPrivateKey, rcvSrvVerifyKey, rcvDhSecret, sndId, sndSrvVerifyKey, decryptKey, verifyKey, status)] =
let server = SMPServer host (deserializePort_ port) keyHash
in Just $
RcvQueue
{ server,
rcvId,
rcvPrivateKey,
rcvSrvVerifyKey,
rcvDhSecret,
sndId,
sndSrvVerifyKey,
decryptKey,
verifyKey,
status
}
rcvQueue _ = Nothing
getSndQueueByConnAlias_ :: DB.Connection -> ConnId -> IO (Maybe SndQueue)
@@ -757,8 +772,8 @@ getSndQueueByConnAlias_ dbConn connId =
(Only connId)
where
sndQueue [(keyHash, host, port, sndId, sndPrivateKey, encryptKey, signKey, status)] =
let srv = SMPServer host (deserializePort_ port) keyHash
in Just $ SndQueue srv sndId sndPrivateKey encryptKey signKey status
let server = SMPServer host (deserializePort_ port) keyHash
in Just $ SndQueue {server, sndId, sndPrivateKey, encryptKey, signKey, status}
sndQueue _ = Nothing
-- * upgradeRcvConnToDuplex helpers

29
src/Simplex/Messaging/Client.hs
View File

@@ -259,19 +259,20 @@ data SMPClientError
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command
createSMPQueue ::
SMPClient ->
RecipientPrivateKey ->
RecipientPublicKey ->
ExceptT SMPClientError IO (RecipientId, SenderId)
createSMPQueue c rpKey rKey =
RcvPrivateSignKey ->
RcvPublicVerifyKey ->
RcvPublicDhKey ->
ExceptT SMPClientError IO QueueIdsKeys
createSMPQueue c rpKey rKey dhKey =
-- TODO add signing this request too - requires changes in the server
sendSMPCommand c (Just rpKey) "" (Cmd SRecipient $ NEW rKey) >>= \case
Cmd _ (IDS rId sId) -> pure (rId, sId)
sendSMPCommand c (Just rpKey) "" (Cmd SRecipient $ NEW rKey dhKey) >>= \case
Cmd _ (IDS qik) -> pure qik
_ -> throwE SMPUnexpectedResponse
-- | Subscribe to the SMP queue.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue
subscribeSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> ExceptT SMPClientError IO ()
subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO ()
subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId =
sendSMPCommand c (Just rpKey) rId (Cmd SRecipient SUB) >>= \case
Cmd _ OK -> return ()
@@ -282,19 +283,19 @@ subscribeSMPQueue c@SMPClient {smpServer, msgQ} rpKey rId =
-- | Subscribe to the SMP queue notifications.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue-notifications
subscribeSMPQueueNotifications :: SMPClient -> NotifierPrivateKey -> NotifierId -> ExceptT SMPClientError IO ()
subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO ()
subscribeSMPQueueNotifications = okSMPCommand $ Cmd SNotifier NSUB
-- | Secure the SMP queue by adding a sender public key.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command
secureSMPQueue :: SMPClient -> RecipientPrivateKey -> RecipientId -> SenderPublicKey -> ExceptT SMPClientError IO ()
secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO ()
secureSMPQueue c rpKey rId senderKey = okSMPCommand (Cmd SRecipient $ KEY senderKey) c rpKey rId
-- | Enable notifications for the queue for push notifications server.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command
enableSMPQueueNotifications :: SMPClient -> RecipientPrivateKey -> RecipientId -> NotifierPublicKey -> ExceptT SMPClientError IO NotifierId
enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> ExceptT SMPClientError IO NotifierId
enableSMPQueueNotifications c rpKey rId notifierKey =
sendSMPCommand c (Just rpKey) rId (Cmd SRecipient $ NKEY notifierKey) >>= \case
Cmd _ (NID nId) -> pure nId
@@ -303,7 +304,7 @@ enableSMPQueueNotifications c rpKey rId notifierKey =
-- | Send SMP message.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message
sendSMPMessage :: SMPClient -> Maybe SenderPrivateKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()
sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgBody -> ExceptT SMPClientError IO ()
sendSMPMessage c spKey sId msg =
sendSMPCommand c spKey sId (Cmd SSender $ SEND msg) >>= \case
Cmd _ OK -> return ()
@@ -312,7 +313,7 @@ sendSMPMessage c spKey sId msg =
-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
ackSMPMessage :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
ackSMPMessage :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId =
sendSMPCommand c (Just rpKey) rId (Cmd SRecipient ACK) >>= \case
Cmd _ OK -> return ()
@@ -324,13 +325,13 @@ ackSMPMessage c@SMPClient {smpServer, msgQ} rpKey rId =
-- The existing messages from the queue will still be delivered.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#suspend-queue
suspendSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
suspendSMPQueue = okSMPCommand $ Cmd SRecipient OFF
-- | Irreversibly delete SMP queue and all messages in it.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue
deleteSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
deleteSMPQueue = okSMPCommand $ Cmd SRecipient DEL
okSMPCommand :: Cmd -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()

136
src/Simplex/Messaging/Crypto.hs
View File

@@ -43,6 +43,9 @@ module Simplex.Messaging.Crypto
CryptoKey (..),
CryptoPrivateKey (..),
KeyPair,
DhSecret (..),
ADhSecret (..),
CryptoDhSecret (..),
KeyHash (..),
generateKeyPair,
generateKeyPair',
@@ -72,6 +75,11 @@ module Simplex.Messaging.Crypto
verify',
validSignatureSize,
-- * DH derivation
dh',
dhSecret,
dhSecret',
-- * AES256 AEAD-GCM scheme
Key (..),
IV (..),
@@ -85,6 +93,11 @@ module Simplex.Messaging.Crypto
aesKeyP,
ivP,
-- * NaCl crypto_box
cbEncrypt,
cbDecrypt,
cbNonce,
-- * Encoding of RSA keys
publicKeyHash,
@@ -101,8 +114,10 @@ import Control.Monad.Except
import Control.Monad.Trans.Except
import Crypto.Cipher.AES (AES256)
import qualified Crypto.Cipher.Types as AES
import qualified Crypto.Cipher.XSalsa as XSalsa
import qualified Crypto.Error as CE
import Crypto.Hash (Digest, SHA256 (..), hash)
import qualified Crypto.MAC.Poly1305 as Poly1305
import Crypto.Number.Generate (generateMax)
import Crypto.Number.Prime (findPrimeFrom)
import qualified Crypto.PubKey.Curve25519 as X25519
@@ -130,6 +145,7 @@ import Data.Constraint (Dict (..))
import Data.Kind (Constraint, Type)
import Data.String
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.X509
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
@@ -335,6 +351,70 @@ instance Eq APublicEncryptKey where
deriving instance Show APublicEncryptKey
data DhSecret (a :: Algorithm) where
DhSecretX25519 :: X25519.DhSecret -> DhSecret X25519
DhSecretX448 :: X448.DhSecret -> DhSecret X448
deriving instance Eq (DhSecret a)
deriving instance Show (DhSecret a)
data ADhSecret
= forall a.
(AlgorithmI a, DhAlgorithm a) =>
ADhSecret (SAlgorithm a) (DhSecret a)
type family DhAlgorithm (a :: Algorithm) :: Constraint where
DhAlgorithm X25519 = ()
DhAlgorithm X448 = ()
DhAlgorithm a =
(Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used for DH exchange"))
dhAlgorithm :: SAlgorithm a -> Maybe (Dict (DhAlgorithm a))
dhAlgorithm = \case
SX25519 -> Just Dict
SX448 -> Just Dict
_ -> Nothing
class CryptoDhSecret s where
serializeDhSecret :: s -> ByteString
dhSecretBytes :: s -> ByteString
strDhSecretP :: Parser s
dhSecretP :: Parser s
instance AlgorithmI a => IsString (DhSecret a) where
fromString = parseString $ dhSecret >=> dhSecret'
instance CryptoDhSecret ADhSecret where
serializeDhSecret (ADhSecret _ s) = serializeDhSecret s
dhSecretBytes (ADhSecret _ s) = dhSecretBytes s
strDhSecretP = dhSecret <$?> base64P
dhSecretP = dhSecret <$?> A.takeByteString
dhSecret :: ByteString -> Either String ADhSecret
dhSecret = cryptoPassed . secret
where
secret bs
| B.length bs == x25519_size = ADhSecret SX25519 . DhSecretX25519 <$> X25519.dhSecret bs
| B.length bs == x448_size = ADhSecret SX448 . DhSecretX448 <$> X448.dhSecret bs
| otherwise = CE.CryptoFailed CE.CryptoError_SharedSecretSizeInvalid
cryptoPassed = \case
CE.CryptoPassed s -> Right s
CE.CryptoFailed e -> Left $ show e
instance forall a. AlgorithmI a => CryptoDhSecret (DhSecret a) where
serializeDhSecret = encode . dhSecretBytes
dhSecretBytes = \case
DhSecretX25519 s -> BA.convert s
DhSecretX448 s -> BA.convert s
strDhSecretP = dhSecret' <$?> strDhSecretP
dhSecretP = dhSecret' <$?> dhSecretP
dhSecret' :: forall a. AlgorithmI a => ADhSecret -> Either String (DhSecret a)
dhSecret' (ADhSecret a s) = case testEquality a $ sAlgorithm @a of
Just Refl -> Right s
_ -> Left "bad DH secret algorithm"
-- | Class for all key types
class CryptoKey k where
keySize :: k -> Int
@@ -518,20 +598,20 @@ type ASignatureKeyPair = (APublicVerifyKey, APrivateSignKey)
type AnEncryptionKeyPair = (APublicEncryptKey, APrivateDecryptKey)
generateKeyPair :: AlgorithmI a => Int -> SAlgorithm a -> IO AKeyPair
generateKeyPair size a = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair' size a
generateKeyPair size a = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair' size
generateSignatureKeyPair ::
(AlgorithmI a, SignatureAlgorithm a) => Int -> SAlgorithm a -> IO ASignatureKeyPair
generateSignatureKeyPair size a =
bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair' size a
bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair' size
generateEncryptionKeyPair ::
(AlgorithmI a, EncryptionAlgorithm a) => Int -> SAlgorithm a -> IO AnEncryptionKeyPair
generateEncryptionKeyPair size a =
bimap (APublicEncryptKey a) (APrivateDecryptKey a) <$> generateKeyPair' size a
bimap (APublicEncryptKey a) (APrivateDecryptKey a) <$> generateKeyPair' size
generateKeyPair' :: Int -> SAlgorithm a -> IO (KeyPair a)
generateKeyPair' size = \case
generateKeyPair' :: forall a. AlgorithmI a => Int -> IO (KeyPair a)
generateKeyPair' size = case sAlgorithm @a of
SRSA -> generateKeyPairRSA size
SEd25519 ->
Ed25519.generateSecretKey >>= \pk ->
@@ -558,6 +638,8 @@ instance ToField APrivateDecryptKey where toField = toField . encodeKey
instance ToField APublicEncryptKey where toField = toField . encodeKey
instance (Typeable a, AlgorithmI a) => ToField (DhSecret a) where toField = toField . dhSecretBytes
instance FromField APrivateSignKey where fromField = blobFieldParser binaryKeyP
instance FromField APublicVerifyKey where fromField = blobFieldParser binaryKeyP
@@ -566,6 +648,8 @@ instance FromField APrivateDecryptKey where fromField = blobFieldParser binaryKe
instance FromField APublicEncryptKey where fromField = blobFieldParser binaryKeyP
instance (Typeable a, AlgorithmI a) => FromField (DhSecret a) where fromField = blobFieldParser dhSecretP
instance IsString (Maybe ASignature) where
fromString = parseString $ decode >=> decodeSignature
@@ -672,6 +756,8 @@ data CryptoError
CryptoIVError
| -- | AES decryption error
AESDecryptError
| -- CryptoBox decryption error
CBDecryptError
| -- | message does not fit in SMP block
CryptoLargeMsgError
| -- | failure parsing RSA-encrypted message header
@@ -903,6 +989,46 @@ verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' o
Just Refl -> verify' k sig msg
_ -> False
dh' :: DhAlgorithm a => PublicKey a -> PrivateKey a -> DhSecret a
dh' (PublicKeyX25519 k) (PrivateKeyX25519 pk) = DhSecretX25519 $ X25519.dh k pk
dh' (PublicKeyX448 k) (PrivateKeyX448 pk) = DhSecretX448 $ X448.dh k pk
-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce.
cbEncrypt :: DhSecret X25519 -> ByteString -> ByteString -> ByteString
cbEncrypt secret nonce msg = BA.convert tag `B.append` c
where
(rs, c) = xSalsa20 secret nonce msg
tag = Poly1305.auth rs c
-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
cbDecrypt :: DhSecret X25519 -> ByteString -> ByteString -> Either CryptoError ByteString
cbDecrypt secret nonce packet
| B.length packet < 16 = Left CBDecryptError
| BA.constEq tag' tag = Right msg
| otherwise = Left CBDecryptError
where
(tag', c) = B.splitAt 16 packet
(rs, msg) = xSalsa20 secret nonce c
tag = Poly1305.auth rs c
cbNonce :: ByteString -> ByteString
cbNonce s
| len == 24 = s
| len > 24 = fst $ B.splitAt 24 s
| otherwise = s <> B.replicate (24 - len) (toEnum 0)
where
len = B.length s
xSalsa20 :: DhSecret X25519 -> ByteString -> ByteString -> (ByteString, ByteString)
xSalsa20 (DhSecretX25519 shared) nonce msg = (rs, msg')
where
zero = B.replicate 16 $ toEnum 0
(iv0, iv1) = B.splitAt 8 nonce
state0 = XSalsa.initialize 20 shared (zero `B.append` iv0)
state1 = XSalsa.derive state0 iv1
(rs, state2) = XSalsa.generate state1 32
(msg', _) = XSalsa.combine state2 msg
pubVerifyKey :: APublicKey -> Either String APublicVerifyKey
pubVerifyKey (APublicKey a k) = case signatureAlgorithm a of
Just Dict -> Right $ APublicVerifyKey a k

68
src/Simplex/Messaging/Protocol.hs
View File

@@ -2,6 +2,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -28,6 +29,7 @@ module Simplex.Messaging.Protocol
Party (..),
Cmd (..),
SParty (..),
QueueIdsKeys (..),
ErrorType (..),
CommandError (..),
Transmission,
@@ -41,12 +43,14 @@ module Simplex.Messaging.Protocol
RecipientId,
SenderId,
NotifierId,
RecipientPrivateKey,
RecipientPublicKey,
SenderPrivateKey,
SenderPublicKey,
NotifierPrivateKey,
NotifierPublicKey,
RcvPrivateSignKey,
RcvPublicVerifyKey,
RcvPublicDhKey,
RcvDhSecret,
SndPrivateSignKey,
SndPublicVerifyKey,
NtfPrivateSignKey,
NtfPublicVerifyKey,
Encoded,
MsgId,
MsgBody,
@@ -142,10 +146,10 @@ type QueueId = Encoded
-- | Parameterized type for SMP protocol commands from all participants.
data Command (a :: Party) where
-- SMP recipient commands
NEW :: RecipientPublicKey -> Command Recipient
NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient
SUB :: Command Recipient
KEY :: SenderPublicKey -> Command Recipient
NKEY :: NotifierPublicKey -> Command Recipient
KEY :: SndPublicVerifyKey -> Command Recipient
NKEY :: NtfPublicVerifyKey -> Command Recipient
ACK :: Command Recipient
OFF :: Command Recipient
DEL :: Command Recipient
@@ -155,7 +159,7 @@ data Command (a :: Party) where
-- SMP notification subscriber commands
NSUB :: Command Notifier
-- SMP broker commands (responses, messages, notifications)
IDS :: RecipientId -> SenderId -> Command Broker
IDS :: QueueIdsKeys -> Command Broker
MSG :: MsgId -> UTCTime -> MsgBody -> Command Broker
NID :: NotifierId -> Command Broker
NMSG :: Command Broker
@@ -179,27 +183,43 @@ newtype CorrId = CorrId {bs :: ByteString} deriving (Eq, Ord, Show)
instance IsString CorrId where
fromString = CorrId . fromString
-- | Queue IDs and keys
data QueueIdsKeys = QIK
{ rcvId :: RecipientId,
rcvSrvVerifyKey :: RcvPublicVerifyKey,
rcvPublicDHKey :: RcvPublicDhKey,
sndId :: SenderId,
sndSrvVerifyKey :: SndPublicVerifyKey
}
deriving (Eq, Show)
-- | Recipient's private key used by the recipient to authorize (sign) SMP commands.
--
-- Only used by SMP agent, kept here so its definition is close to respective public key.
type RecipientPrivateKey = C.APrivateSignKey
type RcvPrivateSignKey = C.APrivateSignKey
-- | Recipient's public key used by SMP server to verify authorization of SMP commands.
type RecipientPublicKey = C.APublicVerifyKey
type RcvPublicVerifyKey = C.APublicVerifyKey
-- | Public key used for DH exchange to encrypt message bodies from server to recipient
type RcvPublicDhKey = C.PublicKey C.X25519
-- | DH Secret used to encrypt message bodies from server to recipient
type RcvDhSecret = C.DhSecret C.X25519
-- | Sender's private key used by the recipient to authorize (sign) SMP commands.
--
-- Only used by SMP agent, kept here so its definition is close to respective public key.
type SenderPrivateKey = C.APrivateSignKey
type SndPrivateSignKey = C.APrivateSignKey
-- | Sender's public key used by SMP server to verify authorization of SMP commands.
type SenderPublicKey = C.APublicVerifyKey
type SndPublicVerifyKey = C.APublicVerifyKey
-- | Private key used by push notifications server to authorize (sign) LSTN command.
type NotifierPrivateKey = C.APrivateSignKey
type NtfPrivateSignKey = C.APrivateSignKey
-- | Public key used by SMP server to verify authorization of LSTN command sent by push notifications server.
type NotifierPublicKey = C.APublicVerifyKey
type NtfPublicVerifyKey = C.APublicVerifyKey
-- | SMP message server ID.
type MsgId = Encoded
@@ -278,8 +298,15 @@ commandP =
<|> "ERR " *> serverError
<|> "PONG" $> Cmd SBroker PONG
where
newCmd = Cmd SRecipient . NEW <$> C.strKeyP
idsResp = Cmd SBroker <$> (IDS <$> (base64P <* A.space) <*> base64P)
newCmd = Cmd SRecipient <$> (NEW <$> C.strKeyP <* A.space <*> C.strKeyP)
idsResp = Cmd SBroker . IDS <$> qik
qik = do
rcvId <- base64P <* A.space
rcvSrvVerifyKey <- C.strKeyP <* A.space
rcvPublicDHKey <- C.strKeyP <* A.space
sndId <- base64P <* A.space
sndSrvVerifyKey <- C.strKeyP
pure QIK {rcvId, rcvSrvVerifyKey, rcvPublicDHKey, sndId, sndSrvVerifyKey}
nIdsResp = Cmd SBroker . NID <$> base64P
keyCmd = Cmd SRecipient . KEY <$> C.strKeyP
nKeyCmd = Cmd SRecipient . NKEY <$> C.strKeyP
@@ -302,7 +329,7 @@ parseCommand = parse (commandP <* " " <* A.takeByteString) $ CMD SYNTAX
-- | Serialize SMP command.
serializeCommand :: Cmd -> ByteString
serializeCommand = \case
Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializeKey rKey
Cmd SRecipient (NEW rKey dhKey) -> B.unwords ["NEW", C.serializeKey rKey, C.serializeKey dhKey]
Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializeKey sKey
Cmd SRecipient (NKEY nKey) -> "NKEY " <> C.serializeKey nKey
Cmd SRecipient SUB -> "SUB"
@@ -314,7 +341,8 @@ serializeCommand = \case
Cmd SNotifier NSUB -> "NSUB"
Cmd SBroker (MSG msgId ts msgBody) ->
B.unwords ["MSG", encode msgId, B.pack $ formatISO8601Millis ts, serializeMsg msgBody]
Cmd SBroker (IDS rId sId) -> B.unwords ["IDS", encode rId, encode sId]
Cmd SBroker (IDS QIK {rcvId, rcvSrvVerifyKey = rsKey, rcvPublicDHKey = dhKey, sndId, sndSrvVerifyKey = ssKey}) ->
B.unwords ["IDS", encode rcvId, C.serializeKey rsKey, C.serializeKey dhKey, encode sndId, C.serializeKey ssKey]
Cmd SBroker (NID nId) -> "NID " <> encode nId
Cmd SBroker (ERR err) -> "ERR " <> serializeErrorType err
Cmd SBroker NMSG -> "NMSG"

67
src/Simplex/Messaging/Server.hs
View File

@@ -7,6 +7,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
@@ -152,7 +153,7 @@ verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => SignedTr
verifyTransmission (sig_, t@(corrId, queueId, cmd)) = do
(corrId,queueId,) <$> case cmd of
Cmd SBroker _ -> return $ smpErr INTERNAL -- it can only be client command, because `fromClient` was used
Cmd SRecipient (NEW k) -> pure $ verifySignature k
Cmd SRecipient (NEW k _) -> pure $ verifySignature k
Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey
Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey
Cmd SSender PING -> return cmd
@@ -234,7 +235,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server
PING -> return (corrId, queueId, Cmd SBroker PONG)
Cmd SNotifier NSUB -> subscribeNotifications
Cmd SRecipient command -> case command of
NEW rKey -> createQueue st rKey
NEW rKey dhKey -> createQueue st rKey dhKey
SUB -> subscribeQueue queueId
ACK -> acknowledgeMsg
KEY sKey -> secureQueue_ st sKey
@@ -242,19 +243,40 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server
OFF -> suspendQueue_ st
DEL -> delQueueAndMsgs st
where
createQueue :: QueueStore -> RecipientPublicKey -> m Transmission
createQueue st rKey = checkKeySize rKey $ addQueueRetry 3
createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> m Transmission
createQueue st recipientKey dhKey = checkKeySize recipientKey $ do
C.SignAlg a <- asks $ trnSignAlg . config
(rcvPublicDHKey, privDhKey) <- liftIO $ C.generateKeyPair' 0
(rcvSrvVerifyKey, rcvSrvSignKey) <- liftIO $ C.generateSignatureKeyPair 0 a
(sndSrvVerifyKey, sndSrvSignKey) <- liftIO $ C.generateSignatureKeyPair 0 a
let rcvDhSecret = C.dh' dhKey privDhKey
qik (rcvId, sndId) = QIK {rcvId, rcvSrvVerifyKey, rcvPublicDHKey, sndId, sndSrvVerifyKey}
qRec (recipientId, senderId) =
QueueRec
{ recipientId,
senderId,
recipientKey,
rcvSrvSignKey,
rcvDhSecret,
senderKey = Nothing,
sndSrvSignKey,
notifier = Nothing,
status = QueueActive
}
addQueueRetry 3 qik qRec
where
addQueueRetry :: Int -> m (Command 'Broker)
addQueueRetry 0 = pure $ ERR INTERNAL
addQueueRetry n = do
ids@(rId, sId) <- getIds
atomically (addQueue st rKey ids) >>= \case
Left DUPLICATE_ -> addQueueRetry $ n - 1
addQueueRetry ::
Int -> ((RecipientId, SenderId) -> QueueIdsKeys) -> ((RecipientId, SenderId) -> QueueRec) -> m (Command 'Broker)
addQueueRetry 0 _ _ = pure $ ERR INTERNAL
addQueueRetry n qik qRec = do
ids@(rId, _) <- getIds
-- create QueueRec record with these ids and keys
atomically (addQueue st $ qRec ids) >>= \case
Left DUPLICATE_ -> addQueueRetry (n - 1) qik qRec
Left e -> pure $ ERR e
Right _ -> do
withLog (`logCreateById` rId)
subscribeQueue rId $> IDS rId sId
subscribeQueue rId $> IDS (qik ids)
logCreateById :: StoreLog 'WriteMode -> RecipientId -> IO ()
logCreateById s rId =
@@ -267,12 +289,12 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server
n <- asks $ queueIdBytes . config
liftM2 (,) (randomId n) (randomId n)
secureQueue_ :: QueueStore -> SenderPublicKey -> m Transmission
secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m Transmission
secureQueue_ st sKey = do
withLog $ \s -> logSecureQueue s queueId sKey
atomically . checkKeySize sKey $ either ERR (const OK) <$> secureQueue st queueId sKey
addQueueNotifier_ :: QueueStore -> NotifierPublicKey -> m Transmission
addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> m Transmission
addQueueNotifier_ st nKey = checkKeySize nKey $ addNotifierRetry 3
where
addNotifierRetry :: Int -> m (Command 'Broker)
@@ -336,12 +358,6 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server
qr <- atomically $ getQueue st SSender queueId
either (return . err) storeMessage qr
where
mkMessage :: m Message
mkMessage = do
msgId <- asks (msgIdBytes . config) >>= randomId
ts <- liftIO getCurrentTime
return $ Message {msgId, ts, msgBody}
storeMessage :: QueueRec -> m Transmission
storeMessage qr = case status qr of
QueueOff -> return $ err AUTH
@@ -356,6 +372,13 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server
writeMsg q msg
pure ok
where
mkMessage :: m 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}
trySendNotification :: STM ()
trySendNotification =
forM_ (notifier qr) $ \(nId, _) ->
@@ -398,6 +421,9 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server
setDelivered :: STM (Maybe Bool)
setDelivered = withSub rId $ \s -> tryPutTMVar (delivered s) ()
msgCmd :: Message -> Command 'Broker
msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody
delQueueAndMsgs :: QueueStore -> m Transmission
delQueueAndMsgs st = do
withLog (`logDeleteQueue` queueId)
@@ -416,9 +442,6 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server
okResp :: Either ErrorType () -> Transmission
okResp = either err $ const ok
msgCmd :: Message -> Command 'Broker
msgCmd Message {msgId, ts, msgBody} = MSG msgId ts msgBody
withLog :: (MonadUnliftIO m, MonadReader Env m) => (StoreLog 'WriteMode -> IO a) -> m ()
withLog action = do
env <- ask

4
src/Simplex/Messaging/Server/Env/STM.hs
View File

@@ -27,11 +27,11 @@ data ServerConfig = ServerConfig
tbqSize :: Natural,
msgQueueQuota :: Natural,
queueIdBytes :: Int,
msgIdBytes :: Int,
msgIdBytes :: Int, -- must be at least 24 bytes, it is used as 192-bit nonce for XSalsa20
storeLog :: Maybe (StoreLog 'ReadMode),
blockSize :: Int,
trnSignAlg :: C.SignAlg,
serverPrivateKey :: C.PrivateKey 'C.RSA
-- serverId :: ByteString
}
data Env = Env

27
src/Simplex/Messaging/Server/QueueStore.hs
View File

@@ -1,7 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
module Simplex.Messaging.Server.QueueStore where
@@ -10,29 +9,21 @@ import Simplex.Messaging.Protocol
data QueueRec = QueueRec
{ recipientId :: RecipientId,
senderId :: SenderId,
recipientKey :: RecipientPublicKey,
senderKey :: Maybe SenderPublicKey,
notifier :: Maybe (NotifierId, NotifierPublicKey),
recipientKey :: RcvPublicVerifyKey,
rcvSrvSignKey :: RcvPrivateSignKey,
rcvDhSecret :: RcvDhSecret,
senderKey :: Maybe SndPublicVerifyKey,
sndSrvSignKey :: SndPrivateSignKey,
notifier :: Maybe (NotifierId, NtfPublicVerifyKey),
status :: QueueStatus
}
data QueueStatus = QueueActive | QueueOff deriving (Eq)
class MonadQueueStore s m where
addQueue :: s -> RecipientPublicKey -> (RecipientId, SenderId) -> m (Either ErrorType ())
addQueue :: s -> QueueRec -> m (Either ErrorType ())
getQueue :: s -> SParty (a :: Party) -> QueueId -> m (Either ErrorType QueueRec)
secureQueue :: s -> RecipientId -> SenderPublicKey -> m (Either ErrorType ())
addQueueNotifier :: s -> RecipientId -> NotifierId -> NotifierPublicKey -> m (Either ErrorType ())
secureQueue :: s -> RecipientId -> SndPublicVerifyKey -> m (Either ErrorType ())
addQueueNotifier :: s -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> m (Either ErrorType ())
suspendQueue :: s -> RecipientId -> m (Either ErrorType ())
deleteQueue :: s -> RecipientId -> m (Either ErrorType ())
mkQueueRec :: RecipientPublicKey -> (RecipientId, SenderId) -> QueueRec
mkQueueRec recipientKey (recipientId, senderId) =
QueueRec
{ recipientId,
senderId,
recipientKey,
senderKey = Nothing,
notifier = Nothing,
status = QueueActive
}

10
src/Simplex/Messaging/Server/QueueStore/STM.hs
View File

@@ -29,15 +29,15 @@ newQueueStore :: STM QueueStore
newQueueStore = newTVar QueueStoreData {queues = M.empty, senders = M.empty, notifiers = M.empty}
instance MonadQueueStore QueueStore STM where
addQueue :: QueueStore -> RecipientPublicKey -> (RecipientId, SenderId) -> STM (Either ErrorType ())
addQueue store rKey ids@(rId, sId) = do
addQueue :: QueueStore -> QueueRec -> STM (Either ErrorType ())
addQueue store qRec@QueueRec {recipientId = rId, senderId = sId} = do
cs@QueueStoreData {queues, senders} <- readTVar store
if M.member rId queues || M.member sId senders
then return $ Left DUPLICATE_
else do
writeTVar store $
cs
{ queues = M.insert rId (mkQueueRec rKey ids) queues,
{ queues = M.insert rId qRec queues,
senders = M.insert sId rId senders
}
return $ Right ()
@@ -60,14 +60,14 @@ instance MonadQueueStore QueueStore STM where
Just rId -> getRcpQueue cs rId
Nothing -> Left AUTH
secureQueue :: QueueStore -> RecipientId -> SenderPublicKey -> STM (Either ErrorType ())
secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType ())
secureQueue store rId sKey =
updateQueues store rId $ \cs c ->
case senderKey c of
Just _ -> (Left AUTH, cs)
_ -> (Right (), cs {queues = M.insert rId c {senderKey = Just sKey} (queues cs)})
addQueueNotifier :: QueueStore -> RecipientId -> NotifierId -> NotifierPublicKey -> STM (Either ErrorType ())
addQueueNotifier :: QueueStore -> RecipientId -> NotifierId -> NtfPublicVerifyKey -> STM (Either ErrorType ())
addQueueNotifier store rId nId nKey = do
cs@QueueStoreData {queues, notifiers} <- readTVar store
if M.member nId notifiers

41
src/Simplex/Messaging/Server/StoreLog.hs
View File

@@ -50,8 +50,8 @@ data StoreLog (a :: IOMode) where
data StoreLogRecord
= CreateQueue QueueRec
| SecureQueue QueueId SenderPublicKey
| AddNotifier QueueId NotifierId NotifierPublicKey
| SecureQueue QueueId SndPublicVerifyKey
| AddNotifier QueueId NotifierId NtfPublicVerifyKey
| DeleteQueue QueueId
storeLogRecordP :: Parser StoreLogRecord
@@ -66,12 +66,15 @@ storeLogRecordP =
addNotifierP =
AddNotifier <$> base64P <* A.space <*> base64P <* A.space <*> C.strKeyP
queueRecP = do
recipientId <- "rid=" *> base64P <* A.space
senderId <- "sid=" *> base64P <* A.space
recipientKey <- "rk=" *> C.strKeyP <* A.space
senderKey <- "sk=" *> optional C.strKeyP
recipientId <- "rid=" *> base64P
recipientKey <- " rk=" *> C.strKeyP
rcvSrvSignKey <- " rsk=" *> C.strKeyP
rcvDhSecret <- " rdh=" *> C.strDhSecretP
senderId <- " sid=" *> base64P
senderKey <- " sk=" *> optional C.strKeyP
sndSrvSignKey <- " ssk=" *> C.strKeyP
notifier <- optional $ (,) <$> (" nid=" *> base64P) <*> (" nk=" *> C.strKeyP)
pure QueueRec {recipientId, senderId, recipientKey, senderKey, notifier, status = QueueActive}
pure QueueRec {recipientId, recipientKey, rcvSrvSignKey, rcvDhSecret, senderId, senderKey, sndSrvSignKey, notifier, status = QueueActive}
serializeStoreLogRecord :: StoreLogRecord -> ByteString
serializeStoreLogRecord = \case
@@ -80,14 +83,18 @@ serializeStoreLogRecord = \case
AddNotifier rId nId nKey -> B.unwords ["NOTIFIER", encode rId, encode nId, C.serializeKey nKey]
DeleteQueue rId -> "DELETE " <> encode rId
where
serializeQueue QueueRec {recipientId, senderId, recipientKey, senderKey, notifier} =
B.unwords
[ "rid=" <> encode recipientId,
"sid=" <> encode senderId,
"rk=" <> C.serializeKey recipientKey,
"sk=" <> maybe "" C.serializeKey senderKey
]
<> maybe "" serializeNotifier notifier
serializeQueue
QueueRec {recipientId, recipientKey, rcvSrvSignKey, rcvDhSecret, senderId, senderKey, sndSrvSignKey, notifier} =
B.unwords
[ "rid=" <> encode recipientId,
"rk=" <> C.serializeKey recipientKey,
"rsk=" <> C.serializeKey rcvSrvSignKey,
"rdh=" <> C.serializeDhSecret rcvDhSecret,
"sid=" <> encode senderId,
"sk=" <> maybe "" C.serializeKey senderKey,
"ssk=" <> C.serializeKey sndSrvSignKey
]
<> maybe "" serializeNotifier notifier
serializeNotifier (nId, nKey) = " nid=" <> encode nId <> " nk=" <> C.serializeKey nKey
openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode)
@@ -116,10 +123,10 @@ writeStoreLogRecord (WriteStoreLog _ h) r = do
logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO ()
logCreateQueue s = writeStoreLogRecord s . CreateQueue
logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SenderPublicKey -> IO ()
logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicVerifyKey -> IO ()
logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey
logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NotifierId -> NotifierPublicKey -> IO ()
logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NotifierId -> NtfPublicVerifyKey -> IO ()
logAddNotifier s qId nId nKey = writeStoreLogRecord s $ AddNotifier qId nId nKey
logDeleteQueue :: StoreLog 'WriteMode -> QueueId -> IO ()

17
tests/AgentTests/SQLiteTests.hs
View File

@@ -152,11 +152,20 @@ cData1 = ConnData {connId = "conn1"}
testPrivateSignKey :: C.APrivateSignKey
testPrivateSignKey = C.APrivateSignKey C.SRSA testPrivateKey
testPublicVerifyKey :: C.APublicVerifyKey
testPublicVerifyKey = C.APublicVerifyKey C.SRSA testPublicKey
testPrivateDecryptKey :: C.APrivateDecryptKey
testPrivateDecryptKey = C.APrivateDecryptKey C.SRSA testPrivateKey
testPublicEncryptKey :: C.APublicEncryptKey
testPublicEncryptKey = C.APublicEncryptKey C.SRSA $ C.PublicKeyRSA $ R.PublicKey 1 2 3
testPublicEncryptKey = C.APublicEncryptKey C.SRSA testPublicKey
testPublicKey :: C.PublicKey 'C.RSA
testPublicKey = C.PublicKeyRSA $ R.PublicKey 1 2 3
testDhSecret :: C.DhSecret 'C.X25519
testDhSecret = "01234567890123456789012345678901"
testPrivateKey :: C.PrivateKey 'C.RSA
testPrivateKey =
@@ -182,7 +191,10 @@ rcvQueue1 =
{ server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,
rcvId = "1234",
rcvPrivateKey = testPrivateSignKey,
rcvSrvVerifyKey = testPublicVerifyKey,
rcvDhSecret = testDhSecret,
sndId = Just "2345",
sndSrvVerifyKey = testPublicVerifyKey,
decryptKey = testPrivateDecryptKey,
verifyKey = Nothing,
status = New
@@ -354,7 +366,10 @@ testUpgradeSndConnToDuplex =
{ server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash,
rcvId = "3456",
rcvPrivateKey = testPrivateSignKey,
rcvSrvVerifyKey = testPublicVerifyKey,
rcvDhSecret = testDhSecret,
sndId = Just "4567",
sndSrvVerifyKey = testPublicVerifyKey,
decryptKey = testPrivateDecryptKey,
verifyKey = Nothing,
status = New

5
tests/SMPClient.hs
View File

@@ -61,8 +61,9 @@ cfg =
{ transports = undefined,
tbqSize = 1,
msgQueueQuota = 4,
queueIdBytes = 12,
msgIdBytes = 6,
queueIdBytes = 24,
msgIdBytes = 24,
trnSignAlg = C.SignAlg C.SEd448,
storeLog = Nothing,
blockSize = 8192,
serverPrivateKey =

171
tests/ServerTests.hs
View File

@@ -43,6 +43,9 @@ serverTests t = do
pattern Resp :: CorrId -> QueueId -> Command 'Broker -> SignedTransmissionOrError
pattern Resp corrId queueId command <- ("", (corrId, queueId, Right (Cmd SBroker command)))
pattern Ids :: RecipientId -> SenderId -> RcvPublicDhKey -> Command 'Broker
pattern Ids rId sId srvDh <- IDS (QIK rId _ srvDh sId _)
sendRecv :: Transport c => THandle c -> (Maybe C.ASignature, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError
sendRecv h (sgn, corrId, qId, cmd) = tPutRaw h (sgn, corrId, encode qId, cmd) >> tGet fromServer h
@@ -63,16 +66,18 @@ testCreateSecure :: ATransport -> Spec
testCreateSecure (ATransport t) =
it "should create (NEW) and secure (KEY) queue" $
smpTest t $ \h -> do
(rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
Resp "abcd" rId1 (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializeKey rPub)
(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
(rId1, "") #== "creates queue"
Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5 hello ")
(ok1, OK) #== "accepts unsigned SEND"
(sId1, sId) #== "same queue ID in response 1"
Resp "" _ (MSG _ _ msg1) <- tGet fromServer h
(msg1, "hello") #== "delivers message"
Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer h
(dec mId1 msg1, Right "hello") #== "delivers message"
Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, "ACK")
(ok4, OK) #== "replies OK when message acknowledged if no more messages"
@@ -80,7 +85,7 @@ 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 rsaKeySize C.SRSA
(sPub, sKey) <- C.generateSignatureKeyPair 0 C.SEd448
Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND 5 hello ")
(err1, ERR AUTH) #== "rejects signed SEND"
(sId2, sId) #== "same queue ID in response 2"
@@ -102,8 +107,8 @@ testCreateSecure (ATransport t) =
Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, "SEND 11 hello again ")
(ok3, OK) #== "accepts signed SEND"
Resp "" _ (MSG _ _ msg) <- tGet fromServer h
(msg, "hello again") #== "delivers message 2"
Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer h
(dec mId2 msg2, Right "hello again") #== "delivers message 2"
Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, "ACK")
(ok5, OK) #== "replies OK when message acknowledged 2"
@@ -115,11 +120,13 @@ 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 rsaKeySize C.SRSA
Resp "abcd" rId1 (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializeKey rPub)
(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
(rId1, "") #== "creates queue"
(sPub, sKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
(sPub, sKey) <- C.generateSignatureKeyPair 0 C.SEd25519
Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializeKey sPub)
(ok1, OK) #== "secures queue"
@@ -129,8 +136,8 @@ testCreateDelete (ATransport t) =
Resp "dabc" _ ok7 <- signSendRecv sh sKey ("dabc", sId, "SEND 7 hello 2 ")
(ok7, OK) #== "accepts signed SEND 2 - this message is not delivered because the first is not ACKed"
Resp "" _ (MSG _ _ msg1) <- tGet fromServer rh
(msg1, "hello") #== "delivers message"
Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer rh
(dec mId1 msg1, Right "hello") #== "delivers message"
Resp "abcd" _ err1 <- sendRecv rh (sampleSig, "abcd", rId, "OFF")
(err1, ERR AUTH) #== "rejects OFF with wrong signature"
@@ -151,8 +158,8 @@ testCreateDelete (ATransport t) =
Resp "bcda" _ ok4 <- signSendRecv rh rKey ("bcda", rId, "OFF")
(ok4, OK) #== "accepts OFF when suspended"
Resp "cdab" _ (MSG _ _ msg) <- signSendRecv rh rKey ("cdab", rId, "SUB")
(msg, "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)"
Resp "cdab" _ (MSG mId2 _ msg2) <- signSendRecv rh rKey ("cdab", rId, "SUB")
(dec mId2 msg2, Right "hello") #== "accepts SUB when suspended and delivers the message again (because was not ACKed)"
Resp "dabc" _ err5 <- sendRecv rh (sampleSig, "dabc", rId, "DEL")
(err5, ERR AUTH) #== "rejects DEL with wrong signature"
@@ -183,70 +190,76 @@ testDuplex :: ATransport -> Spec
testDuplex (ATransport t) =
it "should create 2 simplex connections and exchange messages" $
smpTest2 t $ \alice bob -> do
(arPub, arKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
Resp "abcd" _ (IDS aRcv aSnd) <- signSendRecv alice arKey ("abcd", "", "NEW " <> C.serializeKey arPub)
(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
-- aSnd ID is passed to Bob out-of-band
(bsPub, bsKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
(bsPub, bsKey) <- C.generateSignatureKeyPair 0 C.SEd448
Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, cmdSEND $ "key " <> C.serializeKey bsPub)
-- "key ..." is ad-hoc, different from SMP protocol
Resp "" _ (MSG _ _ msg1) <- tGet fromServer alice
Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer alice
Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK")
["key", bobKey] <- return $ B.words msg1
Right ["key", bobKey] <- pure $ B.words <$> aDec mId1 msg1
(bobKey, C.serializeKey bsPub) #== "key received from Bob"
Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "KEY " <> bobKey)
(brPub, brKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
Resp "abcd" _ (IDS bRcv bSnd) <- signSendRecv bob brKey ("abcd", "", "NEW " <> C.serializeKey brPub)
(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
Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, cmdSEND $ "reply_id " <> encode bSnd)
-- "reply_id ..." is ad-hoc, it is not a part of SMP protocol
Resp "" _ (MSG _ _ msg2) <- tGet fromServer alice
Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer alice
Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK")
["reply_id", bId] <- return $ B.words msg2
Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2
(bId, encode bSnd) #== "reply queue ID received from Bob"
(asPub, asKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
(asPub, asKey) <- C.generateSignatureKeyPair 0 C.SEd448
Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, cmdSEND $ "key " <> C.serializeKey asPub)
-- "key ..." is ad-hoc, different from SMP protocol
Resp "" _ (MSG _ _ msg3) <- tGet fromServer bob
Resp "" _ (MSG mId3 _ msg3) <- tGet fromServer bob
Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, "ACK")
["key", aliceKey] <- return $ B.words msg3
Right ["key", aliceKey] <- pure $ B.words <$> bDec mId3 msg3
(aliceKey, C.serializeKey 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 "" _ (MSG _ _ msg4) <- tGet fromServer alice
Resp "" _ (MSG mId4 _ msg4) <- tGet fromServer alice
Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "ACK")
(msg4, "hi alice") #== "message received from Bob"
(aDec mId4 msg4, Right "hi alice") #== "message received from Bob"
Resp "abcd" _ OK <- signSendRecv alice asKey ("abcd", bSnd, cmdSEND "how are you bob")
Resp "" _ (MSG _ _ msg5) <- tGet fromServer bob
Resp "" _ (MSG mId5 _ msg5) <- tGet fromServer bob
Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "ACK")
(msg5, "how are you bob") #== "message received from alice"
(bDec mId5 msg5, Right "how are you bob") #== "message received from alice"
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 rsaKeySize C.SRSA
Resp "abcd" _ (IDS rId sId) <- signSendRecv rh1 rKey ("abcd", "", "NEW " <> C.serializeKey rPub)
(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 ")
(ok1, OK) #== "sent test message 1"
Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, cmdSEND "test2, no ACK")
(ok2, OK) #== "sent test message 2"
Resp "" _ (MSG _ _ msg1) <- tGet fromServer rh1
(msg1, "test1") #== "test message 1 delivered to the 1st TCP connection"
Resp "abcd" _ (MSG _ _ msg2) <- signSendRecv rh1 rKey ("abcd", rId, "ACK")
(msg2, "test2, no ACK") #== "test message 2 delivered, no ACK"
Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer rh1
(dec mId1 msg1, Right "test1") #== "test message 1 delivered to the 1st TCP connection"
Resp "abcd" _ (MSG mId2 _ msg2) <- signSendRecv rh1 rKey ("abcd", rId, "ACK")
(dec mId2 msg2, Right "test2, no ACK") #== "test message 2 delivered, no ACK"
Resp "bcda" _ (MSG _ _ msg2') <- signSendRecv rh2 rKey ("bcda", rId, "SUB")
(msg2', "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"
Resp "bcda" _ (MSG mId2' _ msg2') <- signSendRecv rh2 rKey ("bcda", rId, "SUB")
(dec mId2' msg2', Right "test2, no ACK") #== "same simplex queue via another TCP connection, tes2 delivered again (no ACK in 1st queue)"
Resp "cdab" _ OK <- signSendRecv rh2 rKey ("cdab", rId, "ACK")
Resp "" _ end <- tGet fromServer rh1
@@ -254,8 +267,8 @@ testSwitchSub (ATransport t) =
Resp "dabc" _ OK <- sendRecv sh ("", "dabc", sId, "SEND 5 test3 ")
Resp "" _ (MSG _ _ msg3) <- tGet fromServer rh2
(msg3, "test3") #== "delivered to the 2nd TCP connection"
Resp "" _ (MSG mId3 _ msg3) <- tGet fromServer rh2
(dec mId3 msg3, Right "test3") #== "delivered to the 2nd TCP connection"
Resp "abcd" _ err <- signSendRecv rh1 rKey ("abcd", rId, "ACK")
(err, ERR NO_MSG) #== "rejects ACK from the 1st TCP connection"
@@ -270,27 +283,36 @@ 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 rsaKeySize C.SRSA
(sPub2, sKey2) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
(nPub, nKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
(sPub1, sKey1) <- C.generateSignatureKeyPair 0 C.SEd25519
(sPub2, sKey2) <- C.generateSignatureKeyPair 0 C.SEd25519
(nPub, nKey) <- C.generateSignatureKeyPair 0 C.SEd25519
recipientId1 <- newTVarIO ""
recipientKey1 <- newTVarIO Nothing
dhShared1 <- newTVarIO Nothing
senderId1 <- newTVarIO ""
senderId2 <- newTVarIO ""
notifierId <- newTVarIO ""
withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
(sId1, rId, rKey) <- createAndSecureQueue h sPub1
atomically $ writeTVar senderId1 sId1
Resp "abcd" _ (NID nId) <- signSendRecv h rKey ("abcd", rId, "NKEY " <> C.serializeKey nPub)
atomically $ writeTVar notifierId nId
(sId1, rId1, rKey1, dhShared) <- createAndSecureQueue h sPub1
Resp "abcd" _ (NID nId) <- signSendRecv h rKey1 ("abcd", rId1, "NKEY " <> C.serializeKey nPub)
atomically $ do
writeTVar recipientId1 rId1
writeTVar recipientKey1 $ Just rKey1
writeTVar dhShared1 $ Just dhShared
writeTVar senderId1 sId1
writeTVar notifierId nId
Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, "NSUB")
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ")
Resp "" _ (MSG _ _ "hello") <- tGet fromServer h
Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer h
(C.cbDecrypt dhShared mId1 msg1, Right "hello") #== "delivered from queue 1"
Resp "" _ NMSG <- tGet fromServer h1
(sId2, rId2, rKey2) <- createAndSecureQueue h sPub2
(sId2, rId2, rKey2, dhShared2) <- createAndSecureQueue h sPub2
atomically $ writeTVar senderId2 sId2
Resp "cdab" _ OK <- signSendRecv h sKey2 ("cdab", sId2, "SEND 9 hello too ")
Resp "" _ (MSG _ _ "hello too") <- tGet fromServer h
Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer h
(C.cbDecrypt dhShared2 mId2 msg2, Right "hello too") #== "delivered from queue 2"
Resp "dabc" _ OK <- signSendRecv h rKey2 ("dabc", rId2, "DEL")
pure ()
@@ -305,10 +327,16 @@ testWithStoreLog at@(ATransport t) =
withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do
-- this queue is restored
rId1 <- readTVarIO recipientId1
Just rKey1 <- readTVarIO recipientKey1
Just dh1 <- readTVarIO dhShared1
sId1 <- readTVarIO senderId1
nId <- readTVarIO notifierId
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ")
Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, "NSUB")
Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ")
Resp "cdab" _ (MSG mId3 _ msg3) <- signSendRecv h rKey1 ("cdab", rId1, "SUB")
(C.cbDecrypt dh1 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 ")
@@ -331,14 +359,16 @@ testWithStoreLog at@(ATransport t) =
Right l -> pure l
Left (_ :: SomeException) -> logSize
createAndSecureQueue :: Transport c => THandle c -> SenderPublicKey -> IO (SenderId, RecipientId, C.APrivateSignKey)
createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret)
createAndSecureQueue h sPub = do
(rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
Resp "abcd" "" (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializeKey rPub)
(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])
let dhShared = C.dh' srvDh dhPriv
let keyCmd = "KEY " <> C.serializeKey sPub
Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, keyCmd)
(rId', rId) #== "same queue ID"
pure (sId, rId, rKey)
pure (sId, rId, rKey, dhShared)
testTiming :: ATransport -> Spec
testTiming (ATransport t) =
@@ -379,7 +409,9 @@ 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
Resp "abcd" "" (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializeKey rPub)
(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
Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, "SUB")
(_, badKey) <- generateKeys badKeySize
@@ -390,7 +422,9 @@ testTiming (ATransport t) =
Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, keyCmd)
Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, "SEND 5 hello ")
Resp "" _ (MSG _ _ "hello") <- tGet fromServer rh
Resp "" _ (MSG mId _ msg) <- tGet fromServer rh
(dec mId msg, Right "hello") #== "delivered from queue"
runTimingTest sh badKey sId "SEND 5 hello "
where
generateKeys = \case
@@ -416,27 +450,32 @@ testTiming (ATransport t) =
testMessageNotifications :: ATransport -> Spec
testMessageNotifications (ATransport t) =
it "should create simplex connection, subscribe notifier and deliver notifications" $ do
(sPub, sKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
(nPub, nKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA
(sPub, sKey) <- C.generateSignatureKeyPair 0 C.SEd25519
(nPub, nKey) <- C.generateSignatureKeyPair 0 C.SEd25519
smpTest4 t $ \rh sh nh1 nh2 -> do
(sId, rId, rKey) <- createAndSecureQueue rh sPub
(sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub
Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, "NKEY " <> C.serializeKey nPub)
Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, "NSUB")
Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, "SEND 5 hello ")
Resp "" _ (MSG _ _ "hello") <- tGet fromServer rh
Resp "" _ (MSG mId1 _ msg1) <- tGet fromServer rh
(C.cbDecrypt dhShared 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 "" _ (MSG _ _ "hello again") <- tGet fromServer rh
Resp "" _ (MSG mId2 _ msg2) <- tGet fromServer rh
(C.cbDecrypt dhShared mId2 msg2, Right "hello again") #== "delivered from queue again"
Resp "" _ NMSG <- tGet fromServer nh2
1000 `timeout` tGet fromServer nh1 >>= \case
Nothing -> return ()
Just _ -> error "nothing else should be delivered to the 1st notifier's TCP connection"
samplePubKey :: ByteString
samplePubKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR"
samplePubKey = "ed25519:MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ6buiZJVgSpQWsucXq7U6zjMgY="
sampleDhPubKey :: ByteString
sampleDhPubKey = "x25519:MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ="
sampleSig :: Maybe C.ASignature
sampleSig = "gM8qn2Vx3GkhIp2hgrji9uhfXKpgtKDmc0maxdP8GvbORUxMCTlLG8Q/gNcl3pQVOzmbZqTZZfKcGDn9DaquJ3fT5D/NKdeW//d6ETE1EXsIbpENS0QsS+bKZDjpp3w3eQlfUxn4BNisp2S14CmJBm/FaiNj2fPkLqfkzZALcoY="
@@ -446,9 +485,9 @@ syntaxTests (ATransport t) = do
it "unknown command" $ ("", "abcd", "1234", "HELLO") >#> ("", "abcd", "1234", "ERR CMD SYNTAX")
describe "NEW" $ do
it "no parameters" $ (sampleSig, "bcda", "", "NEW") >#> ("", "bcda", "", "ERR CMD SYNTAX")
it "many parameters" $ (sampleSig, "cdab", "", "NEW 1 " <> samplePubKey) >#> ("", "cdab", "", "ERR CMD SYNTAX")
it "no signature" $ ("", "dabc", "", "NEW " <> samplePubKey) >#> ("", "dabc", "", "ERR CMD NO_AUTH")
it "queue ID" $ (sampleSig, "abcd", "12345678", "NEW " <> samplePubKey) >#> ("", "abcd", "12345678", "ERR CMD HAS_AUTH")
it "many parameters" $ (sampleSig, "cdab", "", B.unwords ["NEW 1", samplePubKey, sampleDhPubKey]) >#> ("", "cdab", "", "ERR CMD SYNTAX")
it "no signature" $ ("", "dabc", "", B.unwords ["NEW", samplePubKey, sampleDhPubKey]) >#> ("", "dabc", "", "ERR CMD NO_AUTH")
it "queue ID" $ (sampleSig, "abcd", "12345678", B.unwords ["NEW", samplePubKey, sampleDhPubKey]) >#> ("", "abcd", "12345678", "ERR CMD HAS_AUTH")
describe "KEY" $ do
it "valid syntax" $ (sampleSig, "bcda", "12345678", "KEY " <> samplePubKey) >#> ("", "bcda", "12345678", "ERR AUTH")
it "no parameters" $ (sampleSig, "cdab", "12345678", "KEY") >#> ("", "cdab", "12345678", "ERR CMD SYNTAX")