diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index cecfb6a62..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 ((.:), (.:.)) @@ -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 diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index aedb5afda..8de79cee5 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -387,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/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index ca0703153..af6f4a379 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -22,7 +22,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol ( MsgBody, MsgId, - RcvDHSecret, + RcvDhSecret, RcvPrivateSignKey, RcvPublicVerifyKey, SndPrivateSignKey, @@ -83,7 +83,7 @@ data RcvQueue = RcvQueue -- | 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, + rcvDhSecret :: RcvDhSecret, -- | sender queue ID sndId :: Maybe SMP.SenderId, -- | key used by the sender to sign transmissions diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 0466920e0..f51d2630e 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -261,7 +261,7 @@ createSMPQueue :: SMPClient -> RcvPrivateSignKey -> RcvPublicVerifyKey -> - RcvPublicDHKey -> + RcvPublicDhKey -> ExceptT SMPClientError IO QueueIdsKeys createSMPQueue c rpKey rKey dhKey = -- TODO add signing this request too - requires changes in the server diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index cc4bd2c8f..b451103ab 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -96,6 +96,7 @@ module Simplex.Messaging.Crypto -- * NaCl crypto_box cbEncrypt, cbDecrypt, + cbNonce, -- * Encoding of RSA keys publicKeyHash, @@ -1010,6 +1011,14 @@ cbDecrypt secret nonce 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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 334491d0b..6fad11f12 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -45,8 +45,8 @@ module Simplex.Messaging.Protocol NotifierId, RcvPrivateSignKey, RcvPublicVerifyKey, - RcvPublicDHKey, - RcvDHSecret, + RcvPublicDhKey, + RcvDhSecret, SndPrivateSignKey, SndPublicVerifyKey, NtfPrivateSignKey, @@ -146,7 +146,7 @@ type QueueId = Encoded -- | Parameterized type for SMP protocol commands from all participants. data Command (a :: Party) where -- SMP recipient commands - NEW :: RcvPublicVerifyKey -> RcvPublicDHKey -> Command Recipient + NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient SUB :: Command Recipient KEY :: SndPublicVerifyKey -> Command Recipient NKEY :: NtfPublicVerifyKey -> Command Recipient @@ -187,7 +187,7 @@ instance IsString CorrId where data QueueIdsKeys = QIK { rcvId :: RecipientId, rcvSrvVerifyKey :: RcvPublicVerifyKey, - rcvPublicDHKey :: RcvPublicDHKey, + rcvPublicDHKey :: RcvPublicDhKey, sndId :: SenderId, sndSrvVerifyKey :: SndPublicVerifyKey } @@ -202,10 +202,10 @@ type RcvPrivateSignKey = C.APrivateSignKey type RcvPublicVerifyKey = C.APublicVerifyKey -- | Public key used for DH exchange to encrypt message bodies from server to recipient -type RcvPublicDHKey = C.PublicKey C.X25519 +type RcvPublicDhKey = C.PublicKey C.X25519 -- | DH Secret used to encrypt message bodies from server to recipient -type RcvDHSecret = C.DhSecret C.X25519 +type RcvDhSecret = C.DhSecret C.X25519 -- | Sender's private key used by the recipient to authorize (sign) SMP commands. -- diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 5e1545bf6..68070ad24 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -243,7 +243,7 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server OFF -> suspendQueue_ st DEL -> delQueueAndMsgs st where - createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDHKey -> m Transmission + 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 @@ -358,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 @@ -378,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, _) -> @@ -420,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) @@ -438,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/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index d7dc8035e..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 @@ -12,7 +11,7 @@ data QueueRec = QueueRec senderId :: SenderId, recipientKey :: RcvPublicVerifyKey, rcvSrvSignKey :: RcvPrivateSignKey, - rcvDhSecret :: RcvDHSecret, + rcvDhSecret :: RcvDhSecret, senderKey :: Maybe SndPublicVerifyKey, sndSrvSignKey :: SndPrivateSignKey, notifier :: Maybe (NotifierId, NtfPublicVerifyKey), diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 8368f2c2e..f5e260eaf 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -61,8 +61,8 @@ cfg = { transports = undefined, tbqSize = 1, msgQueueQuota = 4, - queueIdBytes = 12, - msgIdBytes = 6, + queueIdBytes = 24, + msgIdBytes = 24, trnSignAlg = C.SignAlg C.SEd448, storeLog = Nothing, blockSize = 8192, diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 8392d6457..caf33b604 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -43,8 +43,8 @@ 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 -> Command 'Broker -pattern Ids rId sId <- IDS (QIK rId _ _ sId _) +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 @@ -67,16 +67,17 @@ testCreateSecure (ATransport t) = it "should create (NEW) and secure (KEY) queue" $ smpTest t $ \h -> do (rPub, rKey) <- C.generateSignatureKeyPair 0 C.SEd448 - (dhPub, _ :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0 - Resp "abcd" rId1 (Ids rId sId) <- signSendRecv h rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub]) + (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" @@ -106,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" @@ -120,8 +121,9 @@ testCreateDelete (ATransport t) = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ smpTest2 t $ \rh sh -> do (rPub, rKey) <- C.generateSignatureKeyPair 0 C.SEd25519 - (dhPub, _ :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0 - Resp "abcd" rId1 (Ids rId sId) <- signSendRecv rh rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub]) + (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 0 C.SEd25519 @@ -134,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" @@ -156,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" @@ -189,72 +191,75 @@ testDuplex (ATransport t) = it "should create 2 simplex connections and exchange messages" $ smpTest2 t $ \alice bob -> do (arPub, arKey) <- C.generateSignatureKeyPair 0 C.SEd448 - (adhPub, _ :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0 - Resp "abcd" _ (Ids aRcv aSnd) <- signSendRecv alice arKey ("abcd", "", B.unwords ["NEW", C.serializeKey arPub, C.serializeKey adhPub]) + (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 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 0 C.SEd448 - (bdhPub, _ :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0 - Resp "abcd" _ (Ids bRcv bSnd) <- signSendRecv bob brKey ("abcd", "", B.unwords ["NEW", C.serializeKey brPub, C.serializeKey bdhPub]) + (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 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 0 C.SEd448 - (dhPub, _ :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0 - Resp "abcd" _ (Ids rId sId) <- signSendRecv rh1 rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub]) + (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 @@ -262,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" @@ -281,24 +286,33 @@ testWithStoreLog at@(ATransport t) = (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 () @@ -313,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 ") @@ -339,15 +359,16 @@ testWithStoreLog at@(ATransport t) = Right l -> pure l Left (_ :: SomeException) -> logSize -createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, C.APrivateSignKey) +createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret) createAndSecureQueue h sPub = do (rPub, rKey) <- C.generateSignatureKeyPair 0 C.SEd448 - (dhPub, _ :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0 - Resp "abcd" "" (Ids rId sId) <- signSendRecv h rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub]) + (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) = @@ -388,8 +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 - (dhPub, _ :: C.PrivateKey 'C.X25519) <- C.generateKeyPair' 0 - Resp "abcd" "" (Ids rId sId) <- signSendRecv rh rKey ("abcd", "", B.unwords ["NEW", C.serializeKey rPub, C.serializeKey dhPub]) + (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 @@ -400,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 @@ -429,17 +453,19 @@ testMessageNotifications (ATransport t) = (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 ()