diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index 75c5080ec..aad2f9ead 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -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 diff --git a/migrations/20210101_initial.sql b/migrations/20210101_initial.sql index 4c1e617c9..1c89060cf 100644 --- a/migrations/20210101_initial.sql +++ b/migrations/20210101_initial.sql @@ -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, diff --git a/protocol/simplex-messaging.md b/protocol/simplex-messaging.md index 1ae222b1d..fb553964a 100644 --- a/protocol/simplex-messaging.md +++ b/protocol/simplex-messaging.md @@ -425,10 +425,11 @@ x509encoded = 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 diff --git a/simplexmq.cabal b/simplexmq.cabal index 457169cb6..b50e86e7f 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -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 diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 20d39a6e2..0e799d9a1 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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 " 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 " 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 diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 9dcf023eb..35434ef83 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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 " $ \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 " $ \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 diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 6251e6f80..10977ea19 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -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 ) 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 } diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 2fd664ee4..af6f4a379 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -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 } diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index adecc4add..306bf8059 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -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 diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 0dc0ac929..f51d2630e 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -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 () diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index decb0c082..b451103ab 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index f6d072aa2..6fad11f12 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -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" diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 0f173d111..68070ad24 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -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 diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index f414c71e3..a716d0dd3 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -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 diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index a59a60446..d0f2d7eaa 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -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 - } diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index a4da5ec10..b6464fff0 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -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 diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 2a0d23929..ecf16f726 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -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 () diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 4662accee..4b4c8cf5c 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -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 diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index c080641ae..f5e260eaf 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -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 = diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 5c4a2e6e8..caf33b604 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -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")