diff --git a/rfcs/2024-02-03-deniability.md b/rfcs/2024-02-03-deniability.md new file mode 100644 index 000000000..b7bd3f7c5 --- /dev/null +++ b/rfcs/2024-02-03-deniability.md @@ -0,0 +1,51 @@ +# Repudiation for message senders + +## Problem + +We use double ratchet protocol to send messages. One of its important qualities is the use of symmetric encryption with forward secrecy, when the new key to encrypt the message is rotated after each message. This provides senders ability to plausibly deny having sent some messages, without denying having sent others. While the recipients can prove to themselves that the message was indeed sent by the sender, because it was encrypted using authenticated encryption with associated data, the recipients cannot prove it to any third party - as the message could have been encrypted by themselves, as they also have the same symmetric keys. + +To receive the messages, the recipients agree a message queue with the senders, and the commands sent to this queue are signed by the senders using the cryptographic key (Edwards curve key) of which the public counterpart was shared with the recipient in the confirmation message of SMP protocol (this confirmation message itself is not signed). + +While it was never claimed that the messaging protocol provides deniability, the deniability is often mentioned as one of the important qualities of double ratchet algorithm used in the innermost layer of e2e encryption, so without explicit disclaimer of deniability limitations, it may be assumed by the users that the system as a whole provides the same level of deniability as the double ratchet algorithm, which currently is not the case. + +While societal understanding and legal acceptance of repudiation is arguable, there was less than a decade since this quality became widely available in Signal - legal systems take longer to evolve. While the argument that the message was forged is unlikely to be accepted in the usual court cases with the ordinary people, it is likely to be considered in cases with high profile defendants, who can reasonably claim that they are the target of smear campaign and are being attributed something that they never sent - the statement that the message is forged is reasonable in such cases, and it provides plausible deniability, and the cryptographic experts invited to the hearing would attest to that. + +It’s important to both continue providing repudiation quality in communication systems, when it is appropriate, and also to educate the users about when it can be used as a reasonable defence strategy, thus improving privacy of communication and making digital off-the-record communications possible and understood both by the society and by legal systems. + +## Solution + +The proposed solution is to avoid the use of signature algorithm for server command authorization, and instead use authenticated encryption to authorize the commands sent to the server queues. If this protocol change is adopted, it could be used both for senders and recipients commands, both for consistency, and also to provide the deniability to recipients about executing any commands on the servers, in a similar way. + +The proposed approach is to use NaCl crypto_box that proves authentication and third party unforgeability and, unlike signature, repudiation guarantee. See [crypto_box docs](https://nacl.cr.yp.to/box.html): + +> The crypto_box function is designed to meet the standard notions of privacy and third-party unforgeability for a public-key authenticated-encryption scheme using nonces. The crypto_box function is not meant to provide non-repudiation. On the contrary: the crypto_box function guarantees repudiability. A receiver can freely modify a boxed message, and therefore cannot convince third parties that this particular message came from the sender. The sender and receiver are nevertheless protected against forgeries by other parties. In the terminology of https://groups.google.com/group/sci.crypt/msg/ec5c18b23b11d82c, crypto_box uses "public-key authenticators" rather than "public-key signatures.” + +DJB further writes in the link above: + +> If you were already planning to encrypt the message, using another key derived from g^xy, then you don't have to do any extra public-key work. A secret-key authenticator is easier to implement than a public-key signature, and it takes less CPU time to compute. + +So the proposed solution appears to have desired security qualities, without non-repudiation, that is undesirable in the context of private messaging. + +When queue is created or secured, the recipient would provide a DH key (X25519) to the server (either their own or received from the sender), and the server would provide its own random X25519 key per session. Then, either the authenticator will be computed in this way: + +```abnf +transmission = authenticator authorized +authenticator = crypto_box(sha512(authorized), secret = dh(client long term queue key, server session key), nonce = correlation ID) +authorized = tlsunique correlationId queueId protocol_command ; same as the currently signed part of the transmission +``` + +The authenticator is smaller in size than currently used signature size, freeing ~34 bytes from the transmission. + +This allows to retain the protocol logic and make authentication scheme configurable, both by the clients and servers, e.g. some servers might be configured to use signature for non-repudiation, and clients may be configured to either agree or disagree to that, per conversation. + +There is no required change in SMP command syntax other than allowing X25519 key instead of Ed signature keys passed to the server in NEW and KEY commands. We could add support for migration of the existing queues to the new authorization scheme, but it is not strictly required, as the clients provide a mechanism to rotate the receiving addresses (currently manually, and once automated all queues will be rotated). On another hand, per queue key and identifiers rotation is cheaper than negotiating the new queue (it can be done between client and server, without the involvement of another party), and could be considered as an independent improvement. + +## Migration plan + +As this new scheme breaks backward compatibility, as the new scheme requires additional keys in protocol handshake, and current implementation does not support forward compatible header extension, we have to migrate in multiple steps, to minimize any disruption to the users. + +1. Upgrade clients for forward compatibility of the protocol handshake (ignore extra bytes) - 5.5.3. +2. Add support for handshake and version negotiation to XFTP - 5.5.4 or 5.6. +3. Upgrade clients to drop support of SMP earlier than v4 (batching) and also drop support of old double ratchet protocol and old handshake - 5.6. +4. Upgrade servers to offer SMP v7 with support for new authorization - by the time 5.6 is released. +5. Upgrade clients to require server support for SMP v7 / new authorization scheme and start using it - 5.7 or 5.8. At this point the old version of the servers will not be supported, as maintaining this backward compatibility would substantially increase the complexity and logic of the client - at the point of generating the key we do not even know which server version will be used. diff --git a/rfcs/2024-02-12-encryption.md b/rfcs/2024-02-12-encryption.md new file mode 100644 index 000000000..37a936ae4 --- /dev/null +++ b/rfcs/2024-02-12-encryption.md @@ -0,0 +1,33 @@ +# Transmission encryption + +## Problems + +### Protection of meta-data from sending proxy + +The SEND commands and message queue IDs need to be encrypted so that sending proxy cannot see how many queues exist on each server. + +Correlation IDs need to be random and can be re-used as nonces so that the destination relay cannot use the increasing correlation IDs that are sent in v6 of the protocol to track the sender. + +### Protection of the traffic from the attacker who compromised TLS + +Currently, even though different sending and receiving queue IDs are used, the attacker who compromised TLS could do statistical analysis and in this way correlate queue IDs of senders and recipients, and therefore correlate the senders and recipients. + +## Possible solutions + +1. Encrypt sent messages, other commands and their responses in the additional envelope, irrespective of whether proxy is used or not. In this case the requestion transmission could have this syntax: + +```abnf +encReqTransmission = pubKey nonce encrypted(reqTransmission) +reqTransmission = respNonce entityId command + +encRespTransmission = replyNonce encrypted(respTransmission) +respTransmission = entityId command +``` + +The keys to encrypt and decrypt both the command and responses would be computed as curve25519 from the key sent together with command and server session key. For the requests, the nonce has to be random and sent outside of the encrypted envelopt, but for the response respNonce would be taken from inside of the encrypted envelope and it would also be used for correlating commands and responses. This way the attacker who could compromise TLS would not be able to correlate the commands and responses, and also observe entity IDs. + +2. The remaining question is to how encrypt and decrypt messages delivered not in response to the commands. + +The possible options are: +- restore client session key only for that purpose, but do not forward this key to the destination proxy for sent messages. Then the messages can be sent with a random replyNonce and the key would be computed from session keys. The advantage here is that we won't need to parameterize handles as both client and server would have session keys. The downside that we would have to either somehow differentiate messages and responses, either by some flag that would allow some correlation or just by the absense of replyNonce in the lookup map - that is if the client can find replyNonce, it would use the associated key to decrypt, and if not it would use session key. +- use the same key that was sent with SUB or ACK command. This is much more complex, and would only have some upside if we were to introduce receiving proxies (to conceal transport sessions from the receiving relays for the recipients). diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 9489f52c1..84c99eb48 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -45,7 +45,7 @@ import Simplex.Messaging.Protocol RecipientId, SenderId, ) -import Simplex.Messaging.Transport (supportedParameters) +import Simplex.Messaging.Transport (THandleParams (..), supportedParameters) import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.Client @@ -57,6 +57,7 @@ import UnliftIO.Directory data XFTPClient = XFTPClient { http2Client :: HTTP2Client, transportSession :: TransportSession FileResponse, + thParams :: THandleParams, config :: XFTPClientConfig } @@ -98,7 +99,9 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkC let usePort = if null port then "443" else port clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected - let c = XFTPClient {http2Client, transportSession, config} + let HTTP2Client {sessionId} = http2Client + thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True} + c = XFTPClient {http2Client, thParams, transportSession, config} atomically $ writeTVar clientVar $ Just c pure c @@ -131,21 +134,21 @@ xftpClientError = \case HCNetworkError -> PCENetworkError HCIOError e -> PCEIOError e -sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) -sendXFTPCommand c@XFTPClient {http2Client = HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do +sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) +sendXFTPCommand c@XFTPClient {thParams} pKey fId cmd chunkSpec_ = do t <- liftEither . first PCETransportError $ - xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd) + xftpEncodeAuthTransmission thParams pKey ("", fId, FileCmd (sFileParty @p) cmd) sendXFTPTransmission c t chunkSpec_ sendXFTPTransmission :: XFTPClient -> ByteString -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) -sendXFTPTransmission XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} t chunkSpec_ = do +sendXFTPTransmission XFTPClient {config, thParams, http2Client} t chunkSpec_ = do let req = H.requestStreaming N.methodPost "/" [] streamBody reqTimeout = (\XFTPChunkSpec {chunkSize} -> chunkTimeout config chunkSize) <$> chunkSpec_ - HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req reqTimeout + HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2Client req reqTimeout when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK -- TODO validate that the file ID is the same as in the request? - (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission sessionId bodyHead + (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission thParams bodyHead case respOrErr of Right r -> case protocolError r of Just e -> throwError $ PCEProtocolError e @@ -163,9 +166,9 @@ sendXFTPTransmission XFTPClient {config, http2Client = http2@HTTP2Client {sessio createXFTPChunk :: XFTPClient -> - C.APrivateSignKey -> + C.APrivateAuthKey -> FileInfo -> - NonEmpty C.APublicVerifyKey -> + NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) createXFTPChunk c spKey file rcps auth_ = @@ -173,17 +176,17 @@ createXFTPChunk c spKey file rcps auth_ = (FRSndIds sId rIds, body) -> noFile body (sId, rIds) (r, _) -> throwError . PCEUnexpectedResponse $ bshow r -addXFTPRecipients :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> NonEmpty C.APublicVerifyKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId) +addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId) addXFTPRecipients c spKey fId rcps = sendXFTPCommand c spKey fId (FADD rcps) Nothing >>= \case (FRRcvIds rIds, body) -> noFile body rIds (r, _) -> throwError . PCEUnexpectedResponse $ bshow r -uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO () +uploadXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO () uploadXFTPChunk c spKey fId chunkSpec = sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse -downloadXFTPChunk :: TVar ChaChaDRG -> XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () +downloadXFTPChunk :: TVar ChaChaDRG -> XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do (rDhKey, rpDhKey) <- atomically $ C.generateKeyPair g sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case @@ -205,17 +208,17 @@ downloadXFTPChunk g c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec { chunkTimeout :: XFTPClientConfig -> Word32 -> Int chunkTimeout config chunkSize = fromIntegral $ (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1 -deleteXFTPChunk :: XFTPClient -> C.APrivateSignKey -> SenderId -> ExceptT XFTPClientError IO () +deleteXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> SenderId -> ExceptT XFTPClientError IO () deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse -ackXFTPChunk :: XFTPClient -> C.APrivateSignKey -> RecipientId -> ExceptT XFTPClientError IO () +ackXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> RecipientId -> ExceptT XFTPClientError IO () ackXFTPChunk c rpKey rId = sendXFTPCommand c rpKey rId FACK Nothing >>= okResponse pingXFTP :: XFTPClient -> ExceptT XFTPClientError IO () -pingXFTP c@XFTPClient {http2Client = HTTP2Client {sessionId}} = do +pingXFTP c@XFTPClient {thParams} = do t <- liftEither . first PCETransportError $ - xftpEncodeTransmission sessionId Nothing ("", "", FileCmd SFRecipient PING) + xftpEncodeTransmission thParams ("", "", FileCmd SFRecipient PING) (r, _) <- sendXFTPTransmission c t Nothing case r of FRPong -> pure () diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 906966fb0..e1ef9f0d8 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -63,7 +63,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, XFTPServer, XFTPServerWithAuth) +import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateAuthKey, XFTPServer, XFTPServerWithAuth) import Simplex.Messaging.Server.CLI (getCliCommand') import Simplex.Messaging.Util (groupAllOn, ifM, tshow, whenM) import System.Exit (exitFailure) @@ -209,7 +209,7 @@ cliCommandP = data SentFileChunk = SentFileChunk { chunkNo :: Int, sndId :: SenderId, - sndPrivateKey :: SndPrivateSignKey, + sndPrivateKey :: SndPrivateAuthKey, chunkSize :: FileSize Word32, digest :: FileDigest, replicas :: [SentFileChunkReplica] @@ -218,7 +218,7 @@ data SentFileChunk = SentFileChunk data SentFileChunkReplica = SentFileChunkReplica { server :: XFTPServer, - recipients :: [(ChunkReplicaId, C.APrivateSignKey)] + recipients :: [(ChunkReplicaId, C.APrivateAuthKey)] } deriving (Eq, Show) @@ -227,7 +227,7 @@ data SentRecipientReplica = SentRecipientReplica server :: XFTPServer, rcvNo :: Int, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, + replicaKey :: C.APrivateAuthKey, digest :: FileDigest, chunkSize :: FileSize Word32 } @@ -319,8 +319,8 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk) uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..." - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519 g) + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + rKeys <- atomically $ L.fromList <$> replicateM numRecipients (C.generateAuthKeyPair C.SEd25519 g) digest <- liftIO $ getChunkDigest chunkSpec let ch = FileInfo {sndKey, size = fromIntegral chunkSize, digest} c <- withRetry retryCount $ getXFTPServerClient a xftpServer @@ -388,7 +388,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re sentChunks -- SentFileChunk having sndId and sndPrivateKey represents the current implementation's limitation -- that sender uploads each chunk only to one server, so we can use the first replica's server for FileChunkReplica - sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateSignKey -> [FileChunkReplica] + sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateAuthKey -> [FileChunkReplica] sndReplicas [] _ _ = [] sndReplicas (SentFileChunkReplica {server} : _) replicaId replicaKey = [FileChunkReplica {server, replicaId, replicaKey}] writeFileDescriptions :: String -> [FileDescription 'FRecipient] -> FileDescription 'FSender -> IO ([FilePath], FilePath) diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index bf5c91634..58bcb9df3 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/src/Simplex/FileTransfer/Description.hs @@ -135,7 +135,7 @@ data FileChunk = FileChunk data FileChunkReplica = FileChunkReplica { server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey + replicaKey :: C.APrivateAuthKey } deriving (Eq, Show) @@ -179,7 +179,7 @@ data FileServerReplica = FileServerReplica { chunkNo :: Int, server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, + replicaKey :: C.APrivateAuthKey, digest :: Maybe FileDigest, chunkSize :: Maybe (FileSize Word32) } diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 5602c4268..a9de56ddb 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} @@ -24,6 +25,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import Data.Type.Equality import Data.Word (Word32) +import Simplex.Messaging.Client (authTransmission) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -38,20 +40,22 @@ import Simplex.Messaging.Protocol ProtocolMsgTag (..), ProtocolType (..), RcvPublicDhKey, - RcvPublicVerifyKey, + RcvPublicAuthKey, RecipientId, SenderId, SentRawTransmission, SignedTransmission, - SndPublicVerifyKey, + SndPublicAuthKey, Transmission, + TransmissionForAuth (..), + encodeTransmissionForAuth, encodeTransmission, messageTagP, tDecodeParseValidate, tEncodeBatch1, tParse, ) -import Simplex.Messaging.Transport (SessionId, TransportError (..)) +import Simplex.Messaging.Transport (THandleParams (..), TransportError (..)) import Simplex.Messaging.Util (bshow, (<$?>)) import Simplex.Messaging.Version @@ -148,8 +152,8 @@ instance Protocol XFTPErrorType FileResponse where _ -> Nothing data FileCommand (p :: FileParty) where - FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FSender - FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FSender + FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender + FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender FPUT :: FileCommand FSender FDEL :: FileCommand FSender FGET :: RcvPublicDhKey -> FileCommand FRecipient @@ -163,7 +167,7 @@ data FileCmd = forall p. FilePartyI p => FileCmd (SFileParty p) (FileCommand p) deriving instance Show FileCmd data FileInfo = FileInfo - { sndKey :: SndPublicVerifyKey, + { sndKey :: SndPublicAuthKey, size :: Word32, digest :: ByteString } @@ -190,18 +194,18 @@ instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse {-# INLINE fromProtocolError #-} - checkCredentials (sig, _, fileId, _) cmd = case cmd of + checkCredentials (auth, _, fileId, _) cmd = case cmd of -- FNEW must not have signature and chunk ID FNEW {} - | isNothing sig -> Left $ CMD NO_AUTH + | isNothing auth -> Left $ CMD NO_AUTH | not (B.null fileId) -> Left $ CMD HAS_AUTH | otherwise -> Right cmd PING - | isNothing sig && B.null fileId -> Right cmd + | isNothing auth && B.null fileId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and queue ID _ - | isNothing sig || B.null fileId -> Left $ CMD NO_AUTH + | isNothing auth || B.null fileId -> Left $ CMD NO_AUTH | otherwise -> Right cmd instance ProtocolEncoding XFTPErrorType FileCmd where @@ -401,23 +405,25 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of Just Refl -> Just c _ -> Nothing -xftpEncodeTransmission :: ProtocolEncoding e c => SessionId -> Maybe C.APrivateSignKey -> Transmission c -> Either TransportError ByteString -xftpEncodeTransmission sessionId pKey (corrId, fId, msg) = do - let t = encodeTransmission currentXFTPVersion sessionId (corrId, fId, msg) - xftpEncodeBatch1 $ signTransmission t - where - signTransmission :: ByteString -> SentRawTransmission - signTransmission t = ((`C.sign` t) <$> pKey, t) +xftpEncodeAuthTransmission :: ProtocolEncoding e c => THandleParams -> C.APrivateAuthKey -> Transmission c -> Either TransportError ByteString +xftpEncodeAuthTransmission thParams pKey (corrId, fId, msg) = do + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, fId, msg) + xftpEncodeBatch1 . (,tToSend) =<< authTransmission Nothing (Just pKey) corrId tForAuth + +xftpEncodeTransmission :: ProtocolEncoding e c => THandleParams -> Transmission c -> Either TransportError ByteString +xftpEncodeTransmission thParams (corrId, fId, msg) = do + let t = encodeTransmission thParams (corrId, fId, msg) + xftpEncodeBatch1 (Nothing, t) -- this function uses batch syntax but puts only one transmission in the batch xftpEncodeBatch1 :: SentRawTransmission -> Either TransportError ByteString xftpEncodeBatch1 t = first (const TELargeMsg) $ C.pad (tEncodeBatch1 t) xftpBlockSize -xftpDecodeTransmission :: ProtocolEncoding e c => SessionId -> ByteString -> Either XFTPErrorType (SignedTransmission e c) -xftpDecodeTransmission sessionId t = do +xftpDecodeTransmission :: ProtocolEncoding e c => THandleParams -> ByteString -> Either XFTPErrorType (SignedTransmission e c) +xftpDecodeTransmission thParams t = do t' <- first (const BLOCK) $ C.unPad t - case tParse True t' of - t'' :| [] -> Right $ tDecodeParseValidate sessionId currentXFTPVersion t'' + case tParse thParams t' of + t'' :| [] -> Right $ tDecodeParseValidate thParams t'' _ -> Left BLOCK $(J.deriveJSON (enumJSON $ dropPrefix "F") ''FileParty) diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index f4b725462..158429d79 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -47,10 +47,11 @@ import Simplex.FileTransfer.Transport import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicVerifyKey, RecipientId) -import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature) +import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicAuthKey, RecipientId, TransmissionAuth) +import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdAuthorization) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Stats +import Simplex.Messaging.Transport (THandleParams (..)) import Simplex.Messaging.Transport.Buffer (trimCR) import Simplex.Messaging.Transport.HTTP2 import Simplex.Messaging.Transport.HTTP2.Server @@ -66,6 +67,14 @@ import qualified UnliftIO.Exception as E type M a = ReaderT XFTPEnv IO a +data XFTPTransportRequest = + XFTPTransportRequest + { thParams :: THandleParams, + reqBody :: HTTP2Body, + request :: H.Request, + sendResponse :: H.Response -> IO () + } + runXFTPServer :: XFTPServerConfig -> IO () runXFTPServer cfg = do started <- newEmptyTMVarIO @@ -86,7 +95,8 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira liftIO $ runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams transportConfig inactiveClientExpiration $ \sessionId r sendResponse -> do reqBody <- getHTTP2Body r xftpBlockSize - processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} `runReaderT` env + let thParams = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = currentXFTPVersion, thAuth = Nothing, implySessId = False, batch = True} + processRequest XFTPTransportRequest {thParams, request = r, reqBody, sendResponse} `runReaderT` env stopServer :: M () stopServer = do @@ -215,11 +225,11 @@ data ServerFile = ServerFile sbState :: LC.SbState } -processRequest :: HTTP2Request -> M () -processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sendResponse} +processRequest :: XFTPTransportRequest -> M () +processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse} | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing | otherwise = do - case xftpDecodeTransmission sessionId bodyHead of + case xftpDecodeTransmission thParams bodyHead of Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do case cmdOrErr of Right cmd -> do @@ -233,7 +243,7 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen where sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M () sendXFTPResponse (corrId, fId, resp) serverFile_ = do - let t_ = xftpEncodeTransmission sessionId Nothing (corrId, fId, resp) + let t_ = xftpEncodeTransmission thParams (corrId, fId, resp) liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_ where streamBody t_ send done = do @@ -250,10 +260,10 @@ processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sen data VerificationResult = VRVerified XFTPRequest | VRFailed -verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult -verifyXFTPTransmission sig_ signed fId cmd = +verifyXFTPTransmission :: Maybe TransmissionAuth -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult +verifyXFTPTransmission tAuth authorized fId cmd = case cmd of - FileCmd SFSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file + FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing FileCmd party _ -> verifyCmd party where @@ -264,8 +274,9 @@ verifyXFTPTransmission sig_ signed fId cmd = where verify = \case Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k - _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed - req `verifyWith` k = if verifyCmdSignature sig_ signed k then VRVerified req else VRFailed + _ -> maybe False (dummyVerifyCmd Nothing authorized) tAuth `seq` VRFailed + -- TODO verify with DH authorization + req `verifyWith` k = if verifyCmdAuthorization Nothing tAuth authorized k then VRVerified req else VRFailed processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile) processXFTPRequest HTTP2Body {bodyPart} = \case @@ -286,7 +297,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) - createFile :: FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse + createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M FileResponse createFile file rks = do st <- asks store r <- runExceptT $ do @@ -310,7 +321,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case retryAdd n $ \sId -> runExceptT $ do ExceptT $ addFile st sId file ts pure sId - addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicVerifyKey -> M (Either XFTPErrorType FileRecipient) + addRecipientRetry :: FileStore -> Int -> XFTPFileId -> RcvPublicAuthKey -> M (Either XFTPErrorType FileRecipient) addRecipientRetry st n sId rpk = retryAdd n $ \rId -> runExceptT $ do let rcp = FileRecipient rId rpk @@ -323,7 +334,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case atomically (add fId) >>= \case Left DUPLICATE_ -> retryAdd (n - 1) add r -> pure r - addRecipients :: XFTPFileId -> NonEmpty RcvPublicVerifyKey -> M FileResponse + addRecipients :: XFTPFileId -> NonEmpty RcvPublicAuthKey -> M FileResponse addRecipients sId rks = do st <- asks store r <- runExceptT $ do diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index 89763608a..4d5d67b07 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -24,7 +24,7 @@ import Simplex.FileTransfer.Server.Stats import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Server.StoreLog import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey) +import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams) import Simplex.Messaging.Util (tshow) @@ -103,6 +103,6 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi pure XFTPEnv {config, store, storeLog, random, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} data XFTPRequest - = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth) + = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 337214e62..031c46f5b 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -31,14 +31,14 @@ import Data.Time.Clock.System (SystemTime (..)) import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPErrorType (..), XFTPFileId) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId) +import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM, ($>>=)) data FileStore = FileStore { files :: TMap SenderId FileRec, - recipients :: TMap RecipientId (SenderId, RcvPublicVerifyKey), + recipients :: TMap RecipientId (SenderId, RcvPublicAuthKey), usedStorage :: TVar Int64 } @@ -51,7 +51,7 @@ data FileRec = FileRec } deriving (Eq) -data FileRecipient = FileRecipient RecipientId RcvPublicVerifyKey +data FileRecipient = FileRecipient RecipientId RcvPublicAuthKey instance StrEncoding FileRecipient where strEncode (FileRecipient rId rKey) = strEncode rId <> ":" <> strEncode rKey @@ -113,7 +113,7 @@ deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do TM.delete rId recipients modifyTVar' recipientIds $ S.delete rId -getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey)) +getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicAuthKey)) getFile st party fId = case party of SFSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f)) SFRecipient -> diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index dcfbb757e..f2ee311b7 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -31,7 +31,7 @@ import Data.Time.Clock.System (SystemTime) import Simplex.FileTransfer.Protocol (FileInfo (..)) import Simplex.FileTransfer.Server.Store import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId) +import Simplex.Messaging.Protocol (RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (bshow, whenM) import System.Directory (doesFileExist, renameFile) @@ -109,7 +109,7 @@ writeFileStore s FileStore {files, recipients} = do allRcps <- readTVarIO recipients readTVarIO files >>= mapM_ (logFile allRcps) where - logFile :: Map RecipientId (SenderId, RcvPublicVerifyKey) -> FileRec -> IO () + logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO () logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} = do logAddFile s senderId fileInfo createdAt (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index 513822a82..21967a3cd 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -102,7 +102,7 @@ data RcvFileChunkReplica = RcvFileChunkReplica { rcvChunkReplicaId :: Int64, server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, + replicaKey :: C.APrivateAuthKey, received :: Bool, delay :: Maybe Int64, retries :: Int @@ -190,8 +190,8 @@ sndChunkSize SndFileChunk {chunkSpec = XFTPChunkSpec {chunkSize}} = chunkSize data NewSndChunkReplica = NewSndChunkReplica { server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, - rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)] + replicaKey :: C.APrivateAuthKey, + rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)] } deriving (Eq, Show) @@ -199,8 +199,8 @@ data SndFileChunkReplica = SndFileChunkReplica { sndChunkReplicaId :: Int64, server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, - rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)], + replicaKey :: C.APrivateAuthKey, + rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)], replicaStatus :: SndFileReplicaStatus, delay :: Maybe Int64, retries :: Int @@ -230,7 +230,7 @@ data DeletedSndChunkReplica = DeletedSndChunkReplica userId :: Int64, server :: XFTPServer, replicaId :: ChunkReplicaId, - replicaKey :: C.APrivateSignKey, + replicaKey :: C.APrivateAuthKey, chunkDigest :: FileDigest, delay :: Maybe Int64, retries :: Int diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index da309d545..587a206fd 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -162,9 +162,10 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicVerifyKey, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth) +import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth, ProtocolTypeI (..), SMPMsgMeta, SProtocolType (..), SndPublicAuthKey, SubscriptionMode (..), UserProtocol, XFTPServerWithAuth) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) +import Simplex.Messaging.Transport (THandleParams (sessionId)) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util import Simplex.Messaging.Version @@ -1037,7 +1038,7 @@ runCommandProcessing c@AgentClient {subQ} server_ Worker {doWork} = do ack srv rId srvMsgId = do rq <- withStore c $ \db -> getRcvQueue db connId srv rId ackQueueMessage c rq srvMsgId - secure :: RcvQueue -> SMP.SndPublicVerifyKey -> m () + secure :: RcvQueue -> SMP.SndPublicAuthKey -> m () secure rq senderKey = do secureQueue c rq senderKey withStore' c $ \db -> setRcvQueueStatus db rq Secured @@ -1641,10 +1642,10 @@ registerNtfToken' c suppliedDeviceToken suppliedNtfMode = createToken = getNtfServer c >>= \case Just ntfServer -> - asks (cmdSignAlg . config) >>= \case - C.SignAlg a -> do + asks (rcvAuthAlg . config) >>= \case + C.AuthAlg a -> do g <- asks random - tknKeys <- atomically $ C.generateSignatureKeyPair a g + tknKeys <- atomically $ C.generateAuthKeyPair a g dhKeys <- atomically $ C.generateKeyPair g let tkn = newNtfToken suppliedDeviceToken ntfServer tknKeys dhKeys suppliedNtfMode withStore' c (`createNtfToken` tkn) @@ -2067,7 +2068,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s where processEND = \case Just (Right clnt) - | sessId == sessionId clnt -> do + | sessId == sessionId (thParams clnt) -> do removeSubscription c connId notify' END pure "END" @@ -2106,7 +2107,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s parseMessage :: Encoding a => ByteString -> m a parseMessage = liftEither . parse smpP (AGENT A_MESSAGE) - smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicVerifyKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m () + smpConfirmation :: SMP.MsgId -> Connection c -> C.APublicAuthKey -> C.PublicKeyX25519 -> Maybe (CR.E2ERatchetParams 'C.X448) -> ByteString -> Version -> Version -> m () smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo smpClientVersion agentVersion = do logServer "<--" c srv rId $ "MSG :" <> logSecret srvMsgId AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config @@ -2252,7 +2253,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s _ -> throwError $ AGENT A_VERSION -- processed by queue recipient - qKeyMsg :: SMP.MsgId -> NonEmpty (SMPQueueInfo, SndPublicVerifyKey) -> Connection 'CDuplex -> m () + qKeyMsg :: SMP.MsgId -> NonEmpty (SMPQueueInfo, SndPublicAuthKey) -> Connection 'CDuplex -> m () qKeyMsg srvMsgId ((qInfo, senderKey) :| _) conn'@(DuplexConnection cData' rqs _) = do when (ratchetSyncSendProhibited cData') $ throwError $ AGENT (A_QUEUE "ratchet is not synchronized") clientVRange <- asks $ smpClientVRange . config @@ -2506,9 +2507,9 @@ agentRatchetDecrypt' g db connId rc encAgentMsg = do newSndQueue :: (MonadUnliftIO m, MonadReader Env m) => UserId -> ConnId -> Compatible SMPQueueInfo -> m NewSndQueue newSndQueue userId connId (Compatible (SMPQueueInfo smpClientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey = rcvE2ePubDhKey})) = do - C.SignAlg a <- asks $ cmdSignAlg . config + C.AuthAlg a <- asks $ sndAuthAlg . config g <- asks random - (sndPublicKey, sndPrivateKey) <- atomically $ C.generateSignatureKeyPair a g + (sndPublicKey, sndPrivateKey) <- atomically $ C.generateAuthKeyPair a g (e2ePubKey, e2ePrivKey) <- atomically $ C.generateKeyPair g pure SndQueue diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 9c6571f14..ad28e79de 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -200,9 +200,10 @@ import Simplex.Messaging.Protocol QueueIdsKeys (..), RcvMessage (..), RcvNtfPublicDhKey, + NtfPublicAuthKey, SMPMsgMeta (..), SProtocolType (..), - SndPublicVerifyKey, + SndPublicAuthKey, SubscriptionMode (..), UserProtocol, XFTPServer, @@ -212,6 +213,7 @@ import Simplex.Messaging.Protocol import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Transport (THandleParams (..)) import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util import Simplex.Messaging.Version @@ -507,8 +509,9 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, connectClient :: SMPClientVar -> m SMPClient connectClient v = do cfg <- getClientConfig c smpCfg + g <- asks random u <- askUnliftIO - liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg (Just msgQ) $ clientDisconnected u v) + liftEitherError (protocolClientError SMP $ B.unpack $ strEncode srv) (getProtocolClient g tSess cfg (Just msgQ) $ clientDisconnected u v) clientDisconnected :: UnliftIO m -> SMPClientVar -> SMPClient -> IO () clientDisconnected u v client = do @@ -606,7 +609,8 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d connectClient :: NtfClientVar -> m NtfClient connectClient v = do cfg <- getClientConfig c ntfCfg - liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient tSess cfg Nothing $ clientDisconnected v) + g <- asks random + liftEitherError (protocolClientError NTF $ B.unpack $ strEncode srv) (getProtocolClient g tSess cfg Nothing $ clientDisconnected v) clientDisconnected :: NtfClientVar -> NtfClient -> IO () clientDisconnected v client = do @@ -860,17 +864,18 @@ data ProtocolTestFailure = ProtocolTestFailure runSMPServerTest :: AgentMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe ProtocolTestFailure) runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do cfg <- getClientConfig c smpCfg - C.SignAlg a <- asks $ cmdSignAlg . config + C.AuthAlg ra <- asks $ rcvAuthAlg . config + C.AuthAlg sa <- asks $ sndAuthAlg . config g <- asks random liftIO $ do let tSess = (userId, srv, Nothing) - getProtocolClient tSess cfg Nothing (\_ -> pure ()) >>= \case + getProtocolClient g tSess cfg Nothing (\_ -> pure ()) >>= \case Right smp -> do - (rKey, rpKey) <- atomically $ C.generateSignatureKeyPair a g - (sKey, _) <- atomically $ C.generateSignatureKeyPair a g + rKeys@(_, rpKey) <- atomically $ C.generateAuthKeyPair ra g + (sKey, _) <- atomically $ C.generateAuthKeyPair sa g (dhKey, _) <- atomically $ C.generateKeyPair g r <- runExceptT $ do - SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rpKey rKey dhKey auth SMSubscribe + SMP.QIK {rcvId} <- liftError (testErr TSCreateQueue) $ createSMPQueue smp rKeys dhKey auth SMSubscribe liftError (testErr TSSecureQueue) $ secureSMPQueue smp rpKey rcvId sKey liftError (testErr TSDeleteQueue) $ deleteSMPQueue smp rpKey rcvId ok <- tcpTimeout (networkConfig cfg) `timeout` closeProtocolClient smp @@ -894,8 +899,8 @@ runXFTPServerTest c userId (ProtoServerWithAuth srv auth) = do let tSess = (userId, srv, Nothing) X.getXFTPClient tSess cfg {xftpNetworkConfig} (\_ -> pure ()) >>= \case Right xftp -> do - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g createTestChunk filePath digest <- liftIO $ C.sha256Hash <$> B.readFile filePath let file = FileInfo {sndKey, size = chSize, digest} @@ -948,15 +953,15 @@ getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> SubscriptionMode -> m (NewRcvQueue, SMPQueueUri) newRcvQueue c userId connId (ProtoServerWithAuth srv auth) vRange subMode = do - C.SignAlg a <- asks (cmdSignAlg . config) + C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random - (recipientKey, rcvPrivateKey) <- atomically $ C.generateSignatureKeyPair a g + rKeys@(_, rcvPrivateKey) <- atomically $ C.generateAuthKeyPair a g (dhKey, privDhKey) <- atomically $ C.generateKeyPair g (e2eDhKey, e2ePrivKey) <- atomically $ C.generateKeyPair g logServer "-->" c srv "" "NEW" tSess <- mkTransportSession c userId srv connId QIK {rcvId, sndId, rcvPublicDhKey} <- - withClient c tSess "NEW" $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth subMode + withClient c tSess "NEW" $ \smp -> createSMPQueue smp rKeys dhKey auth subMode logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId] let rq = RcvQueue @@ -1054,7 +1059,7 @@ sendTSessionBatches statCmd statBatchSize toRQ action c qs = let n = (length qs - 1) `div` statBatchSize + 1 in incClientStatN c userId smp n statCmd "OK" -sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateSignKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ()) +sendBatch :: (SMPClient -> NonEmpty (SMP.RcvPrivateAuthKey, SMP.RecipientId) -> IO (NonEmpty (Either SMPClientError ()))) -> SMPClient -> NonEmpty RcvQueue -> IO (BatchResponses SMPClientError ()) sendBatch smpCmdFunc smp qs = L.zip qs <$> smpCmdFunc smp (L.map queueCreds qs) where queueCreds RcvQueue {rcvPrivateKey, rcvId} = (rcvPrivateKey, rcvId) @@ -1114,7 +1119,7 @@ getQueueMessage :: AgentMonad m => AgentClient -> RcvQueue -> m (Maybe SMPMsgMet getQueueMessage c rq@RcvQueue {server, rcvId, rcvPrivateKey} = do atomically createTakeGetLock (v, msg_) <- withSMPClient c rq "GET" $ \smp -> - (thVersion smp,) <$> getSMPMessage smp rcvPrivateKey rcvId + (thVersion $ thParams smp,) <$> getSMPMessage smp rcvPrivateKey rcvId mapM (decryptMeta v) msg_ where decryptMeta v msg@SMP.RcvMessage {msgId} = SMP.rcvMessageMeta msgId <$> decryptSMPMessage v rq msg @@ -1132,23 +1137,23 @@ decryptSMPMessage v rq SMP.RcvMessage {msgId, msgTs, msgFlags, msgBody = SMP.Enc where decrypt = agentCbDecrypt (rcvDhSecret rq) (C.cbNonce msgId) -secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicVerifyKey -> m () +secureQueue :: AgentMonad m => AgentClient -> RcvQueue -> SndPublicAuthKey -> m () secureQueue c rq@RcvQueue {rcvId, rcvPrivateKey} senderKey = withSMPClient c rq "KEY " $ \smp -> secureSMPQueue smp rcvPrivateKey rcvId senderKey -enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> SMP.NtfPublicVerifyKey -> SMP.RcvNtfPublicDhKey -> m (SMP.NotifierId, SMP.RcvNtfPublicDhKey) +enableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> m (SMP.NotifierId, SMP.RcvNtfPublicDhKey) enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey = withSMPClient c rq "NKEY " $ \smp -> enableSMPQueueNotifications smp rcvPrivateKey rcvId notifierKey rcvNtfPublicDhKey -enableQueuesNtfs :: forall m. AgentMonad' m => AgentClient -> [(RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))] +enableQueuesNtfs :: forall m. AgentMonad' m => AgentClient -> [(RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey)] -> m [(RcvQueue, Either AgentErrorType (SMP.NotifierId, SMP.RcvNtfPublicDhKey))] enableQueuesNtfs = sendTSessionBatches "NKEY" 90 fst3 enableQueues_ where fst3 (x, _, _) = x - enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey))) + enableQueues_ :: SMPClient -> NonEmpty (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> IO (NonEmpty (RcvQueue, Either (ProtocolClientError ErrorType) (SMP.NotifierId, RcvNtfPublicDhKey))) enableQueues_ smp qs' = L.zipWith ((,) . fst3) qs' <$> enableSMPQueuesNtfs smp (L.map queueCreds qs') - queueCreds :: (RcvQueue, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateSignKey, SMP.RecipientId, SMP.NtfPublicVerifyKey, SMP.RcvNtfPublicDhKey) + queueCreds :: (RcvQueue, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) -> (SMP.RcvPrivateAuthKey, SMP.RecipientId, SMP.NtfPublicAuthKey, SMP.RcvNtfPublicDhKey) queueCreds (RcvQueue {rcvPrivateKey, rcvId}, notifierKey, rcvNtfPublicDhKey) = (rcvPrivateKey, rcvId, notifierKey, rcvNtfPublicDhKey) disableQueueNotifications :: AgentMonad m => AgentClient -> RcvQueue -> m () @@ -1193,7 +1198,7 @@ sendAgentMessage c sq@SndQueue {sndId, sndPrivateKey} msgFlags agentMsg = msg <- agentCbEncrypt sq Nothing $ smpEncode clientMsg liftClient SMP (clientServer smp) $ sendSMPMessage smp (Just sndPrivateKey) sndId msgFlags msg -agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519) +agentNtfRegisterToken :: AgentMonad m => AgentClient -> NtfToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> m (NtfTokenId, C.PublicKeyX25519) agentNtfRegisterToken c NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey = withClient c (0, ntfServer, Nothing) "TNEW" $ \ntf -> ntfRegisterToken ntf ntfPrivKey (NewNtfTkn deviceToken ntfPubKey pubDhKey) @@ -1217,7 +1222,7 @@ agentNtfEnableCron :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> W agentNtfEnableCron c tknId NtfToken {ntfServer, ntfPrivKey} interval = withNtfClient c ntfServer tknId "TCRN" $ \ntf -> ntfEnableCron ntf ntfPrivKey tknId interval -agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateSignKey -> m NtfSubscriptionId +agentNtfCreateSubscription :: AgentMonad m => AgentClient -> NtfTokenId -> NtfToken -> SMPQueueNtf -> SMP.NtfPrivateAuthKey -> m NtfSubscriptionId agentNtfCreateSubscription c tknId NtfToken {ntfServer, ntfPrivKey} smpQueue nKey = withNtfClient c ntfServer tknId "SNEW" $ \ntf -> ntfCreateSubscription ntf ntfPrivKey (NewNtfSub tknId smpQueue nKey) @@ -1237,7 +1242,7 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se agentXFTPNewChunk :: AgentMonad m => AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> m NewSndChunkReplica agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do rKeys <- xftpRcvKeys n - (sndKey, replicaKey) <- atomically . C.generateSignatureKeyPair C.SEd25519 =<< asks random + (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = fromIntegral chunkSize, digest = chunkDigest} logServer "-->" c srv "" "FNEW" tSess <- mkTransportSession c userId srv chunkDigest @@ -1249,7 +1254,7 @@ agentXFTPUploadChunk :: AgentMonad m => AgentClient -> UserId -> FileDigest -> S agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = withXFTPClient c (userId, server, chunkDigest) "FPUT" $ \xftp -> X.uploadXFTPChunk xftp replicaKey fId chunkSpec -agentXFTPAddRecipients :: AgentMonad m => AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> Int -> m (NonEmpty (ChunkReplicaId, C.APrivateSignKey)) +agentXFTPAddRecipients :: AgentMonad m => AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> Int -> m (NonEmpty (ChunkReplicaId, C.APrivateAuthKey)) agentXFTPAddRecipients c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} n = do rKeys <- xftpRcvKeys n rIds <- withXFTPClient c (userId, server, chunkDigest) "FADD" $ \xftp -> X.addXFTPRecipients xftp replicaKey fId (L.map fst rKeys) @@ -1259,14 +1264,14 @@ agentXFTPDeleteChunk :: AgentMonad m => AgentClient -> UserId -> DeletedSndChunk agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey, chunkDigest = FileDigest chunkDigest} = withXFTPClient c (userId, server, chunkDigest) "FDEL" $ \xftp -> X.deleteXFTPChunk xftp replicaKey fId -xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.ASignatureKeyPair) +xftpRcvKeys :: AgentMonad m => Int -> m (NonEmpty C.AAuthKeyPair) xftpRcvKeys n = do - rKeys <- atomically . replicateM n . C.generateSignatureKeyPair C.SEd25519 =<< asks random + rKeys <- atomically . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random case L.nonEmpty rKeys of Just rKeys' -> pure rKeys' _ -> throwError $ INTERNAL "non-positive number of recipients" -xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.ASignatureKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateSignKey) +xftpRcvIdsKeys :: NonEmpty ByteString -> NonEmpty C.AAuthKeyPair -> NonEmpty (ChunkReplicaId, C.APrivateAuthKey) xftpRcvIdsKeys rIds rKeys = L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 02d172d0e..71e710473 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -57,6 +57,7 @@ import Simplex.Messaging.Client import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange) +import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Protocol (NtfServer, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange) import Simplex.Messaging.TMap (TMap) @@ -82,7 +83,8 @@ data InitialAgentServers = InitialAgentServers data AgentConfig = AgentConfig { tcpPort :: ServiceName, - cmdSignAlg :: C.SignAlg, + rcvAuthAlg :: C.AuthAlg, + sndAuthAlg :: C.AuthAlg, connIdBytes :: Int, tbqSize :: Natural, smpCfg :: ProtocolClientConfig, @@ -147,11 +149,14 @@ defaultAgentConfig :: AgentConfig defaultAgentConfig = AgentConfig { tcpPort = "5224", - cmdSignAlg = C.SignAlg C.SEd448, + -- while the current client version supports X25519, it can only be enabled once support for SMP v6 is dropped, + -- and all servers are required to support v7 to be compatible. + rcvAuthAlg = C.AuthAlg C.SEd25519, -- this will stay as Ed25519 + sndAuthAlg = C.AuthAlg C.SEd25519, -- TODO replace with X25519 when switching to v7 connIdBytes = 12, tbqSize = 64, - smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)}, - ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)}, + smpCfg = defaultSMPClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)}, + ntfCfg = defaultNTFClientConfig {defaultTransport = ("443", transport @TLS)}, xftpCfg = defaultXFTPClientConfig, reconnectInterval = defaultReconnectInterval, messageRetryInterval = defaultMessageRetryInterval, diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 5e51b2217..aa2c0e9c6 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -253,9 +253,9 @@ runNtfSMPWorker c srv Worker {doWork} = do getNtfToken >>= \case Just NtfToken {ntfTknStatus = NTActive, ntfMode = NMInstant} -> do rq <- withStore c (`getPrimaryRcvQueue` connId) - C.SignAlg a <- asks (cmdSignAlg . config) + C.AuthAlg a <- asks (rcvAuthAlg . config) g <- asks random - (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateSignatureKeyPair a g + (ntfPublicKey, ntfPrivateKey) <- atomically $ C.generateAuthKeyPair a g (rcvNtfPubDhKey, rcvNtfPrivDhKey) <- atomically $ C.generateKeyPair g (notifierId, rcvNtfSrvPubDhKey) <- enableQueueNotifications c rq ntfPublicKey rcvNtfPubDhKey let rcvNtfDhSecret = C.dh' rcvNtfSrvPubDhKey rcvNtfPrivDhKey diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 0771601ab..a56908b38 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -196,7 +196,7 @@ import Simplex.Messaging.Protocol SMPMsgMeta, SMPServer, SMPServerWithAuth, - SndPublicVerifyKey, + SndPublicAuthKey, SubscriptionMode, legacyEncodeServer, legacyServerP, @@ -776,7 +776,7 @@ instance StrEncoding MsgMeta where data SMPConfirmation = SMPConfirmation { -- | sender's public key to use for authentication of sender's commands at the recepient's server - senderKey :: SndPublicVerifyKey, + senderKey :: SndPublicAuthKey, -- | sender's DH public key for simple per-queue e2e encryption e2ePubKey :: C.PublicKeyX25519, -- | sender's information to be associated with the connection, e.g. sender's profile information @@ -1010,7 +1010,7 @@ data AMessage | -- add queue to connection (sent by recipient), with optional address of the replaced queue QADD (NonEmpty (SMPQueueUri, Maybe SndQAddr)) | -- key to secure the added queues and agree e2e encryption key (sent by sender) - QKEY (NonEmpty (SMPQueueInfo, SndPublicVerifyKey)) + QKEY (NonEmpty (SMPQueueInfo, SndPublicAuthKey)) | -- inform that the queues are ready to use (sent by recipient) QUSE (NonEmpty (SndQAddr, Bool)) | -- sent by the sender to test new queues and to complete switching diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 028b7d8ea..db1d37c06 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -37,12 +37,13 @@ import Simplex.Messaging.Protocol MsgFlags, MsgId, NotifierId, - NtfPrivateSignKey, - NtfPublicVerifyKey, + NtfPrivateAuthKey, + NtfPublicAuthKey, RcvDhSecret, RcvNtfDhSecret, - RcvPrivateSignKey, - SndPrivateSignKey, + RcvPrivateAuthKey, + SndPrivateAuthKey, + SndPublicAuthKey, ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Util ((<$?>)) @@ -75,8 +76,8 @@ data StoredRcvQueue (q :: QueueStored) = RcvQueue server :: SMPServer, -- | recipient queue ID rcvId :: SMP.RecipientId, - -- | key used by the recipient to sign transmissions - rcvPrivateKey :: RcvPrivateSignKey, + -- | key used by the recipient to authorize transmissions + rcvPrivateKey :: RcvPrivateAuthKey, -- | shared DH secret used to encrypt/decrypt message bodies from server to recipient rcvDhSecret :: RcvDhSecret, -- | private DH key related to public sent to sender out-of-band (to agree simple per-queue e2e) @@ -119,9 +120,9 @@ canAbortRcvSwitch = maybe False canAbort . rcvSwchStatus RSReceivedMessage -> False data ClientNtfCreds = ClientNtfCreds - { -- | key pair to be used by the notification server to sign transmissions - ntfPublicKey :: NtfPublicVerifyKey, - ntfPrivateKey :: NtfPrivateSignKey, + { -- | key pair to be used by the notification server to authorize transmissions + ntfPublicKey :: NtfPublicAuthKey, + ntfPrivateKey :: NtfPrivateAuthKey, -- | queue ID to be used by the notification server for NSUB command notifierId :: NotifierId, -- | shared DH secret used to encrypt/decrypt notification metadata (NMsgMeta) from server to recipient @@ -140,9 +141,10 @@ data StoredSndQueue (q :: QueueStored) = SndQueue server :: SMPServer, -- | sender queue ID sndId :: SMP.SenderId, - -- | key pair used by the sender to sign transmissions - sndPublicKey :: Maybe C.APublicVerifyKey, - sndPrivateKey :: SndPrivateSignKey, + -- | key pair used by the sender to authorize transmissions + -- TODO combine keys to key pair so that types match + sndPublicKey :: Maybe SndPublicAuthKey, + sndPrivateKey :: SndPrivateAuthKey, -- | DH public key used to negotiate per-queue e2e encryption e2ePubKey :: Maybe C.PublicKeyX25519, -- | shared DH secret agreed for simple per-queue e2e encryption @@ -388,11 +390,11 @@ instance StrEncoding AgentCommandTag where data InternalCommand = ICAck SMP.RecipientId MsgId | ICAckDel SMP.RecipientId MsgId InternalId - | ICAllowSecure SMP.RecipientId SMP.SndPublicVerifyKey - | ICDuplexSecure SMP.RecipientId SMP.SndPublicVerifyKey + | ICAllowSecure SMP.RecipientId SMP.SndPublicAuthKey + | ICDuplexSecure SMP.RecipientId SMP.SndPublicAuthKey | ICDeleteConn | ICDeleteRcvQueue SMP.RecipientId - | ICQSecure SMP.RecipientId SMP.SndPublicVerifyKey + | ICQSecure SMP.RecipientId SMP.SndPublicAuthKey | ICQDelete SMP.RecipientId data InternalCommandTag diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 9865fe424..38319d31c 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -783,7 +783,7 @@ setRcvQueueNtfCreds db connId clientNtfCreds = Just ClientNtfCreds {ntfPublicKey, ntfPrivateKey, notifierId, rcvNtfDhSecret} -> (Just ntfPublicKey, Just ntfPrivateKey, Just notifierId, Just rcvNtfDhSecret) Nothing -> (Nothing, Nothing, Nothing, Nothing) -type SMPConfirmationRow = (SndPublicVerifyKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe Version) +type SMPConfirmationRow = (SndPublicAuthKey, C.PublicKeyX25519, ConnInfo, Maybe [SMPQueueInfo], Maybe Version) smpConfirmation :: SMPConfirmationRow -> SMPConfirmation smpConfirmation (senderKey, e2ePubKey, connInfo, smpReplyQueues_, smpClientVersion_) = @@ -1987,9 +1987,9 @@ rcvQueueQuery = |] toRcvQueue :: - (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateSignKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) + (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SMP.RecipientId, SMP.RcvPrivateAuthKey, SMP.RcvDhSecret, C.PrivateKeyX25519, Maybe C.DhSecretX25519, SMP.SenderId, QueueStatus) :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe RcvSwitchStatus, Maybe Version, Int) - :. (Maybe SMP.NtfPublicVerifyKey, Maybe SMP.NtfPrivateSignKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> + :. (Maybe SMP.NtfPublicAuthKey, Maybe SMP.NtfPrivateAuthKey, Maybe SMP.NotifierId, Maybe RcvNtfDhSecret) -> RcvQueue toRcvQueue ((userId, keyHash, connId, host, port, rcvId, rcvPrivateKey, rcvDhSecret, e2ePrivKey, e2eDhSecret, sndId, status) :. (dbQueueId, primary, dbReplaceQueueId, rcvSwchStatus, smpClientVersion_, deleteErrors) :. (ntfPublicKey_, ntfPrivateKey_, notifierId_, rcvNtfDhSecret_)) = let server = SMPServer host port keyHash @@ -2028,7 +2028,7 @@ sndQueueQuery = toSndQueue :: (UserId, C.KeyHash, ConnId, NonEmpty TransportHost, ServiceName, SenderId) - :. (Maybe C.APublicVerifyKey, SndPrivateSignKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) + :. (Maybe SndPublicAuthKey, SndPrivateAuthKey, Maybe C.PublicKeyX25519, C.DhSecretX25519, QueueStatus) :. (DBQueueId 'QSStored, Bool, Maybe Int64, Maybe SndSwitchStatus, Version) -> SndQueue toSndQueue @@ -2398,7 +2398,7 @@ getRcvFile db rcvFileId = runExceptT $ do |] (Only chunkId) where - toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica + toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries, host, port, keyHash) = let server = XFTPServer host port keyHash in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries} @@ -2492,7 +2492,7 @@ getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} ttl = d |] (Only rcvFileChunkReplicaId) where - toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int64, Int)) -> RcvFileChunk + toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, Bool, Maybe Int64, Int)) -> RcvFileChunk toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) = RcvFileChunk { rcvFileId, @@ -2670,12 +2670,12 @@ getSndFile db sndFileId = runExceptT $ do rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId pure (replica :: SndFileChunkReplica) {rcvIdsKeys} where - toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica + toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) = let server = XFTPServer host port keyHash in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []} -getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateSignKey)] +getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)] getChunkReplicaRecipients_ db replicaId = DB.query db @@ -2823,7 +2823,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do pure (replica :: SndFileChunkReplica) {rcvIdsKeys} pure (chunk {replicas = replicas'} :: SndFileChunk) where - toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateSignKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk + toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) = let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize} in SndFileChunk @@ -2844,7 +2844,7 @@ updateSndChunkReplicaDelay db replicaId delay = do updatedAt <- getCurrentTime DB.execute db "UPDATE snd_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE snd_file_chunk_replica_id = ?" (delay, updatedAt, replicaId) -addSndChunkReplicaRecipients :: DB.Connection -> SndFileChunkReplica -> [(ChunkReplicaId, C.APrivateSignKey)] -> IO SndFileChunkReplica +addSndChunkReplicaRecipients :: DB.Connection -> SndFileChunkReplica -> [(ChunkReplicaId, C.APrivateAuthKey)] -> IO SndFileChunkReplica addSndChunkReplicaRecipients db r@SndFileChunkReplica {sndChunkReplicaId} rcvIdsKeys = do forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do DB.execute @@ -2937,7 +2937,7 @@ getDeletedSndChunkReplica db deletedSndChunkReplicaId = |] (Only deletedSndChunkReplicaId) where - toReplica :: (UserId, ChunkReplicaId, C.APrivateSignKey, FileDigest, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> DeletedSndChunkReplica + toReplica :: (UserId, ChunkReplicaId, C.APrivateAuthKey, FileDigest, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> DeletedSndChunkReplica toReplica (userId, replicaId, replicaKey, chunkDigest, delay, retries, host, port, keyHash) = let server = XFTPServer host port keyHash in DeletedSndChunkReplica {deletedSndChunkReplicaId, userId, server, replicaId, replicaKey, chunkDigest, delay, retries} diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index a3aaaa84d..423bbddd4 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -28,7 +28,7 @@ module Simplex.Messaging.Client ( -- * Connect (disconnect) client to (from) SMP server TransportSession, - ProtocolClient (thVersion, sessionId, sessionTs), + ProtocolClient (thParams, sessionTs), SMPClient, getProtocolClient, closeProtocolClient, @@ -63,6 +63,7 @@ module Simplex.Messaging.Client NetworkConfig (..), TransportSessionMode (..), defaultClientConfig, + defaultSMPClientConfig, defaultNetworkConfig, transportClientConfig, chooseTransportHost, @@ -74,6 +75,7 @@ module Simplex.Messaging.Client -- * For testing PCTransmission, mkTransmission, + authTransmission, clientStub, ) where @@ -83,7 +85,9 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad import Control.Monad.IO.Class (liftIO) +import Control.Monad.Except import Control.Monad.Trans.Except +import Crypto.Random (ChaChaDRG) import qualified Data.Aeson.TH as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -115,12 +119,9 @@ import System.Timeout (timeout) -- Use 'getSMPClient' to connect to an SMP server and create a client handle. data ProtocolClient err msg = ProtocolClient { action :: Maybe (Async ()), - sessionId :: SessionId, + thParams :: THandleParams, sessionTs :: UTCTime, - thVersion :: Version, timeoutPerBlock :: Int, - blockSize :: Int, - batch :: Bool, client_ :: PClient err msg } @@ -131,29 +132,34 @@ data PClient err msg = PClient tcpTimeout :: Int, batchDelay :: Maybe Int, pingErrorCount :: TVar Int, - clientCorrId :: TVar Natural, + clientCorrId :: TVar ChaChaDRG, sentCommands :: TMap CorrId (Request err msg), sndQ :: TBQueue ByteString, rcvQ :: TBQueue (NonEmpty (SignedTransmission err msg)), msgQ :: Maybe (TBQueue (ServerTransmission msg)) } -clientStub :: ByteString -> STM (ProtocolClient err msg) -clientStub sessionId = do +clientStub :: TVar ChaChaDRG -> ByteString -> Version -> Maybe THandleAuth -> STM (ProtocolClient err msg) +clientStub g sessionId thVersion thAuth = do connected <- newTVar False - clientCorrId <- newTVar 0 + clientCorrId <- C.newRandomDRG g sentCommands <- TM.empty sndQ <- newTBQueue 100 rcvQ <- newTBQueue 100 return ProtocolClient { action = Nothing, - sessionId, + thParams = + THandleParams + { sessionId, + thVersion, + thAuth, + blockSize = smpBlockSize, + implySessId = thVersion >= authCmdsSMPVersion, + batch = True + }, sessionTs = undefined, - thVersion = 5, timeoutPerBlock = undefined, - blockSize = smpBlockSize, - batch = undefined, client_ = PClient { connected, @@ -173,7 +179,7 @@ clientStub sessionId = do type SMPClient = ProtocolClient ErrorType BrokerMsg -- | Type for client command data -type ClientCommand msg = (Maybe C.APrivateSignKey, EntityId, ProtoCommand msg) +type ClientCommand msg = (Maybe C.APrivateAuthKey, EntityId, ProtoCommand msg) -- | Type synonym for transmission from some SPM server queue. type ServerTransmission msg = (TransportSession msg, Version, SessionId, EntityId, msg) @@ -251,16 +257,19 @@ data ProtocolClientConfig = ProtocolClientConfig } -- | Default protocol client configuration. -defaultClientConfig :: ProtocolClientConfig -defaultClientConfig = +defaultClientConfig :: VersionRange -> ProtocolClientConfig +defaultClientConfig serverVRange = ProtocolClientConfig { qSize = 64, defaultTransport = ("443", transport @TLS), networkConfig = defaultNetworkConfig, - serverVRange = supportedSMPServerVRange, + serverVRange, batchDelay = Nothing } +defaultSMPClientConfig :: ProtocolClientConfig +defaultSMPClientConfig = defaultClientConfig supportedClientSMPRelayVRange + data Request err msg = Request { entityId :: EntityId, responseVar :: TMVar (Either (ProtocolClientError err) msg) @@ -306,8 +315,8 @@ type TransportSession msg = (UserId, ProtoServer msg, Maybe EntityId) -- -- A single queue can be used for multiple 'SMPClient' instances, -- as 'SMPServerTransmission' includes server information. -getProtocolClient :: forall err msg. Protocol err msg => TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient err msg)) -getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do +getProtocolClient :: forall err msg. Protocol err msg => TVar ChaChaDRG -> TransportSession msg -> ProtocolClientConfig -> Maybe (TBQueue (ServerTransmission msg)) -> (ProtocolClient err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient err msg)) +getProtocolClient g transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, serverVRange, batchDelay} msgQ disconnected = do case chooseTransportHost networkConfig (host srv) of Right useHost -> (atomically (mkProtocolClient useHost) >>= runClient useTransport useHost) @@ -319,7 +328,7 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, mkProtocolClient transportHost = do connected <- newTVar False pingErrorCount <- newTVar 0 - clientCorrId <- newTVar 0 + clientCorrId <- C.newRandomDRG g sentCommands <- TM.empty sndQ <- newTBQueue qSize rcvQ <- newTBQueue qSize @@ -360,13 +369,14 @@ getProtocolClient transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, p -> (p, transport @TLS) client :: forall c. Transport c => TProxy c -> PClient err msg -> TMVar (Either (ProtocolClientError err) (ProtocolClient err msg)) -> c -> IO () - client _ c cVar h = - runExceptT (protocolClientHandshake @err @msg h (keyHash srv) serverVRange) >>= \case + client _ c cVar h = do + ks <- atomically $ C.generateKeyPair g + runExceptT (protocolClientHandshake @err @msg h ks (keyHash srv) serverVRange) >>= \case Left e -> atomically . putTMVar cVar . Left $ PCETransportError e - Right th@THandle {sessionId, thVersion, blockSize, batch} -> do + Right th@THandle {params} -> do sessionTs <- getCurrentTime - let timeoutPerBlock = (blockSize * tcpTimeoutPerKb) `div` 1024 - c' = ProtocolClient {action = Nothing, client_ = c, sessionId, thVersion, sessionTs, timeoutPerBlock, blockSize, batch} + let timeoutPerBlock = (blockSize params * tcpTimeoutPerKb) `div` 1024 + c' = ProtocolClient {action = Nothing, client_ = c, thParams = params, sessionTs, timeoutPerBlock} atomically $ do writeTVar (connected c) True putTMVar cVar $ Right c' @@ -468,13 +478,12 @@ temporaryClientError = \case -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command createSMPQueue :: SMPClient -> - RcvPrivateSignKey -> - RcvPublicVerifyKey -> + C.AAuthKeyPair -> -- SMP v6 - signature key pair, SMP v7 - DH key pair RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> ExceptT SMPClientError IO QueueIdsKeys -createSMPQueue c rpKey rKey dhKey auth subMode = +createSMPQueue c (rKey, rpKey) dhKey auth subMode = sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth subMode) >>= \case IDS qik -> pure qik r -> throwE . PCEUnexpectedResponse $ bshow r @@ -482,7 +491,7 @@ createSMPQueue c rpKey rKey dhKey auth subMode = -- | Subscribe to the SMP queue. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#subscribe-to-queue -subscribeSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO () +subscribeSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () subscribeSMPQueue c rpKey rId = sendSMPCommand c (Just rpKey) rId SUB >>= \case OK -> return () @@ -490,12 +499,12 @@ subscribeSMPQueue c rpKey rId = r -> throwE . PCEUnexpectedResponse $ bshow r -- | Subscribe to multiple SMP queues batching commands if supported. -subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) +subscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) subscribeSMPQueues c qs = sendProtocolCommands c cs >>= mapM (processSUBResponse c) where cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs -streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> ([(RecipientId, Either SMPClientError ())] -> IO ()) -> IO () +streamSubscribeSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> ([(RecipientId, Either SMPClientError ())] -> IO ()) -> IO () streamSubscribeSMPQueues c qs cb = streamProtocolCommands c cs $ mapM process >=> cb where cs = L.map (\(rpKey, rId) -> (Just rpKey, rId, Cmd SRecipient SUB)) qs @@ -512,13 +521,13 @@ writeSMPMessage :: SMPClient -> RecipientId -> BrokerMsg -> IO () writeSMPMessage c rId msg = atomically $ mapM_ (`writeTBQueue` serverTransmission c rId msg) (msgQ $ client_ c) serverTransmission :: ProtocolClient err msg -> RecipientId -> msg -> ServerTransmission msg -serverTransmission ProtocolClient {thVersion, sessionId, client_ = PClient {transportSession}} entityId message = +serverTransmission ProtocolClient {thParams = THandleParams {thVersion, sessionId}, client_ = PClient {transportSession}} entityId message = (transportSession, thVersion, sessionId, entityId, message) -- | Get message from SMP queue. The server returns ERR PROHIBITED if a client uses SUB and GET via the same transport connection for the same queue -- -- https://github.covm/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#receive-a-message-from-the-queue -getSMPMessage :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage) +getSMPMessage :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO (Maybe RcvMessage) getSMPMessage c rpKey rId = sendSMPCommand c (Just rpKey) rId GET >>= \case OK -> pure Nothing @@ -528,30 +537,30 @@ getSMPMessage c 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 -> NtfPrivateSignKey -> NotifierId -> ExceptT SMPClientError IO () +subscribeSMPQueueNotifications :: SMPClient -> NtfPrivateAuthKey -> NotifierId -> ExceptT SMPClientError IO () subscribeSMPQueueNotifications = okSMPCommand NSUB -- | Subscribe to multiple SMP queues notifications batching commands if supported. -subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateSignKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ())) +subscribeSMPQueuesNtfs :: SMPClient -> NonEmpty (NtfPrivateAuthKey, NotifierId) -> IO (NonEmpty (Either SMPClientError ())) subscribeSMPQueuesNtfs = okSMPCommands NSUB -- | Secure the SMP queue by adding a sender public key. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#secure-queue-command -secureSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> SndPublicVerifyKey -> ExceptT SMPClientError IO () +secureSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> SndPublicAuthKey -> ExceptT SMPClientError IO () secureSMPQueue c rpKey rId senderKey = okSMPCommand (KEY senderKey) c rpKey rId -- | Enable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#enable-notifications-command -enableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey) +enableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> ExceptT SMPClientError IO (NotifierId, RcvNtfPublicDhKey) enableSMPQueueNotifications c rpKey rId notifierKey rcvNtfPublicDhKey = sendSMPCommand c (Just rpKey) rId (NKEY notifierKey rcvNtfPublicDhKey) >>= \case NID nId rcvNtfSrvPublicDhKey -> pure (nId, rcvNtfSrvPublicDhKey) r -> throwE . PCEUnexpectedResponse $ bshow r -- | Enable notifications for the multiple queues for push notifications server. -enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId, NtfPublicVerifyKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey))) +enableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId, NtfPublicAuthKey, RcvNtfPublicDhKey) -> IO (NonEmpty (Either SMPClientError (NotifierId, RcvNtfPublicDhKey))) enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs where cs = L.map (\(rpKey, rId, notifierKey, rcvNtfPublicDhKey) -> (Just rpKey, rId, Cmd SRecipient $ NKEY notifierKey rcvNtfPublicDhKey)) qs @@ -563,17 +572,17 @@ enableSMPQueuesNtfs c qs = L.map process <$> sendProtocolCommands c cs -- | Disable notifications for the queue for push notifications server. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#disable-notifications-command -disableSMPQueueNotifications :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO () +disableSMPQueueNotifications :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () disableSMPQueueNotifications = okSMPCommand NDEL -- | Disable notifications for multiple queues for push notifications server. -disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) +disableSMPQueuesNtfs :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) disableSMPQueuesNtfs = okSMPCommands NDEL -- | Send SMP message. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#send-message -sendSMPMessage :: SMPClient -> Maybe SndPrivateSignKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO () +sendSMPMessage :: SMPClient -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO () sendSMPMessage c spKey sId flags msg = sendSMPCommand c spKey sId (SEND flags msg) >>= \case OK -> pure () @@ -582,7 +591,7 @@ sendSMPMessage c spKey sId flags 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 -> RcvPrivateSignKey -> QueueId -> MsgId -> ExceptT SMPClientError IO () +ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO () ackSMPMessage c rpKey rId msgId = sendSMPCommand c (Just rpKey) rId (ACK msgId) >>= \case OK -> return () @@ -593,26 +602,26 @@ ackSMPMessage c rpKey rId msgId = -- 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 -> RcvPrivateSignKey -> QueueId -> ExceptT SMPClientError IO () +suspendSMPQueue :: SMPClient -> RcvPrivateAuthKey -> QueueId -> ExceptT SMPClientError IO () suspendSMPQueue = okSMPCommand OFF -- | Irreversibly delete SMP queue and all messages in it. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#delete-queue -deleteSMPQueue :: SMPClient -> RcvPrivateSignKey -> RecipientId -> ExceptT SMPClientError IO () +deleteSMPQueue :: SMPClient -> RcvPrivateAuthKey -> RecipientId -> ExceptT SMPClientError IO () deleteSMPQueue = okSMPCommand DEL -- | Delete multiple SMP queues batching commands if supported. -deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateSignKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) +deleteSMPQueues :: SMPClient -> NonEmpty (RcvPrivateAuthKey, RecipientId) -> IO (NonEmpty (Either SMPClientError ())) deleteSMPQueues = okSMPCommands DEL -okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO () +okSMPCommand :: PartyI p => Command p -> SMPClient -> C.APrivateAuthKey -> QueueId -> ExceptT SMPClientError IO () okSMPCommand cmd c pKey qId = sendSMPCommand c (Just pKey) qId cmd >>= \case OK -> return () r -> throwE . PCEUnexpectedResponse $ bshow r -okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateSignKey, QueueId) -> IO (NonEmpty (Either SMPClientError ())) +okSMPCommands :: PartyI p => Command p -> SMPClient -> NonEmpty (C.APrivateAuthKey, QueueId) -> IO (NonEmpty (Either SMPClientError ())) okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs where aCmd = Cmd sParty cmd @@ -623,14 +632,14 @@ okSMPCommands cmd c qs = L.map process <$> sendProtocolCommands c cs Left e -> Left e -- | Send SMP command -sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg +sendSMPCommand :: PartyI p => SMPClient -> Maybe C.APrivateAuthKey -> QueueId -> Command p -> ExceptT SMPClientError IO BrokerMsg sendSMPCommand c pKey qId cmd = sendProtocolCommand c pKey qId (Cmd sParty cmd) -type PCTransmission err msg = (SentRawTransmission, Request err msg) +type PCTransmission err msg = (Either TransportError SentRawTransmission, Request err msg) -- | Send multiple commands with batching and collect responses sendProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> IO (NonEmpty (Response err msg)) -sendProtocolCommands c@ProtocolClient {batch, blockSize} cs = do +sendProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs = do bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs validate . concat =<< mapM (sendBatch c) bs where @@ -647,16 +656,16 @@ sendProtocolCommands c@ProtocolClient {batch, blockSize} cs = do diff = L.length cs - length rs streamProtocolCommands :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> NonEmpty (ClientCommand msg) -> ([Response err msg] -> IO ()) -> IO () -streamProtocolCommands c@ProtocolClient {batch, blockSize} cs cb = do +streamProtocolCommands c@ProtocolClient {thParams = THandleParams {batch, blockSize}} cs cb = do bs <- batchTransmissions' batch blockSize <$> mapM (mkTransmission c) cs mapM_ (cb <=< sendBatch c) bs sendBatch :: ProtocolClient err msg -> TransportBatch (Request err msg) -> IO [Response err msg] sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do case b of - TBLargeTransmission Request {entityId} -> do + TBError e Request {entityId} -> do putStrLn "send error: large message" - pure [Response entityId $ Left $ PCETransportError TELargeMsg] + pure [Response entityId $ Left $ PCETransportError e] TBTransmissions s n rs | n > 0 -> do atomically $ writeTBQueue sndQ s @@ -667,19 +676,21 @@ sendBatch c@ProtocolClient {client_ = PClient {sndQ}} b = do (: []) <$> getResponse c r -- | Send Protocol command -sendProtocolCommand :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> Maybe C.APrivateSignKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg -sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, batch, blockSize} pKey entId cmd = +sendProtocolCommand :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> Maybe C.APrivateAuthKey -> EntityId -> ProtoCommand msg -> ExceptT (ProtocolClientError err) IO msg +sendProtocolCommand c@ProtocolClient {client_ = PClient {sndQ}, thParams = THandleParams {batch, blockSize}} pKey entId cmd = ExceptT $ uncurry sendRecv =<< mkTransmission c (pKey, entId, cmd) where -- two separate "atomically" needed to avoid blocking - sendRecv :: SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg) - sendRecv t r - | B.length s > blockSize - 2 = pure $ Left $ PCETransportError TELargeMsg - | otherwise = atomically (writeTBQueue sndQ s) >> response <$> getResponse c r - where - s - | batch = tEncodeBatch1 t - | otherwise = tEncode t + sendRecv :: Either TransportError SentRawTransmission -> Request err msg -> IO (Either (ProtocolClientError err) msg) + sendRecv t_ r = case t_ of + Left e -> pure . Left $ PCETransportError e + Right t + | B.length s > blockSize - 2 -> pure . Left $ PCETransportError TELargeMsg + | otherwise -> atomically (writeTBQueue sndQ s) >> response <$> getResponse c r + where + s + | batch = tEncodeBatch1 t + | otherwise = tEncode t -- TODO switch to timeout or TimeManager that supports Int64 getResponse :: ProtocolClient err msg -> Request err msg -> IO (Response err msg) @@ -691,24 +702,34 @@ getResponse ProtocolClient {client_ = PClient {tcpTimeout, pingErrorCount}} Requ pure Response {entityId, response} mkTransmission :: forall err msg. ProtocolEncoding err (ProtoCommand msg) => ProtocolClient err msg -> ClientCommand msg -> IO (PCTransmission err msg) -mkTransmission ProtocolClient {sessionId, thVersion, client_ = PClient {clientCorrId, sentCommands}} (pKey, entId, cmd) = do +mkTransmission ProtocolClient {thParams, client_ = PClient {clientCorrId, sentCommands}} (pKey_, entId, cmd) = do corrId <- atomically getNextCorrId - let t = signTransmission $ encodeTransmission thVersion sessionId (corrId, entId, cmd) + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, entId, cmd) + auth = authTransmission (thAuth thParams) pKey_ corrId tForAuth r <- atomically $ mkRequest corrId - pure (t, r) + pure ((,tToSend) <$> auth, r) where getNextCorrId :: STM CorrId - getNextCorrId = do - i <- stateTVar clientCorrId $ \i -> (i, i + 1) - pure . CorrId $ bshow i - signTransmission :: ByteString -> SentRawTransmission - signTransmission t = ((`C.sign` t) <$> pKey, t) + getNextCorrId = CorrId <$> C.randomBytes 24 clientCorrId -- also used as nonce mkRequest :: CorrId -> STM (Request err msg) mkRequest corrId = do r <- Request entId <$> newEmptyTMVar TM.insert corrId r sentCommands pure r +authTransmission :: Maybe THandleAuth -> Maybe C.APrivateAuthKey -> CorrId -> ByteString -> Either TransportError (Maybe TransmissionAuth) +authTransmission thAuth pKey_ (CorrId corrId) t = traverse authenticate pKey_ + where + authenticate :: C.APrivateAuthKey -> Either TransportError TransmissionAuth + authenticate (C.APrivateAuthKey a pk) = case a of + C.SX25519 -> case thAuth of + Just THandleAuth {peerPubKey} -> Right $ TAAuthenticator $ C.cbAuthenticate peerPubKey pk (C.cbNonce corrId) t + Nothing -> Left TENoServerAuth + C.SEd25519 -> sign pk + C.SEd448 -> sign pk + sign :: forall a. (C.AlgorithmI a, C.SignatureAlgorithm a) => C.PrivateKey a -> Either TransportError TransmissionAuth + sign pk = Right $ TASignature $ C.ASignature (C.sAlgorithm @a) (C.sign' pk t) + $(J.deriveJSON (enumJSON $ dropPrefix "HM") ''HostMode) $(J.deriveJSON (enumJSON $ dropPrefix "TSM") ''TransportSessionMode) diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 4d0d81bbc..068a52782 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -18,6 +18,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Trans.Except +import Crypto.Random (ChaChaDRG) import Data.Bifunctor (bimap, first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -36,7 +37,7 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (BrokerMsg, NotifierId, NtfPrivateSignKey, ProtocolServer (..), QueueId, RcvPrivateSignKey, RecipientId, SMPServer) +import Simplex.Messaging.Protocol (BrokerMsg, NotifierId, NtfPrivateAuthKey, ProtocolServer (..), QueueId, RcvPrivateAuthKey, RecipientId, SMPServer) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport @@ -74,7 +75,7 @@ data SMPClientAgentConfig = SMPClientAgentConfig defaultSMPClientAgentConfig :: SMPClientAgentConfig defaultSMPClientAgentConfig = SMPClientAgentConfig - { smpCfg = defaultClientConfig {defaultTransport = ("5223", transport @TLS)}, + { smpCfg = defaultSMPClientConfig {defaultTransport = ("5223", transport @TLS)}, reconnectInterval = RetryInterval { initialInterval = second, @@ -92,9 +93,10 @@ data SMPClientAgent = SMPClientAgent { agentCfg :: SMPClientAgentConfig, msgQ :: TBQueue (ServerTransmission BrokerMsg), agentQ :: TBQueue SMPClientAgentEvent, + randomDrg :: TVar ChaChaDRG, smpClients :: TMap SMPServer SMPClientVar, - srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey), - pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateSignKey), + srvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey), + pendingSrvSubs :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey), reconnections :: TVar [Async ()], asyncClients :: TVar [Async ()] } @@ -111,8 +113,8 @@ instance (MonadUnliftIO m, Exception e) => MonadUnliftIO (ExceptT e m) where withRunInIO $ \run -> exceptToIO $ run . (either (E.throwIO . InternalException) return <=< runExceptT) -newSMPClientAgent :: SMPClientAgentConfig -> STM SMPClientAgent -newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do +newSMPClientAgent :: SMPClientAgentConfig -> TVar ChaChaDRG -> STM SMPClientAgent +newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} randomDrg = do msgQ <- newTBQueue msgQSize agentQ <- newTBQueue agentQSize smpClients <- TM.empty @@ -120,10 +122,10 @@ newSMPClientAgent agentCfg@SMPClientAgentConfig {msgQSize, agentQSize} = do pendingSrvSubs <- TM.empty reconnections <- newTVar [] asyncClients <- newTVar [] - pure SMPClientAgent {agentCfg, msgQ, agentQ, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients} + pure SMPClientAgent {agentCfg, msgQ, agentQ, randomDrg, smpClients, srvSubs, pendingSrvSubs, reconnections, asyncClients} getSMPServerClient' :: SMPClientAgent -> SMPServer -> ExceptT SMPClientError IO SMPClient -getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = +getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ, randomDrg} srv = atomically getClientVar >>= either newSMPClient waitForSMPClient where getClientVar :: STM (Either SMPClientVar SMPClientVar) @@ -171,14 +173,14 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = void $ tryConnectClient (const reconnectClient) loop connectClient :: ExceptT SMPClientError IO SMPClient - connectClient = ExceptT $ getProtocolClient (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected + connectClient = ExceptT $ getProtocolClient randomDrg (1, srv, Nothing) (smpCfg agentCfg) (Just msgQ) clientDisconnected clientDisconnected :: SMPClient -> IO () clientDisconnected _ = do removeClientAndSubs >>= (`forM_` serverDown) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv - removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateSignKey)) + removeClientAndSubs :: IO (Maybe (Map SMPSub C.APrivateAuthKey)) removeClientAndSubs = atomically $ do TM.delete srv smpClients TM.lookupDelete srv (srvSubs ca) >>= mapM updateSubs @@ -194,7 +196,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = Just v -> TM.union ss v _ -> TM.insert srv sVar ps - serverDown :: Map SMPSub C.APrivateSignKey -> IO () + serverDown :: Map SMPSub C.APrivateAuthKey -> IO () serverDown ss = unless (M.null ss) $ do notify . CADisconnected srv $ M.keysSet ss void $ runExceptT reconnectServer @@ -224,15 +226,15 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = SPNotifier -> True SPRecipient -> False - subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateSignKey)] -> ExceptT SMPClientError IO () + subscribe_ :: SMPClient -> SMPSubParty -> [(SMPSub, C.APrivateAuthKey)] -> ExceptT SMPClientError IO () subscribe_ smp party = mapM_ subscribeBatch . toChunks (agentSubsBatchSize agentCfg) where subscribeBatch subs' = do - let subs'' :: (NonEmpty (QueueId, C.APrivateSignKey)) = L.map (first snd) subs' + let subs'' :: (NonEmpty (QueueId, C.APrivateAuthKey)) = L.map (first snd) subs' rs <- liftIO $ smpSubscribeQueues party ca smp srv subs'' - let rs' :: (NonEmpty ((SMPSub, C.APrivateSignKey), Either SMPClientError ())) = + let rs' :: (NonEmpty ((SMPSub, C.APrivateAuthKey), Either SMPClientError ())) = L.zipWith (first . const) subs' rs - rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateSignKey)] = + rs'' :: [Either (SMPSub, SMPClientError) (SMPSub, C.APrivateAuthKey)] = map (\(sub, r) -> bimap (fst sub,) (const sub) r) $ L.toList rs' (errs, oks) = partitionEithers rs'' (tempErrs, finalErrs) = partition (temporaryClientError . snd) errs @@ -270,7 +272,7 @@ withSMP ca srv action = (getSMPServerClient' ca srv >>= action) `catchE` logSMPE liftIO $ putStrLn $ "SMP error (" <> show srv <> "): " <> show e throwE e -subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO () +subscribeQueue :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO () subscribeQueue ca srv sub = do atomically $ addPendingSubscription ca srv sub withSMP ca srv $ \smp -> subscribe_ smp `catchE` handleErr @@ -284,20 +286,20 @@ subscribeQueue ca srv sub = do removePendingSubscription ca srv (fst sub) throwE e -subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateSignKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ())) +subscribeQueuesSMP :: SMPClientAgent -> SMPServer -> NonEmpty (RecipientId, RcvPrivateAuthKey) -> IO (NonEmpty (RecipientId, Either SMPClientError ())) subscribeQueuesSMP = subscribeQueues_ SPRecipient -subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateSignKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ())) +subscribeQueuesNtfs :: SMPClientAgent -> SMPServer -> NonEmpty (NotifierId, NtfPrivateAuthKey) -> IO (NonEmpty (NotifierId, Either SMPClientError ())) subscribeQueuesNtfs = subscribeQueues_ SPNotifier -subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) +subscribeQueues_ :: SMPSubParty -> SMPClientAgent -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) subscribeQueues_ party ca srv subs = do atomically $ forM_ subs $ addPendingSubscription ca srv . first (party,) runExceptT (getSMPServerClient' ca srv) >>= \case Left e -> pure $ L.map ((,Left e) . fst) subs Right smp -> smpSubscribeQueues party ca smp srv subs -smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateSignKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) +smpSubscribeQueues :: SMPSubParty -> SMPClientAgent -> SMPClient -> SMPServer -> NonEmpty (QueueId, C.APrivateAuthKey) -> IO (NonEmpty (QueueId, Either SMPClientError ())) smpSubscribeQueues party ca smp srv subs = do rs <- L.zip subs <$> subscribe smp (L.map swap subs) atomically $ forM rs $ \(sub, r) -> @@ -318,22 +320,22 @@ showServer :: SMPServer -> ByteString showServer ProtocolServer {host, port} = strEncode host <> B.pack (if null port then "" else ':' : port) -smpSubscribe :: SMPClient -> (SMPSub, C.APrivateSignKey) -> ExceptT SMPClientError IO () +smpSubscribe :: SMPClient -> (SMPSub, C.APrivateAuthKey) -> ExceptT SMPClientError IO () smpSubscribe smp ((party, queueId), privKey) = subscribe_ smp privKey queueId where subscribe_ = case party of SPRecipient -> subscribeSMPQueue SPNotifier -> subscribeSMPQueueNotifications -addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM () +addSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () addSubscription ca srv sub = do addSub_ (srvSubs ca) srv sub removePendingSubscription ca srv $ fst sub -addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM () +addPendingSubscription :: SMPClientAgent -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () addPendingSubscription = addSub_ . pendingSrvSubs -addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> (SMPSub, C.APrivateSignKey) -> STM () +addSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> (SMPSub, C.APrivateAuthKey) -> STM () addSub_ subs srv (s, key) = TM.lookup srv subs >>= \case Just m -> TM.insert s key m @@ -345,11 +347,11 @@ removeSubscription = removeSub_ . srvSubs removePendingSubscription :: SMPClientAgent -> SMPServer -> SMPSub -> STM () removePendingSubscription = removeSub_ . pendingSrvSubs -removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM () +removeSub_ :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM () removeSub_ subs srv s = TM.lookup srv subs >>= mapM_ (TM.delete s) -getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateSignKey) +getSubKey :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM (Maybe C.APrivateAuthKey) getSubKey subs srv s = TM.lookup srv subs $>>= TM.lookup s -hasSub :: TMap SMPServer (TMap SMPSub C.APrivateSignKey) -> SMPServer -> SMPSub -> STM Bool +hasSub :: TMap SMPServer (TMap SMPSub C.APrivateAuthKey) -> SMPServer -> SMPSub -> STM Bool hasSub subs srv s = maybe (pure False) (TM.member s) =<< TM.lookup srv subs diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 3564454ff..9a775faa3 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -8,6 +8,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -36,7 +37,7 @@ module Simplex.Messaging.Crypto Algorithm (..), SAlgorithm (..), Alg (..), - SignAlg (..), + AuthAlg (..), DhAlg (..), DhAlgorithm, PrivateKey (..), @@ -53,23 +54,32 @@ module Simplex.Messaging.Crypto APublicVerifyKey (..), APrivateDhKey (..), APublicDhKey (..), + APrivateAuthKey (..), + APublicAuthKey (..), CryptoPublicKey (..), CryptoPrivateKey (..), + AAuthKeyPair, KeyPair, + KeyPairX25519, ASignatureKeyPair, DhSecret (..), DhSecretX25519, ADhSecret (..), KeyHash (..), newRandom, + newRandomDRG, generateAKeyPair, generateKeyPair, generateSignatureKeyPair, + generateAuthKeyPair, generateDhKeyPair, privateToX509, + x509ToPublic, + x509ToPrivate, publicKey, signatureKeyPair, publicToX509, + encodeASNObj, -- * key encoding/decoding encodePubKey, @@ -84,6 +94,7 @@ module Simplex.Messaging.Crypto CryptoSignature (..), SignatureSize (..), SignatureAlgorithm, + AuthAlgorithm, AlgorithmI (..), sign, sign', @@ -91,6 +102,12 @@ module Simplex.Messaging.Crypto verify', validSignatureSize, + -- * crypto_box authenticator, as discussed in https://groups.google.com/g/sci.crypt/c/73yb5a9pz2Y/m/LNgRO7IYXOwJ + CbAuthenticator (..), + cbAuthenticatorSize, + cbAuthenticate, + cbVerify, + -- * DH derivation dh', dhBytes', @@ -115,8 +132,10 @@ module Simplex.Messaging.Crypto CbNonce (unCbNonce), pattern CbNonce, cbEncrypt, + cbEncryptNoPad, cbEncryptMaxLenBS, cbDecrypt, + cbDecryptNoPad, sbDecrypt_, sbEncrypt_, cbNonce, @@ -147,10 +166,13 @@ module Simplex.Messaging.Crypto Certificate, signCertificate, signX509, + verifyX509, certificateFingerprint, signedFingerprint, SignatureAlgorithmX509 (..), SignedObject (..), + encodeCertChain, + certChainP, -- * Cryptography error type CryptoError (..), @@ -173,7 +195,7 @@ 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 (..), SHA512, hash) +import Crypto.Hash (Digest, SHA256 (..), SHA512 (..), hash, hashDigestSize) import qualified Crypto.MAC.Poly1305 as Poly1305 import qualified Crypto.PubKey.Curve25519 as X25519 import qualified Crypto.PubKey.Curve448 as X448 @@ -195,6 +217,7 @@ import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy (fromStrict, toStrict) import Data.Constraint (Dict (..)) import Data.Kind (Constraint, Type) +import qualified Data.List.NonEmpty as L import Data.String import Data.Type.Equality import Data.Typeable (Proxy (Proxy), Typeable) @@ -226,10 +249,10 @@ deriving instance Show (SAlgorithm a) data Alg = forall a. AlgorithmI a => Alg (SAlgorithm a) -data SignAlg +data AuthAlg = forall a. - (AlgorithmI a, SignatureAlgorithm a) => - SignAlg (SAlgorithm a) + (AlgorithmI a, AuthAlgorithm a) => + AuthAlg (SAlgorithm a) data DhAlg = forall a. @@ -279,6 +302,12 @@ instance Eq APublicKey where Just Refl -> k == k' Nothing -> False +instance Encoding APublicKey where + smpEncode = smpEncode . encodePubKey + {-# INLINE smpEncode #-} + smpDecode = decodePubKey + {-# INLINE smpDecode #-} + deriving instance Show APublicKey type PublicKeyEd25519 = PublicKey Ed25519 @@ -425,6 +454,57 @@ dhAlgorithm = \case SX448 -> Just Dict _ -> Nothing +data APrivateAuthKey + = forall a. + (AlgorithmI a, AuthAlgorithm a) => + APrivateAuthKey (SAlgorithm a) (PrivateKey a) + +instance Eq APrivateAuthKey where + APrivateAuthKey a k == APrivateAuthKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APrivateAuthKey + +instance Encoding APrivateAuthKey where + smpEncode = smpEncode . encodePrivKey + {-# INLINE smpEncode #-} + smpDecode = decodePrivKey + {-# INLINE smpDecode #-} + +instance StrEncoding APrivateAuthKey where + strEncode = strEncode . encodePrivKey + {-# INLINE strEncode #-} + strDecode = decodePrivKey + {-# INLINE strDecode #-} + +data APublicAuthKey + = forall a. + (AlgorithmI a, AuthAlgorithm a) => + APublicAuthKey (SAlgorithm a) (PublicKey a) + +instance Eq APublicAuthKey where + APublicAuthKey a k == APublicAuthKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APublicAuthKey + +-- either X25519 or Ed algorithm that can be used to authorize commands to SMP server +type family AuthAlgorithm (a :: Algorithm) :: Constraint where + AuthAlgorithm Ed25519 = () + AuthAlgorithm Ed448 = () + AuthAlgorithm X25519 = () + AuthAlgorithm a = + (Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used for authorization")) + +authAlgorithm :: SAlgorithm a -> Maybe (Dict (AuthAlgorithm a)) +authAlgorithm = \case + SEd25519 -> Just Dict + SEd448 -> Just Dict + SX25519 -> Just Dict + _ -> Nothing + dhBytes' :: DhSecret a -> ByteString dhBytes' = \case DhSecretX25519 s -> BA.convert s @@ -464,6 +544,12 @@ instance CryptoPublicKey APublicVerifyKey where Just Dict -> Right $ APublicVerifyKey a k _ -> Left "key does not support signature algorithms" +instance CryptoPublicKey APublicAuthKey where + toPubKey f (APublicAuthKey _ k) = f k + pubKey (APublicKey a k) = case authAlgorithm a of + Just Dict -> Right $ APublicAuthKey a k + _ -> Left "key does not support auth algorithms" + instance CryptoPublicKey APublicDhKey where toPubKey f (APublicDhKey _ k) = f k pubKey (APublicKey a k) = case dhAlgorithm a of @@ -480,6 +566,12 @@ instance Encoding APublicVerifyKey where smpDecode = decodePubKey {-# INLINE smpDecode #-} +instance Encoding APublicAuthKey where + smpEncode = smpEncode . encodePubKey + {-# INLINE smpEncode #-} + smpDecode = decodePubKey + {-# INLINE smpDecode #-} + instance Encoding APublicDhKey where smpEncode = smpEncode . encodePubKey {-# INLINE smpEncode #-} @@ -498,6 +590,12 @@ instance StrEncoding APublicVerifyKey where strDecode = decodePubKey {-# INLINE strDecode #-} +instance StrEncoding APublicAuthKey where + strEncode = strEncode . encodePubKey + {-# INLINE strEncode #-} + strDecode = decodePubKey + {-# INLINE strDecode #-} + instance StrEncoding APublicDhKey where strEncode = strEncode . encodePubKey {-# INLINE strEncode #-} @@ -545,6 +643,13 @@ instance CryptoPrivateKey APrivateSignKey where Just Dict -> Right $ APrivateSignKey a k _ -> Left "key does not support signature algorithms" +instance CryptoPrivateKey APrivateAuthKey where + type PublicKeyType APrivateAuthKey = APublicAuthKey + toPrivKey f (APrivateAuthKey _ k) = f k + privKey (APrivateKey a k) = case authAlgorithm a of + Just Dict -> Right $ APrivateAuthKey a k + _ -> Left "key does not support auth algorithms" + instance CryptoPrivateKey APrivateDhKey where type PublicKeyType APrivateDhKey = APublicDhKey toPrivKey f (APrivateDhKey _ k) = f k @@ -588,21 +693,32 @@ type KeyPairType pk = (PublicKeyType pk, pk) type KeyPair a = KeyPairType (PrivateKey a) +type KeyPairX25519 = KeyPair X25519 + +-- TODO narrow key pair types to have the same algorithm in both keys type AKeyPair = KeyPairType APrivateKey type ASignatureKeyPair = KeyPairType APrivateSignKey type ADhKeyPair = KeyPairType APrivateDhKey +type AAuthKeyPair = KeyPairType APrivateAuthKey + newRandom :: IO (TVar ChaChaDRG) newRandom = newTVarIO =<< drgNew +newRandomDRG :: TVar ChaChaDRG -> STM (TVar ChaChaDRG) +newRandomDRG g = newTVar =<< stateTVar g (`withDRG` drgNew) + generateAKeyPair :: AlgorithmI a => SAlgorithm a -> TVar ChaChaDRG -> STM AKeyPair generateAKeyPair a g = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair g generateSignatureKeyPair :: (AlgorithmI a, SignatureAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ASignatureKeyPair generateSignatureKeyPair a g = bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair g +generateAuthKeyPair :: (AlgorithmI a, AuthAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM AAuthKeyPair +generateAuthKeyPair a g = bimap (APublicAuthKey a) (APrivateAuthKey a) <$> generateKeyPair g + generateDhKeyPair :: (AlgorithmI a, DhAlgorithm a) => SAlgorithm a -> TVar ChaChaDRG -> STM ADhKeyPair generateDhKeyPair a g = bimap (APublicDhKey a) (APrivateDhKey a) <$> generateKeyPair g @@ -632,6 +748,10 @@ instance ToField APrivateSignKey where toField = toField . encodePrivKey instance ToField APublicVerifyKey where toField = toField . encodePubKey +instance ToField APrivateAuthKey where toField = toField . encodePrivKey + +instance ToField APublicAuthKey where toField = toField . encodePubKey + instance ToField APrivateDhKey where toField = toField . encodePrivKey instance ToField APublicDhKey where toField = toField . encodePubKey @@ -646,6 +766,10 @@ instance FromField APrivateSignKey where fromField = blobFieldDecoder decodePriv instance FromField APublicVerifyKey where fromField = blobFieldDecoder decodePubKey +instance FromField APrivateAuthKey where fromField = blobFieldDecoder decodePrivKey + +instance FromField APublicAuthKey where fromField = blobFieldDecoder decodePubKey + instance FromField APrivateDhKey where fromField = blobFieldDecoder decodePrivKey instance FromField APublicDhKey where fromField = blobFieldDecoder decodePubKey @@ -656,7 +780,7 @@ instance (Typeable a, AlgorithmI a) => FromField (PublicKey a) where fromField = instance (Typeable a, AlgorithmI a) => FromField (DhSecret a) where fromField = blobFieldDecoder strDecode -instance IsString (Maybe ASignature) where +instance IsString ASignature where fromString = parseString $ decode >=> decodeSignature data Signature (a :: Algorithm) where @@ -1021,6 +1145,18 @@ signX509 key = fst . objectToSignedExact f signatureAlgorithmX509 key, () ) +{-# INLINE signX509 #-} + +verifyX509 :: (ASN1Object o, Eq o, Show o) => APublicVerifyKey -> SignedExact o -> Either String o +verifyX509 key exact = do + signature <- case signedAlg of + SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> ASignature SEd25519 <$> decodeSignature signedSignature + SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> ASignature SEd448 <$> decodeSignature signedSignature + _ -> Left "unknown x509 signature algorithm" + if verify key signature $ getSignedData exact then Right signedObject else Left "bad signature" + where + Signed {signedObject, signedAlg, signedSignature} = getSigned exact +{-# INLINE verifyX509 #-} certificateFingerprint :: SignedCertificate -> KeyHash certificateFingerprint = signedFingerprint @@ -1049,7 +1185,7 @@ instance SignatureAlgorithmX509 pk => SignatureAlgorithmX509 (a, pk) where signatureAlgorithmX509 = signatureAlgorithmX509 . snd -- | A wrapper to marshall signed ASN1 objects, like certificates. -newtype SignedObject a = SignedObject (SignedExact a) +newtype SignedObject a = SignedObject {getSignedExact :: SignedExact a} instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) where fromField = fmap SignedObject . blobFieldDecoder decodeSignedObject @@ -1057,6 +1193,20 @@ instance (Typeable a, Eq a, Show a, ASN1Object a) => FromField (SignedObject a) instance (Eq a, Show a, ASN1Object a) => ToField (SignedObject a) where toField (SignedObject s) = toField $ encodeSignedObject s +instance (Eq a, Show a, ASN1Object a) => Encoding (SignedObject a) where + smpEncode (SignedObject exact) = smpEncode . Large $ encodeSignedObject exact + smpP = fmap SignedObject . decodeSignedObject . unLarge <$?> smpP + +encodeCertChain :: CertificateChain -> L.NonEmpty Large +encodeCertChain cc = L.fromList $ map Large blobs + where + CertificateChainRaw blobs = encodeCertificateChain cc + +certChainP :: A.Parser CertificateChain +certChainP = do + rawChain <- CertificateChainRaw . map unLarge . L.toList <$> smpP + either (fail . show) pure $ decodeCertificateChain rawChain + -- | Signature verification. -- -- Used by SMP servers to authorize SMP commands and by SMP agents to verify messages. @@ -1073,10 +1223,14 @@ 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. +-- | NaCl @crypto_box@ encrypt with padding with a shared DH secret and 192-bit nonce. cbEncrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString cbEncrypt (DhSecretX25519 secret) = sbEncrypt_ secret +-- | NaCl @crypto_box@ encrypt with a shared DH secret and 192-bit nonce (without padding). +cbEncryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> ByteString +cbEncryptNoPad (DhSecretX25519 secret) (CbNonce nonce) = cryptoBox secret nonce + -- | NaCl @secret_box@ encrypt with a symmetric 256-bit key and 192-bit nonce. sbEncrypt :: SbKey -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString sbEncrypt (SbKey key) = sbEncrypt_ key @@ -1098,21 +1252,43 @@ cryptoBox secret nonce s = BA.convert tag <> c cbDecrypt :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret +-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding). +cbDecryptNoPad :: DhSecret X25519 -> CbNonce -> ByteString -> Either CryptoError ByteString +cbDecryptNoPad (DhSecretX25519 secret) = sbDecryptNoPad_ secret + -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce. sbDecrypt :: SbKey -> CbNonce -> ByteString -> Either CryptoError ByteString sbDecrypt (SbKey key) = sbDecrypt_ key -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce. sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString -sbDecrypt_ secret (CbNonce nonce) packet +sbDecrypt_ secret nonce = unPad <=< sbDecryptNoPad_ secret nonce + +-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding). +sbDecryptNoPad_ :: ByteArrayAccess key => key -> CbNonce -> ByteString -> Either CryptoError ByteString +sbDecryptNoPad_ secret (CbNonce nonce) packet | B.length packet < 16 = Left CBDecryptError - | BA.constEq tag' tag = unPad msg + | 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 +-- type for authentication scheme using NaCl @crypto_box@ over the sha512 digest of the message. +newtype CbAuthenticator = CbAuthenticator ByteString deriving (Eq, Show) + +cbAuthenticatorSize :: Int +cbAuthenticatorSize = hashDigestSize SHA512 + authTagSize -- 64 + 16 = 80 bytes + +-- create crypto_box authenticator for a message. +cbAuthenticate :: PublicKeyX25519 -> PrivateKeyX25519 -> CbNonce -> ByteString -> CbAuthenticator +cbAuthenticate k pk nonce msg = CbAuthenticator $ cbEncryptNoPad (dh' k pk) nonce (sha512Hash msg) + +-- verify crypto_box authenticator for a message. +cbVerify :: PublicKeyX25519 -> PrivateKeyX25519 -> CbNonce -> CbAuthenticator -> ByteString -> Bool +cbVerify k pk nonce (CbAuthenticator s) authorized = cbDecryptNoPad (dh' k pk) nonce s == Right (sha512Hash authorized) + newtype CbNonce = CryptoBoxNonce {unCbNonce :: ByteString} deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs index 6fa2c72c9..9f4c47583 100644 --- a/src/Simplex/Messaging/Encoding.hs +++ b/src/Simplex/Messaging/Encoding.hs @@ -110,7 +110,7 @@ lenP = fromIntegral . c2w <$> A.anyChar {-# INLINE lenP #-} instance Encoding a => Encoding (Maybe a) where - smpEncode = maybe "0" (("1" <>) . smpEncode) + smpEncode = maybe "0" (('1' `B.cons`) . smpEncode) {-# INLINE smpEncode #-} smpP = smpP >>= \case diff --git a/src/Simplex/Messaging/Notifications/Client.hs b/src/Simplex/Messaging/Notifications/Client.hs index dfd84c909..d69114b68 100644 --- a/src/Simplex/Messaging/Notifications/Client.hs +++ b/src/Simplex/Messaging/Notifications/Client.hs @@ -10,6 +10,7 @@ import Data.Word (Word16) import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol +import Simplex.Messaging.Notifications.Transport (supportedClientNTFVRange) import Simplex.Messaging.Protocol (ErrorType) import Simplex.Messaging.Util (bshow) @@ -17,50 +18,53 @@ type NtfClient = ProtocolClient ErrorType NtfResponse type NtfClientError = ProtocolClientError ErrorType -ntfRegisterToken :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519) +defaultNTFClientConfig :: ProtocolClientConfig +defaultNTFClientConfig = defaultClientConfig supportedClientNTFVRange + +ntfRegisterToken :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Token -> ExceptT NtfClientError IO (NtfTokenId, C.PublicKeyX25519) ntfRegisterToken c pKey newTkn = sendNtfCommand c (Just pKey) "" (TNEW newTkn) >>= \case NRTknId tknId dhKey -> pure (tknId, dhKey) r -> throwE . PCEUnexpectedResponse $ bshow r -ntfVerifyToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO () +ntfVerifyToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> NtfRegCode -> ExceptT NtfClientError IO () ntfVerifyToken c pKey tknId code = okNtfCommand (TVFY code) c pKey tknId -ntfCheckToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus +ntfCheckToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO NtfTknStatus ntfCheckToken c pKey tknId = sendNtfCommand c (Just pKey) tknId TCHK >>= \case NRTkn stat -> pure stat r -> throwE . PCEUnexpectedResponse $ bshow r -ntfReplaceToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO () +ntfReplaceToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> DeviceToken -> ExceptT NtfClientError IO () ntfReplaceToken c pKey tknId token = okNtfCommand (TRPL token) c pKey tknId -ntfDeleteToken :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> ExceptT NtfClientError IO () +ntfDeleteToken :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> ExceptT NtfClientError IO () ntfDeleteToken = okNtfCommand TDEL -ntfEnableCron :: NtfClient -> C.APrivateSignKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO () +ntfEnableCron :: NtfClient -> C.APrivateAuthKey -> NtfTokenId -> Word16 -> ExceptT NtfClientError IO () ntfEnableCron c pKey tknId int = okNtfCommand (TCRN int) c pKey tknId -ntfCreateSubscription :: NtfClient -> C.APrivateSignKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId +ntfCreateSubscription :: NtfClient -> C.APrivateAuthKey -> NewNtfEntity 'Subscription -> ExceptT NtfClientError IO NtfSubscriptionId ntfCreateSubscription c pKey newSub = sendNtfCommand c (Just pKey) "" (SNEW newSub) >>= \case NRSubId subId -> pure subId r -> throwE . PCEUnexpectedResponse $ bshow r -ntfCheckSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus +ntfCheckSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO NtfSubStatus ntfCheckSubscription c pKey subId = sendNtfCommand c (Just pKey) subId SCHK >>= \case NRSub stat -> pure stat r -> throwE . PCEUnexpectedResponse $ bshow r -ntfDeleteSubscription :: NtfClient -> C.APrivateSignKey -> NtfSubscriptionId -> ExceptT NtfClientError IO () +ntfDeleteSubscription :: NtfClient -> C.APrivateAuthKey -> NtfSubscriptionId -> ExceptT NtfClientError IO () ntfDeleteSubscription = okNtfCommand SDEL -- | Send notification server command -sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateSignKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse +sendNtfCommand :: NtfEntityI e => NtfClient -> Maybe C.APrivateAuthKey -> NtfEntityId -> NtfCommand e -> ExceptT NtfClientError IO NtfResponse sendNtfCommand c pKey entId cmd = sendProtocolCommand c pKey entId (NtfCmd sNtfEntity cmd) -okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateSignKey -> NtfEntityId -> ExceptT NtfClientError IO () +okNtfCommand :: NtfEntityI e => NtfCommand e -> NtfClient -> C.APrivateAuthKey -> NtfEntityId -> ExceptT NtfClientError IO () okNtfCommand cmd c pKey entId = sendNtfCommand c (Just pKey) entId cmd >>= \case NROk -> return () diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 77b9c10bf..854d7c94b 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -124,8 +124,8 @@ instance ToJSON NtfRegCode where toEncoding = strToJEncoding data NewNtfEntity (e :: NtfEntity) where - NewNtfTkn :: DeviceToken -> C.APublicVerifyKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token - NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateSignKey -> NewNtfEntity 'Subscription + NewNtfTkn :: DeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token + NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription deriving instance Show (NewNtfEntity e) @@ -206,20 +206,20 @@ instance NtfEntityI e => ProtocolEncoding ErrorType (NtfCommand e) where fromProtocolError = fromProtocolError @ErrorType @NtfResponse {-# INLINE fromProtocolError #-} - checkCredentials (sig, _, entityId, _) cmd = case cmd of + checkCredentials (auth, _, entityId, _) cmd = case cmd of -- TNEW and SNEW must have signature but NOT token/subscription IDs TNEW {} -> sigNoEntity SNEW {} -> sigNoEntity PING - | isNothing sig && B.null entityId -> Right cmd + | isNothing auth && B.null entityId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and entity ID _ - | isNothing sig || B.null entityId -> Left $ CMD NO_AUTH + | isNothing auth || B.null entityId -> Left $ CMD NO_AUTH | otherwise -> Right cmd where sigNoEntity - | isNothing sig = Left $ CMD NO_AUTH + | isNothing auth = Left $ CMD NO_AUTH | not (B.null entityId) = Left $ CMD HAS_AUTH | otherwise = Right cmd diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index 1de707e58..754aa6d62 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -48,8 +48,8 @@ import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server import Simplex.Messaging.Server.Stats import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (ATransport (..), THandle (..), TProxy, Transport (..)) -import Simplex.Messaging.Transport.Server (runTransportServer) +import Simplex.Messaging.Transport (ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..)) +import Simplex.Messaging.Transport.Server (runTransportServer, tlsServerCredentials) import Simplex.Messaging.Util import System.Exit (exitFailure) import System.IO (BufferMode (..), hPutStrLn, hSetBuffering) @@ -82,12 +82,16 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg} started = do runServer :: (ServiceName, ATransport) -> M () runServer (tcpPort, ATransport t) = do serverParams <- asks tlsServerParams - runTransportServer started tcpPort serverParams tCfg (runClient t) + serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams + runTransportServer started tcpPort serverParams tCfg (runClient serverSignKey t) + fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey - runClient :: Transport c => TProxy c -> c -> M () - runClient _ h = do + runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M () + runClient signKey _ h = do kh <- asks serverIdentity - liftIO (runExceptT $ ntfServerHandshake h kh supportedNTFServerVRange) >>= \case + ks <- atomically . C.generateKeyPair =<< asks random + NtfServerConfig {ntfServerVRange} <- asks config + liftIO (runExceptT $ ntfServerHandshake signKey h ks kh ntfServerVRange) >>= \case Right th -> runNtfClientTransport th Left _ -> pure () @@ -335,10 +339,10 @@ updateTknStatus NtfTknData {ntfTknId, tknStatus} status = do when (old /= status) $ withNtfLog $ \sl -> logTokenStatus sl ntfTknId status runNtfClientTransport :: Transport c => THandle c -> M () -runNtfClientTransport th@THandle {sessionId} = do +runNtfClientTransport th@THandle {params} = do qSize <- asks $ clientQSize . config ts <- liftIO getSystemTime - c <- atomically $ newNtfServerClient qSize sessionId ts + c <- atomically $ newNtfServerClient qSize params ts s <- asks subscriber ps <- asks pushServer expCfg <- asks $ inactiveClientExpiration . config @@ -352,7 +356,7 @@ clientDisconnected :: NtfServerClient -> IO () clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False receive :: Transport c => THandle c -> NtfServerClient -> M () -receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do +receive th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do ts <- liftIO $ tGet th forM_ ts $ \t@(_, _, (corrId, entId, cmdOrError)) -> do atomically . writeTVar rcvActiveAt =<< liftIO getSystemTime @@ -360,16 +364,16 @@ receive th NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do case cmdOrError of Left e -> write sndQ (corrId, entId, NRErr e) Right cmd -> - verifyNtfTransmission t cmd >>= \case + verifyNtfTransmission ((,C.cbNonce (SMP.bs corrId)) <$> thAuth) t cmd >>= \case VRVerified req -> write rcvQ req VRFailed -> write sndQ (corrId, entId, NRErr AUTH) where write q t = atomically $ writeTBQueue q t send :: Transport c => THandle c -> NtfServerClient -> IO () -send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = forever $ do +send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do t <- atomically $ readTBQueue sndQ - void . liftIO $ tPut h [(Nothing, encodeTransmission v sessionId t)] + void . liftIO $ tPut h [Right (Nothing, encodeTransmission params t)] atomically . writeTVar sndActiveAt =<< liftIO getSystemTime -- instance Show a => Show (TVar a) where @@ -377,14 +381,14 @@ send h@THandle {thVersion = v} NtfServerClient {sndQ, sessionId, sndActiveAt} = data VerificationResult = VRVerified NtfRequest | VRFailed -verifyNtfTransmission :: SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult -verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do +verifyNtfTransmission :: Maybe (THandleAuth, C.CbNonce) -> SignedTransmission ErrorType NtfCmd -> NtfCmd -> M VerificationResult +verifyNtfTransmission auth_ (tAuth, authorized, (corrId, entId, _)) cmd = do st <- asks store case cmd of NtfCmd SToken c@(TNEW tkn@(NewNtfTkn _ k _)) -> do r_ <- atomically $ getNtfTokenRegistration st tkn pure $ - if verifyCmdSignature sig_ signed k + if verifyCmdAuthorization auth_ tAuth authorized k then case r_ of Just t@NtfTknData {tknVerifyKey} | k == tknVerifyKey -> verifiedTknCmd t c @@ -405,7 +409,7 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do then do t_ <- atomically $ getActiveNtfToken st subTknId verifyToken' t_ $ verifiedSubCmd s c - else pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed + else pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed NtfCmd SSubscription PING -> pure $ VRVerified $ NtfReqPing corrId entId NtfCmd SSubscription c -> do s_ <- atomically $ getNtfSubscription st entId @@ -413,7 +417,7 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do Just s@NtfSubData {tokenId = subTknId} -> do t_ <- atomically $ getActiveNtfToken st subTknId verifyToken' t_ $ verifiedSubCmd s c - _ -> pure $ maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed + _ -> pure $ maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed where verifiedTknCmd t c = VRVerified (NtfReqCmd SToken (NtfTkn t) (corrId, entId, c)) verifiedSubCmd s c = VRVerified (NtfReqCmd SSubscription (NtfSub s) (corrId, entId, c)) @@ -421,10 +425,10 @@ verifyNtfTransmission (sig_, signed, (corrId, entId, _)) cmd = do verifyToken t_ positiveVerificationResult = pure $ case t_ of Just t@NtfTknData {tknVerifyKey} -> - if verifyCmdSignature sig_ signed tknVerifyKey + if verifyCmdAuthorization auth_ tAuth authorized tknVerifyKey then positiveVerificationResult t else VRFailed - _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed + _ -> maybe False (dummyVerifyCmd auth_ authorized) tAuth `seq` VRFailed verifyToken' :: Maybe NtfTknData -> VerificationResult -> M VerificationResult verifyToken' t_ = verifyToken t_ . const diff --git a/src/Simplex/Messaging/Notifications/Server/Env.hs b/src/Simplex/Messaging/Notifications/Server/Env.hs index e1b4f51c5..ec2290b40 100644 --- a/src/Simplex/Messaging/Notifications/Server/Env.hs +++ b/src/Simplex/Messaging/Notifications/Server/Env.hs @@ -12,7 +12,6 @@ import Control.Concurrent.Async (Async) import Control.Logger.Simple import Control.Monad.IO.Unlift import Crypto.Random -import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import Data.Time.Clock (getCurrentTime) @@ -33,8 +32,9 @@ import Simplex.Messaging.Protocol (CorrId, SMPServer, Transmission) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Transport (ATransport) +import Simplex.Messaging.Transport (ATransport, THandleParams) import Simplex.Messaging.Transport.Server (TransportServerConfig, loadFingerprint, loadTLSServerParams) +import Simplex.Messaging.Version (VersionRange) import System.IO (IOMode (..)) import System.Mem.Weak (Weak) import UnliftIO.STM @@ -60,6 +60,7 @@ data NtfServerConfig = NtfServerConfig logStatsStartTime :: Int64, serverStatsLogFile :: FilePath, serverStatsBackupFile :: Maybe FilePath, + ntfServerVRange :: VersionRange, transportConfig :: TransportServerConfig } @@ -89,7 +90,7 @@ newNtfServerEnv config@NtfServerConfig {subQSize, pushQSize, smpAgentCfg, apnsCo logInfo "restoring subscriptions..." storeLog <- liftIO $ mapM (`readWriteNtfStore` store) storeLogFile logInfo "restored subscriptions" - subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg + subscriber <- atomically $ newNtfSubscriber subQSize smpAgentCfg random pushServer <- atomically $ newNtfPushServer pushQSize apnsConfig tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile @@ -102,11 +103,11 @@ data NtfSubscriber = NtfSubscriber smpAgent :: SMPClientAgent } -newNtfSubscriber :: Natural -> SMPClientAgentConfig -> STM NtfSubscriber -newNtfSubscriber qSize smpAgentCfg = do +newNtfSubscriber :: Natural -> SMPClientAgentConfig -> TVar ChaChaDRG -> STM NtfSubscriber +newNtfSubscriber qSize smpAgentCfg random = do smpSubscribers <- TM.empty newSubQ <- newTBQueue qSize - smpAgent <- newSMPClientAgent smpAgentCfg + smpAgent <- newSMPClientAgent smpAgentCfg random pure NtfSubscriber {smpSubscribers, newSubQ, smpAgent} data SMPSubscriber = SMPSubscriber @@ -158,17 +159,17 @@ data NtfRequest data NtfServerClient = NtfServerClient { rcvQ :: TBQueue NtfRequest, sndQ :: TBQueue (Transmission NtfResponse), - sessionId :: ByteString, + ntfThParams :: THandleParams, connected :: TVar Bool, rcvActiveAt :: TVar SystemTime, sndActiveAt :: TVar SystemTime } -newNtfServerClient :: Natural -> ByteString -> SystemTime -> STM NtfServerClient -newNtfServerClient qSize sessionId ts = do +newNtfServerClient :: Natural -> THandleParams -> SystemTime -> STM NtfServerClient +newNtfServerClient qSize ntfThParams ts = do rcvQ <- newTBQueue qSize sndQ <- newTBQueue qSize connected <- newTVar True rcvActiveAt <- newTVar ts sndActiveAt <- newTVar ts - return NtfServerClient {rcvQ, sndQ, sessionId, connected, rcvActiveAt, sndActiveAt} + return NtfServerClient {rcvQ, sndQ, ntfThParams, connected, rcvActiveAt, sndActiveAt} diff --git a/src/Simplex/Messaging/Notifications/Server/Main.hs b/src/Simplex/Messaging/Notifications/Server/Main.hs index 0462cf154..bb10d8e3e 100644 --- a/src/Simplex/Messaging/Notifications/Server/Main.hs +++ b/src/Simplex/Messaging/Notifications/Server/Main.hs @@ -19,6 +19,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Server (runNtfServer) import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..), defaultInactiveClientExpiration) import Simplex.Messaging.Notifications.Server.Push.APNS (defaultAPNSPushClientConfig) +import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange) import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern NtfServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Expiration @@ -139,6 +140,7 @@ ntfServerCLI cfgPath logPath = logStatsStartTime = 0, -- seconds from 00:00 UTC serverStatsLogFile = combine logPath "ntf-server-stats.daily.log", serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log", + ntfServerVRange = supportedServerNTFVRange, transportConfig = defaultTransportServerConfig { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini diff --git a/src/Simplex/Messaging/Notifications/Server/Store.hs b/src/Simplex/Messaging/Notifications/Server/Store.hs index b7750ae2c..83dc1a4c2 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store.hs @@ -19,7 +19,7 @@ import qualified Data.Set as S import Data.Word (Word16) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol -import Simplex.Messaging.Protocol (NtfPrivateSignKey, SMPServer) +import Simplex.Messaging.Protocol (NtfPrivateAuthKey, NtfPublicAuthKey, SMPServer) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (whenM, ($>>=)) @@ -46,7 +46,7 @@ data NtfTknData = NtfTknData { ntfTknId :: NtfTokenId, token :: DeviceToken, tknStatus :: TVar NtfTknStatus, - tknVerifyKey :: C.APublicVerifyKey, + tknVerifyKey :: NtfPublicAuthKey, tknDhKeys :: C.KeyPair 'C.X25519, tknDhSecret :: C.DhSecretX25519, tknRegCode :: NtfRegCode, @@ -62,7 +62,7 @@ mkNtfTknData ntfTknId (NewNtfTkn token tknVerifyKey _) tknDhKeys tknDhSecret tkn data NtfSubData = NtfSubData { ntfSubId :: NtfSubscriptionId, smpQueue :: SMPQueueNtf, - notifierKey :: NtfPrivateSignKey, + notifierKey :: NtfPrivateAuthKey, tokenId :: NtfTokenId, subStatus :: TVar NtfSubStatus } diff --git a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs index 3ed28eb52..cc2a1802e 100644 --- a/src/Simplex/Messaging/Notifications/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Notifications/Server/StoreLog.hs @@ -32,7 +32,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Store -import Simplex.Messaging.Protocol (NtfPrivateSignKey) +import Simplex.Messaging.Protocol (NtfPrivateAuthKey) import Simplex.Messaging.Server.StoreLog import Simplex.Messaging.Util (whenM) import System.Directory (doesFileExist, renameFile) @@ -52,7 +52,7 @@ data NtfTknRec = NtfTknRec { ntfTknId :: NtfTokenId, token :: DeviceToken, tknStatus :: NtfTknStatus, - tknVerifyKey :: C.APublicVerifyKey, + tknVerifyKey :: C.APublicAuthKey, tknDhKeys :: C.KeyPair 'C.X25519, tknDhSecret :: C.DhSecretX25519, tknRegCode :: NtfRegCode, @@ -74,7 +74,7 @@ mkTknRec NtfTknData {ntfTknId, token, tknStatus = status, tknVerifyKey, tknDhKey data NtfSubRec = NtfSubRec { ntfSubId :: NtfSubscriptionId, smpQueue :: SMPQueueNtf, - notifierKey :: NtfPrivateSignKey, + notifierKey :: NtfPrivateAuthKey, tokenId :: NtfTokenId, subStatus :: NtfSubStatus } diff --git a/src/Simplex/Messaging/Notifications/Transport.hs b/src/Simplex/Messaging/Notifications/Transport.hs index 54bd354bb..00fd811a2 100644 --- a/src/Simplex/Messaging/Notifications/Transport.hs +++ b/src/Simplex/Messaging/Notifications/Transport.hs @@ -1,72 +1,136 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Simplex.Messaging.Notifications.Transport where +import Control.Monad (forM) import Control.Monad.Except +import Data.Attoparsec.ByteString.Char8 (Parser) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.X509 as X import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Transport import Simplex.Messaging.Version +import Simplex.Messaging.Util (liftEitherWith) ntfBlockSize :: Int ntfBlockSize = 512 -supportedNTFServerVRange :: VersionRange -supportedNTFServerVRange = mkVersionRange 1 1 +authBatchCmdsNTFVersion :: Version +authBatchCmdsNTFVersion = 2 + +currentClientNTFVersion :: Version +currentClientNTFVersion = 1 + +currentServerNTFVersion :: Version +currentServerNTFVersion = 1 + +supportedClientNTFVRange :: VersionRange +supportedClientNTFVRange = mkVersionRange 1 currentClientNTFVersion + +supportedServerNTFVRange :: VersionRange +supportedServerNTFVRange = mkVersionRange 1 currentServerNTFVersion data NtfServerHandshake = NtfServerHandshake { ntfVersionRange :: VersionRange, - sessionId :: SessionId + sessionId :: SessionId, + -- pub key to agree shared secrets for command authorization and entity ID encryption. + authPubKey :: Maybe (X.SignedExact X.PubKey) } data NtfClientHandshake = NtfClientHandshake { -- | agreed SMP notifications server protocol version ntfVersion :: Version, -- | server identity - CA certificate fingerprint - keyHash :: C.KeyHash + keyHash :: C.KeyHash, + -- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys. + authPubKey :: Maybe C.PublicKeyX25519 } instance Encoding NtfServerHandshake where - smpEncode NtfServerHandshake {ntfVersionRange, sessionId} = - smpEncode (ntfVersionRange, sessionId) + smpEncode NtfServerHandshake {ntfVersionRange, sessionId, authPubKey} = + B.concat + [ smpEncode (ntfVersionRange, sessionId), + encodeAuthEncryptCmds (maxVersion ntfVersionRange) $ C.SignedObject <$> authPubKey + ] + smpP = do (ntfVersionRange, sessionId) <- smpP - pure NtfServerHandshake {ntfVersionRange, sessionId} + -- TODO drop SMP v6: remove special parser and make key non-optional + authPubKey <- authEncryptCmdsP (maxVersion ntfVersionRange) $ C.getSignedExact <$> smpP + pure NtfServerHandshake {ntfVersionRange, sessionId, authPubKey} + +encodeAuthEncryptCmds :: Encoding a => Version -> Maybe a -> ByteString +encodeAuthEncryptCmds v k + | v >= authBatchCmdsNTFVersion = maybe "" smpEncode k + | otherwise = "" + +authEncryptCmdsP :: Version -> Parser a -> Parser (Maybe a) +authEncryptCmdsP v p = if v >= authBatchCmdsNTFVersion then Just <$> p else pure Nothing instance Encoding NtfClientHandshake where - smpEncode NtfClientHandshake {ntfVersion, keyHash} = smpEncode (ntfVersion, keyHash) + smpEncode NtfClientHandshake {ntfVersion, keyHash, authPubKey} = + smpEncode (ntfVersion, keyHash) <> encodeNtfAuthPubKey ntfVersion authPubKey smpP = do (ntfVersion, keyHash) <- smpP - pure NtfClientHandshake {ntfVersion, keyHash} + -- TODO drop SMP v6: remove special parser and make key non-optional + authPubKey <- ntfAuthPubKeyP ntfVersion + pure NtfClientHandshake {ntfVersion, keyHash, authPubKey} + +ntfAuthPubKeyP :: Version -> Parser (Maybe C.PublicKeyX25519) +ntfAuthPubKeyP v = if v >= authBatchCmdsNTFVersion then Just <$> smpP else pure Nothing + +encodeNtfAuthPubKey :: Version -> Maybe C.PublicKeyX25519 -> ByteString +encodeNtfAuthPubKey v k + | v >= authBatchCmdsNTFVersion = maybe "" smpEncode k + | otherwise = "" -- | Notifcations server transport handshake. -ntfServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) -ntfServerHandshake c kh ntfVRange = do - let th@THandle {sessionId} = ntfTHandle c - sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange} +ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) +ntfServerHandshake serverSignKey c (k, pk) kh ntfVRange = do + let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c + let sk = C.signX509 serverSignKey $ C.publicToX509 k + sendHandshake th $ NtfServerHandshake {sessionId, ntfVersionRange = ntfVRange, authPubKey = Just sk} getHandshake th >>= \case - NtfClientHandshake {ntfVersion, keyHash} + NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = k'} | keyHash /= kh -> throwError $ TEHandshake IDENTITY - | ntfVersion `isCompatible` ntfVRange -> - pure (th :: THandle c) {thVersion = ntfVersion} + | v `isCompatible` ntfVRange -> + pure $ ntfThHandle th v pk k' | otherwise -> throwError $ TEHandshake VERSION -- | Notifcations server client transport handshake. -ntfClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) -ntfClientHandshake c keyHash ntfVRange = do - let th@THandle {sessionId} = ntfTHandle c - NtfServerHandshake {sessionId = sessId, ntfVersionRange} <- getHandshake th +ntfClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) +ntfClientHandshake c (k, pk) keyHash ntfVRange = do + let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c + NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey = sk'} <- getHandshake th if sessionId /= sessId then throwError TEBadSession else case ntfVersionRange `compatibleVersion` ntfVRange of - Just (Compatible ntfVersion) -> do - sendHandshake th $ NtfClientHandshake {ntfVersion, keyHash} - pure (th :: THandle c) {thVersion = ntfVersion} + Just (Compatible v) -> do + sk_ <- forM sk' $ \exact -> liftEitherWith (const $ TEHandshake BAD_AUTH) $ do + serverKey <- getServerVerifyKey c + pubKey <- C.verifyX509 serverKey exact + C.x509ToPublic (pubKey, []) >>= C.pubKey + sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash, authPubKey = Just k} + pure $ ntfThHandle th v pk sk_ Nothing -> throwError $ TEHandshake VERSION +ntfThHandle :: forall c. THandle c -> Version -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandle c +ntfThHandle th@THandle {params} v privKey k_ = + -- TODO drop SMP v6: make thAuth non-optional + let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_ + v3 = v >= authBatchCmdsNTFVersion + params' = params {thVersion = v, thAuth, implySessId = v3, batch = v3} + in (th :: THandle c) {params = params'} + ntfTHandle :: Transport c => c -> THandle c -ntfTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, batch = False} +ntfTHandle c = THandle {connection = c, params} + where + params = THandleParams {sessionId = tlsUnique c, blockSize = ntfBlockSize, thVersion = 0, thAuth = Nothing, implySessId = False, batch = False} diff --git a/src/Simplex/Messaging/Notifications/Types.hs b/src/Simplex/Messaging/Notifications/Types.hs index 34a0079bb..4465f8767 100644 --- a/src/Simplex/Messaging/Notifications/Types.hs +++ b/src/Simplex/Messaging/Notifications/Types.hs @@ -47,10 +47,11 @@ data NtfToken = NtfToken { deviceToken :: DeviceToken, ntfServer :: NtfServer, ntfTokenId :: Maybe NtfTokenId, + -- TODO combine keys to key pair as the types should match -- | key used by the ntf server to verify transmissions - ntfPubKey :: C.APublicVerifyKey, + ntfPubKey :: C.APublicAuthKey, -- | key used by the ntf client to sign transmissions - ntfPrivKey :: C.APrivateSignKey, + ntfPrivKey :: C.APrivateAuthKey, -- | client's DH keys (to repeat registration if necessary) ntfDhKeys :: C.KeyPair 'C.X25519, -- | shared DH secret used to encrypt/decrypt notifications e2e @@ -63,7 +64,7 @@ data NtfToken = NtfToken } deriving (Show) -newNtfToken :: DeviceToken -> NtfServer -> C.ASignatureKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken +newNtfToken :: DeviceToken -> NtfServer -> C.AAuthKeyPair -> C.KeyPair 'C.X25519 -> NotificationsMode -> NtfToken newNtfToken deviceToken ntfServer (ntfPubKey, ntfPrivKey) ntfDhKeys ntfMode = NtfToken { deviceToken, diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index e8be3b126..78a8d757f 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -59,6 +59,7 @@ module Simplex.Messaging.Protocol ErrorType (..), CommandError (..), Transmission, + TransmissionAuth (..), SignedTransmission, SentRawTransmission, SignedRawTransmission, @@ -92,14 +93,14 @@ module Simplex.Messaging.Protocol RecipientId, SenderId, NotifierId, - RcvPrivateSignKey, - RcvPublicVerifyKey, + RcvPrivateAuthKey, + RcvPublicAuthKey, RcvPublicDhKey, RcvDhSecret, - SndPrivateSignKey, - SndPublicVerifyKey, - NtfPrivateSignKey, - NtfPublicVerifyKey, + SndPrivateAuthKey, + SndPublicAuthKey, + NtfPrivateAuthKey, + NtfPublicAuthKey, RcvNtfPublicDhKey, RcvNtfDhSecret, Message (..), @@ -124,6 +125,8 @@ module Simplex.Messaging.Protocol -- * Parse and serialize ProtocolMsgTag (..), messageTagP, + TransmissionForAuth (..), + encodeTransmissionForAuth, encodeTransmission, transmissionP, _smpP, @@ -155,11 +158,13 @@ module Simplex.Messaging.Protocol where import Control.Applicative (optional, (<|>)) +import Control.Monad import Control.Monad.Except import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser, ()) import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char (isPrint, isSpace) @@ -240,14 +245,14 @@ deriving instance Show Cmd type Transmission c = (CorrId, EntityId, c) -- | signed parsed transmission, with original raw bytes and parsing error. -type SignedTransmission e c = (Maybe C.ASignature, Signed, Transmission (Either e c)) +type SignedTransmission e c = (Maybe TransmissionAuth, Signed, Transmission (Either e c)) type Signed = ByteString -- | unparsed SMP transmission with signature. data RawTransmission = RawTransmission - { signature :: ByteString, - signed :: ByteString, + { authenticator :: ByteString, -- signature or encrypted transmission hash + authorized :: ByteString, -- authorized transmission sessId :: SessionId, corrId :: ByteString, entityId :: ByteString, @@ -255,11 +260,32 @@ data RawTransmission = RawTransmission } deriving (Show) +data TransmissionAuth + = TASignature C.ASignature + | TAAuthenticator C.CbAuthenticator + deriving (Eq, Show) + +-- this encoding is backwards compatible with v6 that used Maybe C.ASignature instead of TAuthorization +tAuthBytes :: Maybe TransmissionAuth -> ByteString +tAuthBytes = \case + Nothing -> "" + Just (TASignature s) -> C.signatureBytes s + Just (TAAuthenticator (C.CbAuthenticator s)) -> s + +decodeTAuthBytes :: ByteString -> Either String (Maybe TransmissionAuth) +decodeTAuthBytes s + | B.null s = Right Nothing + | B.length s == C.cbAuthenticatorSize = Right . Just . TAAuthenticator $ C.CbAuthenticator s + | otherwise = Just . TASignature <$> C.decodeSignature s + +instance IsString (Maybe TransmissionAuth) where + fromString = parseString $ B64.decode >=> C.decodeSignature >=> pure . fmap TASignature + -- | unparsed sent SMP transmission with signature, without session ID. -type SignedRawTransmission = (Maybe C.ASignature, SessionId, ByteString, ByteString) +type SignedRawTransmission = (Maybe TransmissionAuth, SessionId, ByteString, ByteString) -- | unparsed sent SMP transmission with signature. -type SentRawTransmission = (Maybe C.ASignature, ByteString) +type SentRawTransmission = (Maybe TransmissionAuth, ByteString) -- | SMP queue ID for the recipient. type RecipientId = QueueId @@ -278,10 +304,14 @@ type EntityId = ByteString -- | Parameterized type for SMP protocol commands from all clients. data Command (p :: Party) where -- SMP recipient commands - NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient + -- RcvPublicAuthKey is the key used for command authorization: + -- v6 of SMP servers only support signature algorithm for command authorization. + -- v7 of SMP servers additionally support additional layer of authenticated encryption. + -- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys. + NEW :: RcvPublicAuthKey -> RcvPublicDhKey -> Maybe BasicAuth -> SubscriptionMode -> Command Recipient SUB :: Command Recipient - KEY :: SndPublicVerifyKey -> Command Recipient - NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient + KEY :: SndPublicAuthKey -> Command Recipient + NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient NDEL :: Command Recipient GET :: Command Recipient -- ACK v1 has to be supported for encoding/decoding @@ -641,7 +671,7 @@ instance Encoding ClientMsgEnvelope where data ClientMessage = ClientMessage PrivHeader ByteString data PrivHeader - = PHConfirmation C.APublicVerifyKey + = PHConfirmation C.APublicAuthKey | PHEmpty deriving (Show) @@ -942,13 +972,13 @@ data QueueIdsKeys = QIK } deriving (Eq, Show) --- | Recipient's private key used by the recipient to authorize (sign) SMP commands. +-- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key. -type RcvPrivateSignKey = C.APrivateSignKey +type RcvPrivateAuthKey = C.APrivateAuthKey -- | Recipient's public key used by SMP server to verify authorization of SMP commands. -type RcvPublicVerifyKey = C.APublicVerifyKey +type RcvPublicAuthKey = C.APublicAuthKey -- | Public key used for DH exchange to encrypt message bodies from server to recipient type RcvPublicDhKey = C.PublicKeyX25519 @@ -956,19 +986,19 @@ type RcvPublicDhKey = C.PublicKeyX25519 -- | DH Secret used to encrypt message bodies from server to recipient type RcvDhSecret = C.DhSecretX25519 --- | Sender's private key used by the recipient to authorize (sign) SMP commands. +-- | Sender's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key. -type SndPrivateSignKey = C.APrivateSignKey +type SndPrivateAuthKey = C.APrivateAuthKey -- | Sender's public key used by SMP server to verify authorization of SMP commands. -type SndPublicVerifyKey = C.APublicVerifyKey +type SndPublicAuthKey = C.APublicAuthKey --- | Private key used by push notifications server to authorize (sign) NSUB command. -type NtfPrivateSignKey = C.APrivateSignKey +-- | Private key used by push notifications server to authorize (sign or encrypt hash) NSUB command. +type NtfPrivateAuthKey = C.APrivateAuthKey -- | Public key used by SMP server to verify authorization of NSUB command sent by push notifications server. -type NtfPublicVerifyKey = C.APublicVerifyKey +type NtfPublicAuthKey = C.APublicAuthKey -- | Public key used for DH exchange to encrypt notification metadata from server to recipient type RcvNtfPublicDhKey = C.PublicKeyX25519 @@ -1029,23 +1059,24 @@ data CommandError deriving (Eq, Read, Show) -- | SMP transmission parser. -transmissionP :: Parser RawTransmission -transmissionP = do - signature <- smpP - signed <- A.takeByteString - either fail pure $ parseAll (trn signature signed) signed +transmissionP :: THandleParams -> Parser RawTransmission +transmissionP THandleParams {sessionId, implySessId} = do + authenticator <- smpP + authorized <- A.takeByteString + either fail pure $ parseAll (trn authenticator authorized) authorized where - trn signature signed = do - sessId <- smpP + trn authenticator authorized = do + sessId <- if implySessId then pure "" else smpP + let authorized' = if implySessId then smpEncode sessionId <> authorized else authorized corrId <- smpP entityId <- smpP command <- A.takeByteString - pure RawTransmission {signature, signed, sessId, corrId, entityId, command} + pure RawTransmission {authenticator, authorized = authorized', sessId, corrId, entityId, command} class (ProtocolEncoding err msg, ProtocolEncoding err (ProtoCommand msg), Show err, Show msg) => Protocol err msg | msg -> err where type ProtoCommand msg = cmd | cmd -> msg type ProtoType msg = (sch :: ProtocolType) | sch -> msg - protocolClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) + protocolClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) protocolPing :: ProtoCommand msg protocolError :: msg -> Maybe err @@ -1071,8 +1102,8 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where type Tag (Command p) = CommandTag p encodeProtocol v = \case NEW rKey dhKey auth_ subMode - | v >= 6 -> new <> auth <> e subMode - | v == 5 -> new <> auth + | v >= subModeSMPVersion -> new <> auth <> e subMode + | v == basicAuthSMPVersion -> new <> auth | otherwise -> new where new = e (NEW_, ' ', rKey, dhKey) @@ -1101,10 +1132,10 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where fromProtocolError = fromProtocolError @ErrorType @BrokerMsg {-# INLINE fromProtocolError #-} - checkCredentials (sig, _, queueId, _) cmd = case cmd of + checkCredentials (auth, _, queueId, _) cmd = case cmd of -- NEW must have signature but NOT queue ID NEW {} - | isNothing sig -> Left $ CMD NO_AUTH + | isNothing auth -> Left $ CMD NO_AUTH | not (B.null queueId) -> Left $ CMD HAS_AUTH | otherwise -> Right cmd -- SEND must have queue ID, signature is not always required @@ -1113,11 +1144,11 @@ instance PartyI p => ProtocolEncoding ErrorType (Command p) where | otherwise -> Right cmd -- PING must not have queue ID or signature PING - | isNothing sig && B.null queueId -> Right cmd + | isNothing auth && B.null queueId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and queue ID _ - | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH + | isNothing auth || B.null queueId -> Left $ CMD NO_AUTH | otherwise -> Right cmd instance ProtocolEncoding ErrorType Cmd where @@ -1128,8 +1159,8 @@ instance ProtocolEncoding ErrorType Cmd where CT SRecipient tag -> Cmd SRecipient <$> case tag of NEW_ - | v >= 6 -> new <*> auth <*> smpP - | v == 5 -> new <*> auth <*> pure SMSubscribe + | v >= subModeSMPVersion -> new <*> auth <*> smpP + | v == basicAuthSMPVersion -> new <*> auth <*> pure SMSubscribe | otherwise -> new <*> pure Nothing <*> pure SMSubscribe where new = NEW <$> _smpP <*> smpP @@ -1274,13 +1305,13 @@ instance Encoding CommandError where _ -> fail "bad command error type" -- | Send signed SMP transmission to TCP transport. -tPut :: Transport c => THandle c -> NonEmpty SentRawTransmission -> IO [Either TransportError ()] -tPut th = fmap concat . mapM tPutBatch . batchTransmissions (batch th) (blockSize th) +tPut :: Transport c => THandle c -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()] +tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions (batch params) (blockSize params) where tPutBatch :: TransportBatch () -> IO [Either TransportError ()] tPutBatch = \case - TBLargeTransmission _ -> [Left TELargeMsg] <$ putStrLn "tPut error: large message" - TBTransmissions s n _ -> replicate n <$> (tPutLog th s) + TBError e _ -> [Left e] <$ putStrLn "tPut error: large message" + TBTransmissions s n _ -> replicate n <$> tPutLog th s TBTransmission s _ -> (: []) <$> tPutLog th s tPutLog :: Transport c => THandle c -> ByteString -> IO (Either TransportError ()) @@ -1292,42 +1323,46 @@ tPutLog th s = do pure r -- ByteString in TBTransmissions includes byte with transmissions count -data TransportBatch r = TBTransmissions ByteString Int [r] | TBTransmission ByteString r | TBLargeTransmission r +data TransportBatch r = TBTransmissions ByteString Int [r] | TBTransmission ByteString r | TBError TransportError r -batchTransmissions :: Bool -> Int -> NonEmpty SentRawTransmission -> [TransportBatch ()] +batchTransmissions :: Bool -> Int -> NonEmpty (Either TransportError SentRawTransmission) -> [TransportBatch ()] batchTransmissions batch bSize = batchTransmissions' batch bSize . L.map (,()) -- | encodes and batches transmissions into blocks, -batchTransmissions' :: forall r. Bool -> Int -> NonEmpty (SentRawTransmission, r) -> [TransportBatch r] +batchTransmissions' :: forall r. Bool -> Int -> NonEmpty (Either TransportError SentRawTransmission, r) -> [TransportBatch r] batchTransmissions' batch bSize | batch = addBatch . foldr addTransmission ([], 0, 0, [], []) | otherwise = map mkBatch1 . L.toList where - mkBatch1 :: (SentRawTransmission, r) -> TransportBatch r - mkBatch1 (t, r) - -- 2 bytes are reserved for pad size - | B.length s <= bSize - 2 = TBTransmission s r - | otherwise = TBLargeTransmission r - where - s = tEncode t + mkBatch1 :: (Either TransportError SentRawTransmission, r) -> TransportBatch r + mkBatch1 (t_, r) = case t_ of + Left e -> TBError e r + Right t + -- 2 bytes are reserved for pad size + | B.length s <= bSize - 2 -> TBTransmission s r + | otherwise -> TBError TELargeMsg r + where + s = tEncode t -- 3 = 2 bytes reserved for pad size + 1 for transmission count bSize' = bSize - 3 - addTransmission :: (SentRawTransmission, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r]) - addTransmission (t, r) acc@(bs, len, n, ss, rs) - | len' <= bSize' && n < 255 = (bs, len', 1 + n, s : ss, r : rs) - | sLen <= bSize' = (addBatch acc, sLen, 1, [s], [r]) - | otherwise = (TBLargeTransmission r : addBatch acc, 0, 0, [], []) - where - s = tEncodeForBatch t - sLen = B.length s - len' = len + sLen + addTransmission :: (Either TransportError SentRawTransmission, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r]) + addTransmission (t_, r) acc@(bs, len, n, ss, rs) = case t_ of + Left e -> (TBError e r : addBatch acc, 0, 0, [], []) + Right t + | len' <= bSize' && n < 255 -> (bs, len', 1 + n, s : ss, r : rs) + | sLen <= bSize' -> (addBatch acc, sLen, 1, [s], [r]) + | otherwise -> (TBError TELargeMsg r : addBatch acc, 0, 0, [], []) + where + s = tEncodeForBatch t + sLen = B.length s + len' = len + sLen addBatch :: ([TransportBatch r], Int, Int, [ByteString], [r]) -> [TransportBatch r] addBatch (bs, _len, n, ss, rs) = if n == 0 then bs else TBTransmissions b n rs : bs where b = B.concat $ B.singleton (lenEncode n) : ss tEncode :: SentRawTransmission -> ByteString -tEncode (sig, t) = smpEncode (C.signatureBytes sig) <> t +tEncode (auth, t) = smpEncode (tAuthBytes auth) <> t {-# INLINE tEncode #-} tEncodeForBatch :: SentRawTransmission -> ByteString @@ -1338,22 +1373,40 @@ tEncodeBatch1 :: SentRawTransmission -> ByteString tEncodeBatch1 t = lenEncode 1 `B.cons` tEncodeForBatch t {-# INLINE tEncodeBatch1 #-} -encodeTransmission :: ProtocolEncoding e c => Version -> ByteString -> Transmission c -> ByteString -encodeTransmission v sessionId (CorrId corrId, queueId, command) = - smpEncode (sessionId, corrId, queueId) <> encodeProtocol v command +-- tForAuth is lazy to avoid computing it when there is no key to sign +data TransmissionForAuth = TransmissionForAuth {tForAuth :: ~ByteString, tToSend :: ByteString} + +encodeTransmissionForAuth :: ProtocolEncoding e c => THandleParams -> Transmission c -> TransmissionForAuth +encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId} t = + TransmissionForAuth {tForAuth, tToSend = if implySessId then t' else tForAuth} + where + tForAuth = smpEncode sessionId <> t' + t' = encodeTransmission_ v t +{-# INLINE encodeTransmissionForAuth #-} + +encodeTransmission :: ProtocolEncoding e c => THandleParams -> Transmission c -> ByteString +encodeTransmission THandleParams {thVersion = v, sessionId, implySessId} t = + if implySessId then t' else smpEncode sessionId <> t' + where + t' = encodeTransmission_ v t {-# INLINE encodeTransmission #-} +encodeTransmission_ :: ProtocolEncoding e c => Version -> Transmission c -> ByteString +encodeTransmission_ v (CorrId corrId, queueId, command) = + smpEncode (corrId, queueId) <> encodeProtocol v command +{-# INLINE encodeTransmission_ #-} + -- | Receive and parse transmission from the TCP transport (ignoring any trailing padding). tGetParse :: Transport c => THandle c -> IO (NonEmpty (Either TransportError RawTransmission)) -tGetParse th = eitherList (tParse $ batch th) <$> tGetBlock th +tGetParse th@THandle {params} = eitherList (tParse params) <$> tGetBlock th {-# INLINE tGetParse #-} -tParse :: Bool -> ByteString -> NonEmpty (Either TransportError RawTransmission) -tParse batch s +tParse :: THandleParams -> ByteString -> NonEmpty (Either TransportError RawTransmission) +tParse thParams@THandleParams {batch} s | batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts | otherwise = [tParse1 s] where - tParse1 = parse transmissionP TEBadBlock + tParse1 = parse (transmissionP thParams) TEBadBlock ts = parse smpP TEBadBlock s eitherList :: (a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b) @@ -1361,14 +1414,14 @@ eitherList = either (\e -> [Left e]) -- | Receive client and server transmissions (determined by `cmd` type). tGet :: forall err cmd c. (ProtocolEncoding err cmd, Transport c) => THandle c -> IO (NonEmpty (SignedTransmission err cmd)) -tGet th@THandle {sessionId, thVersion = v} = L.map (tDecodeParseValidate sessionId v) <$> tGetParse th +tGet th@THandle {params} = L.map (tDecodeParseValidate params) <$> tGetParse th -tDecodeParseValidate :: forall err cmd. ProtocolEncoding err cmd => SessionId -> Version -> Either TransportError RawTransmission -> SignedTransmission err cmd -tDecodeParseValidate sessionId v = \case - Right RawTransmission {signature, signed, sessId, corrId, entityId, command} - | sessId == sessionId -> - let decodedTransmission = (,corrId,entityId,command) <$> C.decodeSignature signature - in either (const $ tError corrId) (tParseValidate signed) decodedTransmission +tDecodeParseValidate :: forall err cmd. ProtocolEncoding err cmd => THandleParams -> Either TransportError RawTransmission -> SignedTransmission err cmd +tDecodeParseValidate THandleParams {sessionId, thVersion = v, implySessId} = \case + Right RawTransmission {authenticator, authorized, sessId, corrId, entityId, command} + | implySessId || sessId == sessionId -> + let decodedTransmission = (,corrId,entityId,command) <$> decodeTAuthBytes authenticator + in either (const $ tError corrId) (tParseValidate authorized) decodedTransmission | otherwise -> (Nothing, "", (CorrId corrId, "", Left $ fromProtocolError @err @cmd PESession)) Left _ -> tError "" where diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 1bf7de2eb..83fe32d40 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -13,6 +13,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Simplex.Messaging.Server @@ -31,7 +32,7 @@ module Simplex.Messaging.Server ( runSMPServer, runSMPServerBlocking, disconnectTransport, - verifyCmdSignature, + verifyCmdAuthorization, dummyVerifyCmd, randomId, ) @@ -132,7 +133,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do runServer (tcpPort, ATransport t) = do serverParams <- asks tlsServerParams ss <- asks sockets - runTransportServerState ss started tcpPort serverParams tCfg (runClient t) + serverSignKey <- either fail pure . fromTLSCredentials $ tlsServerCredentials serverParams + runTransportServerState ss started tcpPort serverParams tCfg (runClient serverSignKey t) + fromTLSCredentials (_, pk) = C.x509ToPrivate (pk, []) >>= C.privKey saveServer :: Bool -> M () saveServer keepMsgs = withLog closeStoreLog >> saveServerMessages keepMsgs >> saveServerStats @@ -243,12 +246,13 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do ] liftIO $ threadDelay' interval - runClient :: Transport c => TProxy c -> c -> M () - runClient tp h = do + runClient :: Transport c => C.APrivateSignKey -> TProxy c -> c -> M () + runClient signKey tp h = do kh <- asks serverIdentity + ks <- atomically . C.generateKeyPair =<< asks random ServerConfig {smpServerVRange, smpHandshakeTimeout} <- asks config labelMyThread $ "smp handshake for " <> transportName tp - liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake h kh smpServerVRange) >>= \case + liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake signKey h ks kh smpServerVRange) >>= \case Just (Right th) -> runClientTransport th _ -> pure () @@ -369,7 +373,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do CPSkip -> pure () runClientTransport :: Transport c => THandle c -> M () -runClientTransport th@THandle {thVersion, sessionId} = do +runClientTransport th@THandle {params = THandleParams {thVersion, sessionId}} = do q <- asks $ tbqSize . config ts <- liftIO getSystemTime active <- asks clients @@ -414,7 +418,7 @@ cancelSub sub = _ -> return () receive :: Transport c => THandle c -> Client -> M () -receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do +receive th@THandle {params = THandleParams {thAuth}} Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive" forever $ do ts <- L.toList <$> liftIO (tGet th) @@ -424,10 +428,10 @@ receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do write rcvQ $ snd as where cmdAction :: SignedTransmission ErrorType Cmd -> M (Either (Transmission BrokerMsg) (Maybe QueueRec, Transmission Cmd)) - cmdAction (sig, signed, (corrId, queueId, cmdOrError)) = + cmdAction (tAuth, authorized, (corrId, queueId, cmdOrError)) = case cmdOrError of Left e -> pure $ Left (corrId, queueId, ERR e) - Right cmd -> verified <$> verifyTransmission sig signed queueId cmd + Right cmd -> verified <$> verifyTransmission ((,C.cbNonce (bs corrId)) <$> thAuth) tAuth authorized queueId cmd where verified = \case VRVerified qr -> Right (qr, (corrId, queueId, cmd)) @@ -435,11 +439,12 @@ receive th Client {rcvQ, sndQ, rcvActiveAt, sessionId} = do write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty send :: Transport c => THandle c -> Client -> IO () -send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do +send h@THandle {params} Client {sndQ, sessionId, sndActiveAt} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " send" forever $ do ts <- atomically $ L.sortWith tOrder <$> readTBQueue sndQ - void . liftIO . tPut h $ L.map ((Nothing,) . encodeTransmission v sessionId) ts + -- TODO we can authorize responses as well + void . liftIO . tPut h $ L.map (\t -> Right (Nothing, encodeTransmission params t)) ts atomically . writeTVar sndActiveAt =<< liftIO getSystemTime where tOrder :: Transmission BrokerMsg -> Int @@ -449,7 +454,7 @@ send h@THandle {thVersion = v} Client {sndQ, sessionId, sndActiveAt} = do _ -> 1 disconnectTransport :: Transport c => THandle c -> TVar SystemTime -> TVar SystemTime -> ExpirationConfig -> IO Bool -> IO () -disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expCfg noSubscriptions = do +disconnectTransport THandle {connection, params = THandleParams {sessionId}} rcvActiveAt sndActiveAt expCfg noSubscriptions = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " disconnectTransport" loop where @@ -463,44 +468,69 @@ disconnectTransport THandle {connection, sessionId} rcvActiveAt sndActiveAt expC data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed -verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult -verifyTransmission sig_ signed queueId cmd = +-- This function verifies queue command authorization, with the objective to have constant time between the three AUTH error scenarios: +-- - the queue and party key exist, and the provided authorization has type matching queue key, but it is made with the different key. +-- - the queue and party key exist, but the provided authorization has incorrect type. +-- - the queue or party key do not exist. +-- In all cases, the time of the verification should depend only on the provided authorization type, +-- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result. +verifyTransmission :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> QueueId -> Cmd -> M VerificationResult +verifyTransmission auth_ tAuth authorized queueId cmd = case cmd of - Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k - Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey - Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey + Cmd SRecipient (NEW k _ _ _) -> pure $ Nothing `verifiedWith` k + Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey q) <$> get SRecipient + -- SEND will be accepted without authorization before the queue is secured with KEY command + Cmd SSender SEND {} -> verifyQueue (\q -> Just q `verified` maybe (isNothing tAuth) verify (senderKey q)) <$> get SSender Cmd SSender PING -> pure $ VRVerified Nothing - Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap notifierKey . notifier + -- NSUB will not be accepted without authorization + Cmd SNotifier NSUB -> verifyQueue (\q -> maybe dummyVerify (Just q `verifiedWith`) (notifierKey <$> notifier q)) <$> get SNotifier where - verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult - verifyCmd party f = do - st <- asks queueStore - q_ <- atomically $ getQueue st party queueId - pure $ case q_ of - Right q -> Just q `verified` f q - _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed - verifyMaybe :: Maybe C.APublicVerifyKey -> Bool - verifyMaybe = maybe (isNothing sig_) $ verifyCmdSignature sig_ signed + verify = verifyCmdAuthorization auth_ tAuth authorized + dummyVerify = verify (dummyAuthKey tAuth) `seq` VRFailed + verifyQueue :: (QueueRec -> VerificationResult) -> Either ErrorType QueueRec -> VerificationResult + verifyQueue = either (\_ -> dummyVerify) verified q cond = if cond then VRVerified q else VRFailed + verifiedWith q k = q `verified` verify k + get :: SParty p -> M (Either ErrorType QueueRec) + get party = do + st <- asks queueStore + atomically $ getQueue st party queueId -verifyCmdSignature :: Maybe C.ASignature -> ByteString -> C.APublicVerifyKey -> Bool -verifyCmdSignature sig_ signed key = maybe False (verify key) sig_ +verifyCmdAuthorization :: Maybe (THandleAuth, C.CbNonce) -> Maybe TransmissionAuth -> ByteString -> C.APublicAuthKey -> Bool +verifyCmdAuthorization auth_ tAuth authorized key = maybe False (verify key) tAuth where - verify :: C.APublicVerifyKey -> C.ASignature -> Bool - verify (C.APublicVerifyKey a k) sig@(C.ASignature a' s) = - case (testEquality a a', C.signatureSize k == C.signatureSize s) of - (Just Refl, True) -> C.verify' k s signed - _ -> dummyVerifyCmd signed sig `seq` False + verify :: C.APublicAuthKey -> TransmissionAuth -> Bool + verify (C.APublicAuthKey a k) = \case + TASignature (C.ASignature a' s) -> case testEquality a a' of + Just Refl -> C.verify' k s authorized + _ -> C.verify' (dummySignKey a') s authorized `seq` False + TAAuthenticator s -> case a of + C.SX25519 -> verifyCmdAuth auth_ k s authorized + _ -> verifyCmdAuth auth_ dummyKeyX25519 s authorized `seq` False -dummyVerifyCmd :: ByteString -> C.ASignature -> Bool -dummyVerifyCmd signed (C.ASignature _ s) = C.verify' (dummyPublicKey s) s signed +verifyCmdAuth :: Maybe (THandleAuth, C.CbNonce) -> C.PublicKeyX25519 -> C.CbAuthenticator -> ByteString -> Bool +verifyCmdAuth auth_ k authenticator authorized = case auth_ of + Just (THandleAuth {privKey}, nonce) -> C.cbVerify k privKey nonce authenticator authorized + Nothing -> False + +dummyVerifyCmd :: Maybe (THandleAuth, C.CbNonce) -> ByteString -> TransmissionAuth -> Bool +dummyVerifyCmd auth_ authorized = \case + TASignature (C.ASignature a s) -> C.verify' (dummySignKey a) s authorized + TAAuthenticator s -> verifyCmdAuth auth_ dummyKeyX25519 s authorized -- These dummy keys are used with `dummyVerify` function to mitigate timing attacks -- by having the same time of the response whether a queue exists or nor, for all valid key/signature sizes -dummyPublicKey :: C.Signature a -> C.PublicKey a -dummyPublicKey = \case - C.SignatureEd25519 _ -> dummyKeyEd25519 - C.SignatureEd448 _ -> dummyKeyEd448 +dummySignKey :: C.SignatureAlgorithm a => C.SAlgorithm a -> C.PublicKey a +dummySignKey = \case + C.SEd25519 -> dummyKeyEd25519 + C.SEd448 -> dummyKeyEd448 + +dummyAuthKey :: Maybe TransmissionAuth -> C.APublicAuthKey +dummyAuthKey = \case + Just (TASignature (C.ASignature a _)) -> case a of + C.SEd25519 -> C.APublicAuthKey C.SEd25519 dummyKeyEd25519 + C.SEd448 -> C.APublicAuthKey C.SEd448 dummyKeyEd448 + _ -> C.APublicAuthKey C.SX25519 dummyKeyX25519 dummyKeyEd25519 :: C.PublicKey 'C.Ed25519 dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs=" @@ -508,6 +538,9 @@ dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs=" dummyKeyEd448 :: C.PublicKey 'C.Ed448 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA" +dummyKeyX25519 :: C.PublicKey 'C.X25519 +dummyKeyX25519 = "MCowBQYDK2VuAyEA4JGSMYht18H4mas/jHeBwfcM7jLwNYJNOAhi2/g4RXg=" + client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m () client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sessionId} Server {subscribedQ, ntfSubscribedQ, notifiers} = do labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands" @@ -545,7 +578,7 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess OFF -> suspendQueue_ st DEL -> delQueueAndMsgs st where - createQueue :: QueueStore -> RcvPublicVerifyKey -> RcvPublicDhKey -> SubscriptionMode -> m (Transmission BrokerMsg) + createQueue :: QueueStore -> RcvPublicAuthKey -> RcvPublicDhKey -> SubscriptionMode -> m (Transmission BrokerMsg) createQueue st recipientKey dhKey subMode = time "NEW" $ do (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvDhSecret = C.dh' dhKey privDhKey @@ -593,14 +626,14 @@ client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ, sess n <- asks $ queueIdBytes . config liftM2 (,) (randomId n) (randomId n) - secureQueue_ :: QueueStore -> SndPublicVerifyKey -> m (Transmission BrokerMsg) + secureQueue_ :: QueueStore -> SndPublicAuthKey -> m (Transmission BrokerMsg) secureQueue_ st sKey = time "KEY" $ do withLog $ \s -> logSecureQueue s queueId sKey stats <- asks serverStats atomically $ modifyTVar' (qSecured stats) (+ 1) atomically $ (corrId,queueId,) . either ERR (const OK) <$> secureQueue st queueId sKey - addQueueNotifier_ :: QueueStore -> NtfPublicVerifyKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg) + addQueueNotifier_ :: QueueStore -> NtfPublicAuthKey -> RcvNtfPublicDhKey -> m (Transmission BrokerMsg) addQueueNotifier_ st notifierKey dhKey = time "NKEY" $ do (rcvPublicDhKey, privDhKey) <- atomically . C.generateKeyPair =<< asks random let rcvNtfDhSecret = C.dh' dhKey privDhKey diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index 13b2af4a3..cfe08c621 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -25,7 +25,7 @@ import Simplex.Messaging.Server (runSMPServer) import Simplex.Messaging.Server.CLI import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defMsgExpirationDays, defaultInactiveClientExpiration, defaultMessageExpiration) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (simplexMQVersion, supportedSMPServerVRange) +import Simplex.Messaging.Transport (simplexMQVersion, supportedServerSMPRelayVRange) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Server (TransportServerConfig (..), defaultTransportServerConfig) import Simplex.Messaging.Util (safeDecodeUtf8) @@ -204,7 +204,7 @@ smpServerCLI cfgPath logPath = logStatsStartTime = 0, -- seconds from 00:00 UTC serverStatsLogFile = combine logPath "smp-server-stats.daily.log", serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log", - smpServerVRange = supportedSMPServerVRange, + smpServerVRange = supportedServerSMPRelayVRange, transportConfig = defaultTransportServerConfig { logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index 8a7856eb6..56ce9b679 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -10,10 +10,10 @@ import Simplex.Messaging.Protocol data QueueRec = QueueRec { recipientId :: !RecipientId, - recipientKey :: !RcvPublicVerifyKey, + recipientKey :: !RcvPublicAuthKey, rcvDhSecret :: !RcvDhSecret, senderId :: !SenderId, - senderKey :: !(Maybe SndPublicVerifyKey), + senderKey :: !(Maybe SndPublicAuthKey), notifier :: !(Maybe NtfCreds), status :: !ServerQueueStatus } @@ -21,7 +21,7 @@ data QueueRec = QueueRec data NtfCreds = NtfCreds { notifierId :: !NotifierId, - notifierKey :: !NtfPublicVerifyKey, + notifierKey :: !NtfPublicAuthKey, rcvNtfDhSecret :: !RcvNtfDhSecret } deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index b4c41c0de..195955513 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -63,7 +63,7 @@ getQueue QueueStore {queues, senders, notifiers} party qId = SSender -> TM.lookup qId senders $>>= (`TM.lookup` queues) SNotifier -> TM.lookup qId notifiers $>>= (`TM.lookup` queues) -secureQueue :: QueueStore -> RecipientId -> SndPublicVerifyKey -> STM (Either ErrorType QueueRec) +secureQueue :: QueueStore -> RecipientId -> SndPublicAuthKey -> STM (Either ErrorType QueueRec) secureQueue QueueStore {queues} rId sKey = withQueue rId queues $ \qVar -> readTVar qVar >>= \q -> case senderKey q of diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index b88338ab8..b3f5486b8 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -46,7 +46,7 @@ data StoreLog (a :: IOMode) where data StoreLogRecord = CreateQueue QueueRec - | SecureQueue QueueId SndPublicVerifyKey + | SecureQueue QueueId SndPublicAuthKey | AddNotifier QueueId NtfCreds | SuspendQueue QueueId | DeleteQueue QueueId @@ -120,7 +120,7 @@ writeStoreLogRecord (WriteStoreLog _ h) r = do logCreateQueue :: StoreLog 'WriteMode -> QueueRec -> IO () logCreateQueue s = writeStoreLogRecord s . CreateQueue -logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicVerifyKey -> IO () +logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO () logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NtfCreds -> IO () diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index d0f371cef..0d9552f9b 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -26,7 +27,13 @@ -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a module Simplex.Messaging.Transport ( -- * SMP transport parameters - supportedSMPServerVRange, + supportedClientSMPRelayVRange, + supportedServerSMPRelayVRange, + currentClientSMPRelayVersion, + currentServerSMPRelayVersion, + basicAuthSMPVersion, + subModeSMPVersion, + authCmdsSMPVersion, simplexMQVersion, smpBlockSize, TransportConfig (..), @@ -36,6 +43,7 @@ module Simplex.Messaging.Transport TProxy (..), ATransport (..), TransportPeer (..), + getServerVerifyKey, -- * TLS Transport TLS (..), @@ -47,6 +55,8 @@ module Simplex.Messaging.Transport -- * SMP transport THandle (..), + THandleParams (..), + THandleAuth (..), TransportError (..), HandshakeError (..), smpServerHandshake, @@ -61,12 +71,13 @@ module Simplex.Messaging.Transport where import Control.Applicative ((<|>)) +import Control.Monad (forM) import Control.Monad.Except import Control.Monad.Trans.Except (throwE) import qualified Data.Aeson.TH as J import Data.Attoparsec.ByteString.Char8 (Parser) import qualified Data.Attoparsec.ByteString.Char8 as A -import Data.Bifunctor (first) +import Data.Bifunctor (bimap, first) import Data.Bitraversable (bimapM) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -74,6 +85,8 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Default (def) import Data.Functor (($>)) import Data.Version (showVersion) +import qualified Data.X509 as X +import qualified Data.X509.Validation as XV import GHC.IO.Handle.Internals (ioe_EOF) import Network.Socket import qualified Network.TLS as T @@ -83,7 +96,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON) import Simplex.Messaging.Transport.Buffer -import Simplex.Messaging.Util (bshow, catchAll, catchAll_) +import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith) import Simplex.Messaging.Version import UnliftIO.Exception (Exception) import qualified UnliftIO.Exception as E @@ -94,8 +107,40 @@ import UnliftIO.STM smpBlockSize :: Int smpBlockSize = 16384 -supportedSMPServerVRange :: VersionRange -supportedSMPServerVRange = mkVersionRange 1 6 +-- SMP protocol version history: +-- 1 - binary protocol encoding (1/1/2022) +-- 2 - message flags (used to control notifications, 6/6/2022) +-- 3 - encrypt message timestamp and flags together with the body when delivered to the recipient (7/5/2022) +-- 4 - support command batching (7/17/2022) +-- 5 - basic auth for SMP servers (11/12/2022) +-- 6 - allow creating queues without subscribing (9/10/2023) +-- 7 - support authenticated encryption to verify senders' commands, imply but do NOT send session ID in signed part (2/3/2024) + +batchCmdsSMPVersion :: Version +batchCmdsSMPVersion = 4 + +basicAuthSMPVersion :: Version +basicAuthSMPVersion = 5 + +subModeSMPVersion :: Version +subModeSMPVersion = 6 + +authCmdsSMPVersion :: Version +authCmdsSMPVersion = 7 + +currentClientSMPRelayVersion :: Version +currentClientSMPRelayVersion = 6 + +currentServerSMPRelayVersion :: Version +currentServerSMPRelayVersion = 6 + +-- minimal supported protocol version is 4 +-- TODO remove code that supports sending commands without batching +supportedClientSMPRelayVRange :: VersionRange +supportedClientSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentClientSMPRelayVersion + +supportedServerSMPRelayVRange :: VersionRange +supportedServerSMPRelayVRange = mkVersionRange batchCmdsSMPVersion currentServerSMPRelayVersion simplexMQVersion :: String simplexMQVersion = showVersion SMQ.version @@ -118,10 +163,12 @@ class Transport c where transportConfig :: c -> TransportConfig -- | Upgrade server TLS context to connection (used in the server) - getServerConnection :: TransportConfig -> T.Context -> IO c + getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c -- | Upgrade client TLS context to connection (used in the client) - getClientConnection :: TransportConfig -> T.Context -> IO c + getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO c + + getServerCerts :: c -> X.CertificateChain -- | tls-unique channel binding per RFC5929 tlsUnique :: c -> SessionId @@ -149,6 +196,12 @@ data TProxy c = TProxy data ATransport = forall c. Transport c => ATransport (TProxy c) +getServerVerifyKey :: Transport c => c -> Either String C.APublicVerifyKey +getServerVerifyKey c = + case getServerCerts c of + X.CertificateChain (server : _ca) -> C.x509ToPublic (X.certPubKey . X.signedObject $ X.getSigned server, []) >>= C.pubKey + _ -> Left "no certificate chain" + -- * TLS Transport data TLS = TLS @@ -156,6 +209,7 @@ data TLS = TLS tlsPeer :: TransportPeer, tlsUniq :: ByteString, tlsBuffer :: TBuffer, + tlsServerCerts :: X.CertificateChain, tlsTransportConfig :: TransportConfig } @@ -168,12 +222,12 @@ connectTLS host_ TransportConfig {logTLSErrors} params sock = logThrow e = putStrLn ("TLS error" <> host <> ": " <> show e) >> E.throwIO e host = maybe "" (\h -> " (" <> h <> ")") host_ -getTLS :: TransportPeer -> TransportConfig -> T.Context -> IO TLS -getTLS tlsPeer cfg cxt = withTlsUnique tlsPeer cxt newTLS +getTLS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO TLS +getTLS tlsPeer cfg tlsServerCerts cxt = withTlsUnique tlsPeer cxt newTLS where newTLS tlsUniq = do tlsBuffer <- atomically newTBuffer - pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsPeer, tlsUniq, tlsBuffer} + pure TLS {tlsContext = cxt, tlsTransportConfig = cfg, tlsServerCerts, tlsPeer, tlsUniq, tlsBuffer} withTlsUnique :: TransportPeer -> T.Context -> (ByteString -> IO c) -> IO c withTlsUnique peer cxt f = @@ -208,6 +262,7 @@ instance Transport TLS where transportConfig = tlsTransportConfig getServerConnection = getTLS TServer getClientConnection = getTLS TClient + getServerCerts = tlsServerCerts tlsUnique = tlsUniq closeConnection tls = closeTLS $ tlsContext tls @@ -231,45 +286,85 @@ instance Transport TLS where -- * SMP transport --- | The handle for SMP encrypted transport connection over Transport . +-- | The handle for SMP encrypted transport connection over Transport. data THandle c = THandle { connection :: c, - sessionId :: SessionId, + params :: THandleParams + } + +data THandleParams = THandleParams + { sessionId :: SessionId, blockSize :: Int, -- | agreed server protocol version thVersion :: Version, + -- | peer public key for command authorization and shared secrets for entity ID encryption + thAuth :: Maybe THandleAuth, + -- | do NOT send session ID in transmission, but include it into signed message + -- based on protocol version + implySessId :: Bool, -- | send multiple transmissions in a single block - -- based on protocol and protocol version + -- based on protocol version batch :: Bool } +data THandleAuth = THandleAuth + { peerPubKey :: C.PublicKeyX25519, -- used only in the client to combine with per-queue key + privKey :: C.PrivateKeyX25519 -- used to combine with peer's per-queue key (currently only in the server) + } + -- | TLS-unique channel binding type SessionId = ByteString data ServerHandshake = ServerHandshake { smpVersionRange :: VersionRange, - sessionId :: SessionId + sessionId :: SessionId, + -- pub key to agree shared secrets for command authorization and entity ID encryption. + authPubKey :: Maybe (X.CertificateChain, X.SignedExact X.PubKey) } data ClientHandshake = ClientHandshake { -- | agreed SMP server protocol version smpVersion :: Version, -- | server identity - CA certificate fingerprint - keyHash :: C.KeyHash + keyHash :: C.KeyHash, + -- pub key to agree shared secret for entity ID encryption, shared secret for command authorization is agreed using per-queue keys. + authPubKey :: Maybe C.PublicKeyX25519 } instance Encoding ClientHandshake where - smpEncode ClientHandshake {smpVersion, keyHash} = smpEncode (smpVersion, keyHash) + smpEncode ClientHandshake {smpVersion, keyHash, authPubKey} = + smpEncode (smpVersion, keyHash) <> encodeAuthEncryptCmds smpVersion authPubKey smpP = do (smpVersion, keyHash) <- smpP - pure ClientHandshake {smpVersion, keyHash} + -- TODO drop SMP v6: remove special parser and make key non-optional + authPubKey <- authEncryptCmdsP smpVersion smpP + pure ClientHandshake {smpVersion, keyHash, authPubKey} instance Encoding ServerHandshake where - smpEncode ServerHandshake {smpVersionRange, sessionId} = - smpEncode (smpVersionRange, sessionId) + smpEncode ServerHandshake {smpVersionRange, sessionId, authPubKey} = + smpEncode (smpVersionRange, sessionId) <> auth + where + auth = + encodeAuthEncryptCmds (maxVersion smpVersionRange) $ + bimap C.encodeCertChain C.SignedObject <$> authPubKey smpP = do (smpVersionRange, sessionId) <- smpP - pure ServerHandshake {smpVersionRange, sessionId} + -- TODO drop SMP v6: remove special parser and make key non-optional + authPubKey <- authEncryptCmdsP (maxVersion smpVersionRange) authP + pure ServerHandshake {smpVersionRange, sessionId, authPubKey} + where + authP = do + cert <- C.certChainP + C.SignedObject key <- smpP + pure (cert, key) + +encodeAuthEncryptCmds :: Encoding a => Version -> Maybe a -> ByteString +encodeAuthEncryptCmds v k + | v >= authCmdsSMPVersion = maybe "" smpEncode k + | otherwise = "" + +authEncryptCmdsP :: Version -> Parser a -> Parser (Maybe a) +authEncryptCmdsP v p = if v >= authCmdsSMPVersion then Just <$> p else pure Nothing -- | Error of SMP encrypted transport over TCP. data TransportError @@ -279,6 +374,9 @@ data TransportError TELargeMsg | -- | incorrect session ID TEBadSession + | -- | absent server key for v7 entity + -- This error happens when the server did not provide a DH key to authorize commands for the queue that should be authorized with a DH key. + TENoServerAuth | -- | transport handshake error TEHandshake {handshakeErr :: HandshakeError} deriving (Eq, Read, Show, Exception) @@ -291,6 +389,8 @@ data HandshakeError VERSION | -- | incorrect server identity IDENTITY + | -- | v7 authentication failed + BAD_AUTH deriving (Eq, Read, Show, Exception) -- | SMP encrypted transport error parser. @@ -299,6 +399,7 @@ transportErrorP = "BLOCK" $> TEBadBlock <|> "LARGE_MSG" $> TELargeMsg <|> "SESSION" $> TEBadSession + <|> "NO_AUTH" $> TENoServerAuth <|> "HANDSHAKE " *> (TEHandshake <$> parseRead1) -- | Serialize SMP encrypted transport error. @@ -307,17 +408,18 @@ serializeTransportError = \case TEBadBlock -> "BLOCK" TELargeMsg -> "LARGE_MSG" TEBadSession -> "SESSION" + TENoServerAuth -> "NO_AUTH" TEHandshake e -> "HANDSHAKE " <> bshow e -- | Pad and send block to SMP transport. tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ()) -tPutBlock THandle {connection = c, blockSize} block = +tPutBlock THandle {connection = c, params = THandleParams {blockSize}} block = bimapM (const $ pure TELargeMsg) (cPut c) $ C.pad block blockSize -- | Receive block from SMP transport. tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString) -tGetBlock THandle {connection = c, blockSize} = do +tGetBlock THandle {connection = c, params = THandleParams {blockSize}} = do msg <- cGet c blockSize if B.length msg == blockSize then pure . first (const TELargeMsg) $ C.unPad msg @@ -326,35 +428,49 @@ tGetBlock THandle {connection = c, blockSize} = do -- | Server SMP transport handshake. -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a -smpServerHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) -smpServerHandshake c kh smpVRange = do - let th@THandle {sessionId} = smpTHandle c - sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange} +smpServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) +smpServerHandshake serverSignKey c (k, pk) kh smpVRange = do + let th@THandle {params = THandleParams {sessionId}} = smpTHandle c + sk = C.signX509 serverSignKey $ C.publicToX509 k + certChain = getServerCerts c + sendHandshake th $ ServerHandshake {sessionId, smpVersionRange = smpVRange, authPubKey = Just (certChain, sk)} getHandshake th >>= \case - ClientHandshake {smpVersion, keyHash} + ClientHandshake {smpVersion = v, keyHash, authPubKey = k'} | keyHash /= kh -> throwE $ TEHandshake IDENTITY - | smpVersion `isCompatible` smpVRange -> do - pure $ smpThHandle th smpVersion + | v `isCompatible` smpVRange -> + pure $ smpThHandle th v pk k' | otherwise -> throwE $ TEHandshake VERSION -- | Client SMP transport handshake. -- -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a -smpClientHandshake :: forall c. Transport c => c -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) -smpClientHandshake c keyHash smpVRange = do - let th@THandle {sessionId} = smpTHandle c - ServerHandshake {sessionId = sessId, smpVersionRange} <- getHandshake th +smpClientHandshake :: forall c. Transport c => c -> C.KeyPairX25519 -> C.KeyHash -> VersionRange -> ExceptT TransportError IO (THandle c) +smpClientHandshake c (k, pk) keyHash@(C.KeyHash kh) smpVRange = do + let th@THandle {params = THandleParams {sessionId}} = smpTHandle c + ServerHandshake {sessionId = sessId, smpVersionRange, authPubKey} <- getHandshake th if sessionId /= sessId then throwE TEBadSession else case smpVersionRange `compatibleVersion` smpVRange of - Just (Compatible smpVersion) -> do - sendHandshake th $ ClientHandshake {smpVersion, keyHash} - pure $ smpThHandle th smpVersion + Just (Compatible v) -> do + sk_ <- forM authPubKey $ \(X.CertificateChain cert, exact) -> + liftEitherWith (const $ TEHandshake BAD_AUTH) $ do + case cert of + [_leaf, ca] | XV.Fingerprint kh == XV.getFingerprint ca X.HashSHA256 -> pure () + _ -> throwError "bad certificate" + serverKey <- getServerVerifyKey c + pubKey <- C.verifyX509 serverKey exact + C.x509ToPublic (pubKey, []) >>= C.pubKey + sendHandshake th $ ClientHandshake {smpVersion = v, keyHash, authPubKey = Just k} + pure $ smpThHandle th v pk sk_ Nothing -> throwE $ TEHandshake VERSION -smpThHandle :: forall c. THandle c -> Version -> THandle c -smpThHandle th v = (th :: THandle c) {thVersion = v, batch = v >= 4} +smpThHandle :: forall c. THandle c -> Version -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> THandle c +smpThHandle th@THandle {params} v privKey k_ = + -- TODO drop SMP v6: make thAuth non-optional + let thAuth = (\k -> THandleAuth {peerPubKey = k, privKey}) <$> k_ + params' = params {thVersion = v, thAuth, implySessId = v >= authCmdsSMPVersion} + in (th :: THandle c) {params = params'} sendHandshake :: (Transport c, Encoding smp) => THandle c -> smp -> ExceptT TransportError IO () sendHandshake th = ExceptT . tPutBlock th . smpEncode @@ -364,7 +480,9 @@ getHandshake :: (Transport c, Encoding smp) => THandle c -> ExceptT TransportErr getHandshake th = ExceptT $ (first (\_ -> TEHandshake PARSE) . A.parseOnly smpP =<<) <$> tGetBlock th smpTHandle :: Transport c => c -> THandle c -smpTHandle c = THandle {connection = c, sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, batch = False} +smpTHandle c = THandle {connection = c, params} + where + params = THandleParams {sessionId = tlsUnique c, blockSize = smpBlockSize, thVersion = 0, thAuth = Nothing, implySessId = False, batch = True} $(J.deriveJSON (sumTypeJSON id) ''HandshakeError) diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index c36b33719..ddc08ae98 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -22,6 +22,7 @@ where import Control.Applicative (optional) import Control.Logger.Simple (logError) +import Control.Monad (when) import Control.Monad.IO.Unlift import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Attoparsec.ByteString.Char8 as A @@ -54,6 +55,7 @@ import System.IO.Error import Text.Read (readMaybe) import UnliftIO.Exception (IOException) import qualified UnliftIO.Exception as E +import UnliftIO.STM data TransportHost = THIPv4 (Word8, Word8, Word8, Word8) @@ -129,8 +131,9 @@ runTransportClient = runTLSTransportClient supportedParameters Nothing runTLSTransportClient :: (Transport c, MonadUnliftIO m) => T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, tcpKeepAlive, clientCredentials} proxyUsername host port keyHash client = do + serverCert <- newEmptyTMVarIO let hostName = B.unpack $ strEncode host - clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials + clientParams = mkTLSClientParams tlsParams caStore_ hostName port keyHash clientCredentials serverCert connectTCP = case socksProxy of Just proxy -> connectSocksClient proxy proxyUsername $ hostAddr host _ -> connectTCPClient hostName @@ -138,7 +141,13 @@ runTLSTransportClient tlsParams caStore_ cfg@TransportClientConfig {socksProxy, sock <- connectTCP port mapM_ (setSocketKeepAlive sock) tcpKeepAlive `catchAll` \e -> logError ("Error setting TCP keep-alive" <> tshow e) let tCfg = clientTransportConfig cfg - connectTLS (Just hostName) tCfg clientParams sock >>= getClientConnection tCfg + connectTLS (Just hostName) tCfg clientParams sock >>= \tls -> do + chain <- atomically (tryTakeTMVar serverCert) >>= \case + Nothing -> do + logError "onServerCertificate didn't fire or failed to get cert chain" + closeTLS tls >> error "onServerCertificate failed" + Just c -> pure c + getClientConnection tCfg chain tls client c `E.finally` liftIO (closeConnection c) where hostAddr = \case @@ -207,19 +216,24 @@ instance ToJSON SocksProxy where instance FromJSON SocksProxy where parseJSON = strParseJSON "SocksProxy" -mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> T.ClientParams -mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ = +mkTLSClientParams :: T.Supported -> Maybe XS.CertificateStore -> HostName -> ServiceName -> Maybe C.KeyHash -> Maybe (X.CertificateChain, T.PrivKey) -> TMVar X.CertificateChain -> T.ClientParams +mkTLSClientParams supported caStore_ host port cafp_ clientCreds_ serverCerts = (T.defaultParamsClient host p) { T.clientShared = def {T.sharedCAStore = fromMaybe (T.sharedCAStore def) caStore_}, T.clientHooks = def - { T.onServerCertificate = maybe def (\cafp _ _ _ -> validateCertificateChain cafp host p) cafp_, + { T.onServerCertificate = onServerCert, T.onCertificateRequest = maybe def (const . pure . Just) clientCreds_ }, T.clientSupported = supported } where p = B.pack port + onServerCert _ _ _ c = do + errs <- maybe def (\ca -> validateCertificateChain ca host p c) cafp_ + when (null errs) $ + atomically (putTMVar serverCerts c) + pure errs validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason] validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain] diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs index 06f97a353..983068434 100644 --- a/src/Simplex/Messaging/Transport/Server.hs +++ b/src/Simplex/Messaging/Transport/Server.hs @@ -19,6 +19,7 @@ module Simplex.Messaging.Transport.Server loadTLSServerParams, loadFingerprint, smpServerHandshake, + tlsServerCredentials ) where @@ -78,13 +79,13 @@ runTransportServerState :: forall c m. (Transport c, MonadUnliftIO m) => SocketS runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started port) (transportName (TProxy :: TProxy c)) -- | Run a transport server with provided connection setup and handler. -runTransportServerSocket :: (MonadUnliftIO m, T.TLSParams p, Transport a) => TMVar Bool -> IO Socket -> String -> p -> TransportServerConfig -> (a -> m ()) -> m () +runTransportServerSocket :: (MonadUnliftIO m, Transport a) => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> m ()) -> m () runTransportServerSocket started getSocket threadLabel serverParams cfg server = do ss <- atomically newSocketState runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server -- | Run a transport server with provided connection setup and handler. -runTransportServerSocketState :: (MonadUnliftIO m, T.TLSParams p, Transport a) => SocketState -> TMVar Bool -> IO Socket -> String -> p -> TransportServerConfig -> (a -> m ()) -> m () +runTransportServerSocketState :: (MonadUnliftIO m, Transport a) => SocketState -> TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> m ()) -> m () runTransportServerSocketState ss started getSocket threadLabel serverParams cfg server = do u <- askUnliftIO labelMyThread $ "transport server for " <> threadLabel @@ -95,7 +96,12 @@ runTransportServerSocketState ss started getSocket threadLabel serverParams cfg setup conn = timeout (tlsSetupTimeout cfg) $ do labelMyThread $ threadLabel <> "/setup" tls <- connectTLS Nothing tCfg serverParams conn - getServerConnection tCfg tls + getServerConnection tCfg (fst $ tlsServerCredentials serverParams) tls + +tlsServerCredentials :: T.ServerParams -> (X.CertificateChain, X.PrivKey) +tlsServerCredentials serverParams = case T.sharedCredentials $ T.serverShared serverParams of + T.Credentials [creds] -> creds + _ -> error "server has more than one key" -- | Run TCP server without TLS runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO () diff --git a/src/Simplex/Messaging/Transport/WebSockets.hs b/src/Simplex/Messaging/Transport/WebSockets.hs index 4a39234b5..062f4f0f0 100644 --- a/src/Simplex/Messaging/Transport/WebSockets.hs +++ b/src/Simplex/Messaging/Transport/WebSockets.hs @@ -8,6 +8,7 @@ import qualified Control.Exception as E import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB +import qualified Data.X509 as X import qualified Network.TLS as T import Network.WebSockets import Network.WebSockets.Stream (Stream) @@ -29,7 +30,8 @@ data WS = WS tlsUniq :: ByteString, wsStream :: Stream, wsConnection :: Connection, - wsTransportConfig :: TransportConfig + wsTransportConfig :: TransportConfig, + wsServerCerts :: X.CertificateChain } websocketsOpts :: ConnectionOptions @@ -50,12 +52,15 @@ instance Transport WS where transportConfig :: WS -> TransportConfig transportConfig = wsTransportConfig - getServerConnection :: TransportConfig -> T.Context -> IO WS + getServerConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS getServerConnection = getWS TServer - getClientConnection :: TransportConfig -> T.Context -> IO WS + getClientConnection :: TransportConfig -> X.CertificateChain -> T.Context -> IO WS getClientConnection = getWS TClient + getServerCerts :: WS -> X.CertificateChain + getServerCerts = wsServerCerts + tlsUnique :: WS -> ByteString tlsUnique = tlsUniq @@ -79,13 +84,13 @@ instance Transport WS where then E.throwIO TEBadBlock else pure $ B.init s -getWS :: TransportPeer -> TransportConfig -> T.Context -> IO WS -getWS wsPeer cfg cxt = withTlsUnique wsPeer cxt connectWS +getWS :: TransportPeer -> TransportConfig -> X.CertificateChain -> T.Context -> IO WS +getWS wsPeer cfg wsServerCerts cxt = withTlsUnique wsPeer cxt connectWS where connectWS tlsUniq = do s <- makeTLSContextStream cxt wsConnection <- connectPeer wsPeer s - pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg} + pure $ WS {wsPeer, tlsUniq, wsStream = s, wsConnection, wsTransportConfig = cfg, wsServerCerts} connectPeer :: TransportPeer -> Stream -> IO Connection connectPeer TServer = acceptClientRequest connectPeer TClient = sendClientRequest diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 94a994104..b3c710bd7 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -15,6 +15,7 @@ module AgentTests.FunctionalAPITests ( functionalAPITests, testServerMatrix2, + withAgentClientsCfg2, getSMPAgentClient', makeConnection, exchangeGreetingsMsgId, @@ -29,6 +30,7 @@ module AgentTests.FunctionalAPITests (##>), (=##>), pattern Msg, + agentCfgV7, ) where @@ -49,21 +51,22 @@ import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Data.Type.Equality import qualified Database.SQLite.Simple as SQL import SMPAgentClient -import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerV7, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..), createAgentStore) import Simplex.Messaging.Agent.Protocol as Agent import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') -import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig) +import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultSMPClientConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Notifications.Transport (authBatchCmdsNTFVersion) import Simplex.Messaging.Protocol (BasicAuth, ErrorType (..), MsgBody, ProtocolServer (..), SubscriptionMode (..), supportedSMPClientVRange) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration -import Simplex.Messaging.Transport (ATransport (..)) +import Simplex.Messaging.Transport (ATransport (..), authCmdsSMPVersion) import Simplex.Messaging.Version import System.Directory (copyFile, renameFile) import Test.Hspec @@ -126,8 +129,14 @@ pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMs smpCfgVPrev :: ProtocolClientConfig smpCfgVPrev = (smpCfg agentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg agentCfg} -smpCfgV1 :: ProtocolClientConfig -smpCfgV1 = (smpCfg agentCfg) {serverVRange = v1Range} +smpCfgV4 :: ProtocolClientConfig +smpCfgV4 = (smpCfg agentCfg) {serverVRange = mkVersionRange 4 4} + +smpCfgV7 :: ProtocolClientConfig +smpCfgV7 = (smpCfg agentCfg) {serverVRange = mkVersionRange 4 authCmdsSMPVersion} + +ntfCfgV2 :: ProtocolClientConfig +ntfCfgV2 = (smpCfg agentCfg) {serverVRange = mkVersionRange 1 authBatchCmdsNTFVersion} agentCfgVPrev :: AgentConfig agentCfgVPrev = @@ -138,13 +147,21 @@ agentCfgVPrev = smpCfg = smpCfgVPrev } +agentCfgV7 :: AgentConfig +agentCfgV7 = + agentCfg + { sndAuthAlg = C.AuthAlg C.SX25519, + smpCfg = smpCfgV7, + ntfCfg = ntfCfgV2 + } + agentCfgV1 :: AgentConfig agentCfgV1 = agentCfg { smpAgentVRange = v1Range, smpClientVRange = v1Range, e2eEncryptVRange = v1Range, - smpCfg = smpCfgV1 + smpCfg = smpCfgV4 } agentCfgRatchetVPrev :: AgentConfig @@ -363,6 +380,10 @@ canCreateQueue allowNew (srvAuth, srvVersion) (clntAuth, clntVersion) = testMatrix2 :: ATransport -> (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 t runTest = do + it "v7" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfgV7 3 runTest + it "v7 to current" $ withSmpServerV7 t $ runTestCfg2 agentCfgV7 agentCfg 3 runTest + it "current to v7" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfgV7 3 runTest + it "current with v7 server" $ withSmpServerV7 t $ runTestCfg2 agentCfg agentCfg 3 runTest it "current" $ withSmpServer t $ runTestCfg2 agentCfg agentCfg 3 runTest it "prev" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfgVPrev 3 runTest it "prev to current" $ withSmpServer t $ runTestCfg2 agentCfgVPrev agentCfg 3 runTest @@ -2019,7 +2040,7 @@ testCreateQueueAuth clnt1 clnt2 = do where getClient clientId (clntAuth, clntVersion) db = let servers = initAgentServers {smp = userServers [ProtoServerWithAuth testSMPServer clntAuth]} - smpCfg = (defaultClientConfig :: ProtocolClientConfig) {serverVRange = mkVersionRange 4 clntVersion} + smpCfg = (defaultSMPClientConfig :: ProtocolClientConfig) {serverVRange = mkVersionRange 4 clntVersion} in getSMPAgentClient' clientId agentCfg {smpCfg} servers db testSMPServerConnectionTest :: ATransport -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Maybe ProtocolTestFailure) diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 15ba1993e..e5d6ad7db 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -6,11 +7,12 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module AgentTests.NotificationTests where -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) -import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, getSMPAgentClient', makeConnection, nGet, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg) +import AgentTests.FunctionalAPITests (agentCfgV7, exchangeGreetingsMsgId, get, getSMPAgentClient', makeConnection, nGet, runRight, runRight_, switchComplete, testServerMatrix2, withAgentClientsCfg2, (##>), (=##>), pattern Msg) import Control.Concurrent (ThreadId, killThread, threadDelay) import Control.Monad import Control.Monad.Except @@ -24,14 +26,15 @@ import Data.ByteString.Char8 (ByteString) import Data.Text.Encoding (encodeUtf8) import NtfClient import SMPAgentClient (agentCfg, initAgentServers, initAgentServers2, testDB, testDB2, testDB3, testNtfServer2) -import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn, xit') +import SMPClient (cfg, cfgV7, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerStoreLogOn) import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Client (withStore') -import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers) +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, Env (..), InitialAgentServers) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.SQLite (getSavedNtfToken) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..)) import Simplex.Messaging.Notifications.Protocol import Simplex.Messaging.Notifications.Server.Push.APNS import Simplex.Messaging.Notifications.Types (NtfToken (..)) @@ -49,72 +52,88 @@ removeFileIfExists filePath = do when fileExists $ removeFile filePath notificationTests :: ATransport -> Spec -notificationTests t = - after_ (removeFileIfExists testDB >> removeFileIfExists testDB2) $ do - describe "Managing notification tokens" $ do - it "should register and verify notification token" $ - withAPNSMockServer $ \apns -> - withNtfServer t $ testNotificationToken apns - it "should allow repeated registration with the same credentials" $ \_ -> - withAPNSMockServer $ \apns -> - withNtfServer t $ testNtfTokenRepeatRegistration apns - it "should allow the second registration with different credentials and delete the first after verification" $ \_ -> - withAPNSMockServer $ \apns -> - withNtfServer t $ testNtfTokenSecondRegistration apns - it "should re-register token when notification server is restarted" $ \_ -> - withAPNSMockServer $ \apns -> - testNtfTokenServerRestart t apns - it "should work with multiple configured servers" $ \_ -> - withAPNSMockServer $ \apns -> - testNtfTokenMultipleServers t apns - it "should keep working with active token until replaced" $ \_ -> - withAPNSMockServer $ \apns -> - testNtfTokenChangeServers t apns - describe "Managing notification subscriptions" $ do - -- fails on Ubuntu CI? - xit' "should create notification subscription for existing connection" $ \_ -> do - withSmpServer t $ - withAPNSMockServer $ \apns -> - withNtfServer t $ testNotificationSubscriptionExistingConnection apns - it "should create notification subscription for new connection" $ \_ -> - withSmpServer t $ - withAPNSMockServer $ \apns -> - withNtfServer t $ testNotificationSubscriptionNewConnection apns - it "should change notifications mode" $ \_ -> - withSmpServer t $ - withAPNSMockServer $ \apns -> - withNtfServer t $ testChangeNotificationsMode apns - it "should change token" $ \_ -> - withSmpServer t $ - withAPNSMockServer $ \apns -> - withNtfServer t $ testChangeToken apns - describe "Notifications server store log" $ - it "should save and restore tokens and subscriptions" $ \_ -> - withSmpServer t $ - withAPNSMockServer $ \apns -> - testNotificationsStoreLog t apns - describe "Notifications after SMP server restart" $ - it "should resume subscriptions after SMP server is restarted" $ \_ -> - withAPNSMockServer $ \apns -> - withNtfServer t $ testNotificationsSMPRestart t apns - describe "Notifications after SMP server restart" $ - it "should resume batched subscriptions after SMP server is restarted" $ \_ -> - withAPNSMockServer $ \apns -> - withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns - describe "should switch notifications to the new queue" $ - testServerMatrix2 t $ \servers -> - withAPNSMockServer $ \apns -> - withNtfServer t $ testSwitchNotifications servers apns - it "should keep sending notifications for old token" $ +notificationTests t = do + describe "Managing notification tokens" $ do + it "should register and verify notification token" $ + withAPNSMockServer $ \apns -> + withNtfServer t $ testNotificationToken apns + it "should allow repeated registration with the same credentials" $ + withAPNSMockServer $ \apns -> + withNtfServer t $ testNtfTokenRepeatRegistration apns + it "should allow the second registration with different credentials and delete the first after verification" $ + withAPNSMockServer $ \apns -> + withNtfServer t $ testNtfTokenSecondRegistration apns + it "should re-register token when notification server is restarted" $ + withAPNSMockServer $ \apns -> + testNtfTokenServerRestart t apns + it "should work with multiple configured servers" $ + withAPNSMockServer $ \apns -> + testNtfTokenMultipleServers t apns + it "should keep working with active token until replaced" $ + withAPNSMockServer $ \apns -> + testNtfTokenChangeServers t apns + describe "Managing notification subscriptions" $ do + describe "should create notification subscription for existing connection" $ + testNtfMatrix t testNotificationSubscriptionExistingConnection + describe "should create notification subscription for new connection" $ + testNtfMatrix t testNotificationSubscriptionNewConnection + it "should change notifications mode" $ withSmpServer t $ withAPNSMockServer $ \apns -> - withNtfServerOn t ntfTestPort $ - testNotificationsOldToken apns - it "should update server from new token" $ + withNtfServer t $ testChangeNotificationsMode apns + it "should change token" $ withSmpServer t $ withAPNSMockServer $ \apns -> - withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf -> - testNotificationsNewToken apns ntf + withNtfServer t $ testChangeToken apns + describe "Notifications server store log" $ + it "should save and restore tokens and subscriptions" $ + withSmpServer t $ + withAPNSMockServer $ \apns -> + testNotificationsStoreLog t apns + describe "Notifications after SMP server restart" $ + it "should resume subscriptions after SMP server is restarted" $ + withAPNSMockServer $ \apns -> + withNtfServer t $ testNotificationsSMPRestart t apns + describe "Notifications after SMP server restart" $ + it "should resume batched subscriptions after SMP server is restarted" $ + withAPNSMockServer $ \apns -> + withNtfServer t $ testNotificationsSMPRestartBatch 100 t apns + describe "should switch notifications to the new queue" $ + testServerMatrix2 t $ \servers -> + withAPNSMockServer $ \apns -> + withNtfServer t $ testSwitchNotifications servers apns + it "should keep sending notifications for old token" $ + withSmpServer t $ + withAPNSMockServer $ \apns -> + withNtfServerOn t ntfTestPort $ + testNotificationsOldToken apns + it "should update server from new token" $ + withSmpServer t $ + withAPNSMockServer $ \apns -> + withNtfServerOn t ntfTestPort2 . withNtfServerThreadOn t ntfTestPort $ \ntf -> + testNotificationsNewToken apns ntf + +testNtfMatrix :: ATransport -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> Spec +testNtfMatrix t runTest = do + describe "next and current" $ do + it "next servers: SMP v7, NTF v2; next clients: v7/v2" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfgV7 runTest + it "next servers: SMP v7, NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfg runTest + it "curr servers: SMP v6, NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfg agentCfg agentCfg runTest + -- this case will cannot be supported - see RFC + xit "servers: SMP v6, NTF v1; clients: v7/v2 (not supported)" $ runNtfTestCfg t cfg ntfServerCfg agentCfgV7 agentCfgV7 runTest + -- servers can be migrated in any order + it "servers: next SMP v7, curr NTF v1; curr clients: v6/v1" $ runNtfTestCfg t cfgV7 ntfServerCfg agentCfg agentCfg runTest + it "servers: curr SMP v6, next NTF v2; curr clients: v6/v1" $ runNtfTestCfg t cfg ntfServerCfgV2 agentCfg agentCfg runTest + -- clients can be partially migrated + it "servers: next SMP v7, curr NTF v2; clients: next/curr" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfgV7 agentCfg runTest + it "servers: next SMP v7, curr NTF v2; clients: curr/new" $ runNtfTestCfg t cfgV7 ntfServerCfgV2 agentCfg agentCfgV7 runTest + +runNtfTestCfg :: ATransport -> ServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentClient -> AgentClient -> IO ()) -> IO () +runNtfTestCfg t smpCfg ntfCfg aCfg bCfg runTest = + withSmpServerConfigOn t smpCfg testPort $ \_ -> + withAPNSMockServer $ \apns -> + withNtfServerCfg ntfCfg {transports = [(ntfTestPort, t)]} $ \_ -> + withAgentClientsCfg2 aCfg bCfg $ runTest apns testNotificationToken :: APNSMockServer -> IO () testNotificationToken APNSMockServer {apnsQ} = do @@ -294,10 +313,8 @@ testNtfTokenChangeServers t APNSMockServer {apnsQ} = tkn <- registerTestToken a "qwer" NMInstant apnsQ checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive -testNotificationSubscriptionExistingConnection :: APNSMockServer -> IO () -testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 +testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () +testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} alice@AgentClient {agentEnv = Env {config = aliceCfg}} bob = do (bobId, aliceId, nonce, message) <- runRight $ do -- establish connection (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -318,7 +335,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do verifyNtfToken alice tkn vNonce verification NTActive <- checkNtfToken alice tkn -- send message - liftIO $ threadDelay 50000 + liftIO $ threadDelay 250000 1 <- msgId <$> sendMessage bob aliceId (SMP.MsgFlags True) "hello" get bob ##> ("", aliceId, SENT $ baseId + 1) -- notification @@ -329,7 +346,7 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do Left (CMD PROHIBITED) <- runExceptT $ getNotificationMessage alice nonce message -- aliceNtf client doesn't have subscription and is allowed to get notification message - aliceNtf <- getSMPAgentClient' 3 agentCfg initAgentServers testDB + aliceNtf <- getSMPAgentClient' 3 aliceCfg initAgentServers testDB runRight_ $ do (_, [SMPMsgMeta {msgFlags = MsgFlags True}]) <- getNotificationMessage aliceNtf nonce message pure () @@ -346,16 +363,12 @@ testNotificationSubscriptionExistingConnection APNSMockServer {apnsQ} = do get bob ##> ("", aliceId, SENT $ baseId + 2) -- no notifications should follow noNotification apnsQ - disconnectAgentClient alice - disconnectAgentClient bob where baseId = 3 msgId = subtract baseId -testNotificationSubscriptionNewConnection :: APNSMockServer -> IO () -testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do - alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB - bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 +testNotificationSubscriptionNewConnection :: APNSMockServer -> AgentClient -> AgentClient -> IO () +testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} alice bob = runRight_ $ do -- alice registers notification token DeviceToken {} <- registerTestToken alice "abcd" NMInstant apnsQ @@ -391,8 +404,6 @@ testNotificationSubscriptionNewConnection APNSMockServer {apnsQ} = do ackMessage bob aliceId (baseId + 2) Nothing -- no unexpected notifications should follow noNotification apnsQ - disconnectAgentClient alice - disconnectAgentClient bob where baseId = 3 msgId = subtract baseId @@ -625,7 +636,7 @@ testNotificationsSMPRestartBatch n t APNSMockServer {apnsQ} = do runServers :: ExceptT AgentErrorType IO a -> IO a runServers a = do withSmpServerStoreLogOn t testPort $ \t1 -> do - res <- withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 -> + res <- withSmpServerConfigOn t (cfg :: ServerConfig) {storeLogFile = Just testStoreLogFile2} testPort2 $ \t2 -> runRight a `finally` killThread t2 killThread t1 pure res diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 9d258bdf7..1421209b8 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -174,8 +174,8 @@ testForeignKeysEnabled = cData1 :: ConnData cData1 = ConnData {userId = 1, connId = "conn1", connAgentVersion = 1, enableNtfs = True, duplexHandshake = Nothing, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk} -testPrivateSignKey :: C.APrivateSignKey -testPrivateSignKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" +testPrivateAuthKey :: C.APrivateAuthKey +testPrivateAuthKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" testPrivDhKey :: C.PrivateKeyX25519 testPrivDhKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk" @@ -193,7 +193,7 @@ rcvQueue1 = connId = "conn1", server = smpServer1, rcvId = "1234", - rcvPrivateKey = testPrivateSignKey, + rcvPrivateKey = testPrivateAuthKey, rcvDhSecret = testDhSecret, e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, @@ -216,7 +216,7 @@ sndQueue1 = server = smpServer1, sndId = "3456", sndPublicKey = Nothing, - sndPrivateKey = testPrivateSignKey, + sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, status = New, @@ -354,7 +354,7 @@ testUpgradeRcvConnToDuplex = server = SMPServer "smp.simplex.im" "5223" testKeyHash, sndId = "2345", sndPublicKey = Nothing, - sndPrivateKey = testPrivateSignKey, + sndPrivateKey = testPrivateAuthKey, e2ePubKey = Nothing, e2eDhSecret = testDhSecret, status = New, @@ -381,7 +381,7 @@ testUpgradeSndConnToDuplex = connId = "conn1", server = SMPServer "smp.simplex.im" "5223" testKeyHash, rcvId = "3456", - rcvPrivateKey = testPrivateSignKey, + rcvPrivateKey = testPrivateAuthKey, rcvDhSecret = testDhSecret, e2ePrivKey = testPrivDhKey, e2eDhSecret = Nothing, @@ -672,8 +672,8 @@ testFileSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD testFileCbNonce :: C.CbNonce testFileCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu" -testFileReplicaKey :: C.APrivateSignKey -testFileReplicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" +testFileReplicaKey :: C.APrivateAuthKey +testFileReplicaKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" testGetNextRcvChunkToDownload :: SQLiteStore -> Expectation testGetNextRcvChunkToDownload st = do diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index bf31f0811..05b440d31 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -1,41 +1,68 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} module CoreTests.BatchingTests (batchingTests) where import Control.Concurrent.STM import Control.Monad -import Data.ByteString.Char8 (ByteString) +import Crypto.Random (ChaChaDRG) import qualified Data.ByteString as B +import Data.ByteString.Char8 (ByteString) import qualified Data.List.NonEmpty as L import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol import Simplex.Messaging.Transport -import Simplex.Messaging.Version (VersionRange (..)) +import Simplex.Messaging.Version (Version) import Test.Hspec batchingTests :: Spec batchingTests = do describe "batchTransmissions" $ do - it "should batch with 90 subscriptions per batch" testBatchSubscriptions - it "should break on message that does not fit" testBatchWithMessage - it "should break on large message" testBatchWithLargeMessage + describe "SMP v6 (current)" $ do + it "should batch with 107 subscriptions per batch" testBatchSubscriptions + it "should break on message that does not fit" testBatchWithMessage + it "should break on large message" testBatchWithLargeMessage + describe "v7 (next)" $ do + it "should batch with 136 subscriptions per batch" testBatchSubscriptionsV7 + it "should break on message that does not fit" testBatchWithMessageV7 + it "should break on large message" testBatchWithLargeMessageV7 describe "batchTransmissions'" $ do - it "should batch with 90 subscriptions per batch" testClientBatchSubscriptions - it "should break on message that does not fit" testClientBatchWithMessage - it "should break on large message" testClientBatchWithLargeMessage + describe "SMP v6 (current)" $ do + it "should batch with 107 subscriptions per batch" testClientBatchSubscriptions + it "should break on message that does not fit" testClientBatchWithMessage + it "should break on large message" testClientBatchWithLargeMessage + describe "v7 (next)" $ do + it "should batch with 136 subscriptions per batch" testClientBatchSubscriptionsV7 + it "should break on message that does not fit" testClientBatchWithMessageV7 + it "should break on large message" testClientBatchWithLargeMessageV7 testBatchSubscriptions :: IO () testBatchSubscriptions = do sessId <- atomically . C.randomBytes 32 =<< C.newRandom - subs <- replicateM 200 $ randomSUB sessId + subs <- replicateM 250 $ randomSUB sessId let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs all lenOk1 batches1 `shouldBe` True - length batches1 `shouldBe` 200 + length batches1 `shouldBe` 250 let batches = batchTransmissions True smpBlockSize $ L.fromList subs length batches `shouldBe` 3 [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches - (n1, n2, n3) `shouldBe` (20, 90, 90) + (n1, n2, n3) `shouldBe` (36, 107, 107) + all lenOk [s1, s2, s3] `shouldBe` True + +testBatchSubscriptionsV7 :: IO () +testBatchSubscriptionsV7 = do + sessId <- atomically . C.randomBytes 32 =<< C.newRandom + subs <- replicateM 300 $ randomSUBv7 sessId + let batches1 = batchTransmissions False smpBlockSize $ L.fromList subs + all lenOk1 batches1 `shouldBe` True + length batches1 `shouldBe` 300 + let batches = batchTransmissions True smpBlockSize $ L.fromList subs + length batches `shouldBe` 3 + [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches + (n1, n2, n3) `shouldBe` (28, 136, 136) all lenOk [s1, s2, s3] `shouldBe` True testBatchWithMessage :: IO () @@ -51,46 +78,92 @@ testBatchWithMessage = do let batches = batchTransmissions True smpBlockSize $ L.fromList cmds length batches `shouldBe` 2 [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches - (n1, n2) `shouldBe` (55, 46) + (n1, n2) `shouldBe` (47, 54) + all lenOk [s1, s2] `shouldBe` True + +testBatchWithMessageV7 :: IO () +testBatchWithMessageV7 = do + sessId <- atomically . C.randomBytes 32 =<< C.newRandom + subs1 <- replicateM 60 $ randomSUBv7 sessId + send <- randomSENDv7 sessId 8000 + subs2 <- replicateM 40 $ randomSUBv7 sessId + let cmds = subs1 <> [send] <> subs2 + batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds + all lenOk1 batches1 `shouldBe` True + length batches1 `shouldBe` 101 + let batches = batchTransmissions True smpBlockSize $ L.fromList cmds + length batches `shouldBe` 2 + [TBTransmissions s1 n1 _, TBTransmissions s2 n2 _] <- pure batches + (n1, n2) `shouldBe` (32, 69) all lenOk [s1, s2] `shouldBe` True testBatchWithLargeMessage :: IO () testBatchWithLargeMessage = do sessId <- atomically . C.randomBytes 32 =<< C.newRandom - subs1 <- replicateM 60 $ randomSUB sessId + subs1 <- replicateM 50 $ randomSUB sessId send <- randomSEND sessId 17000 - subs2 <- replicateM 100 $ randomSUB sessId + subs2 <- replicateM 150 $ randomSUB sessId let cmds = subs1 <> [send] <> subs2 batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds all lenOk1 batches1 `shouldBe` False - length batches1 `shouldBe` 161 - let batches1' = take 60 batches1 <> drop 61 batches1 + length batches1 `shouldBe` 201 + let batches1' = take 50 batches1 <> drop 51 batches1 all lenOk1 batches1' `shouldBe` True - length batches1' `shouldBe` 160 + length batches1' `shouldBe` 200 let batches = batchTransmissions True smpBlockSize $ L.fromList cmds length batches `shouldBe` 4 - [TBTransmissions s1 n1 _, TBLargeTransmission _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches - (n1, n2, n3) `shouldBe` (60, 10, 90) + [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches + (n1, n2, n3) `shouldBe` (50, 43, 107) + all lenOk [s1, s2, s3] `shouldBe` True + +testBatchWithLargeMessageV7 :: IO () +testBatchWithLargeMessageV7 = do + sessId <- atomically . C.randomBytes 32 =<< C.newRandom + subs1 <- replicateM 60 $ randomSUBv7 sessId + send <- randomSENDv7 sessId 17000 + subs2 <- replicateM 150 $ randomSUBv7 sessId + let cmds = subs1 <> [send] <> subs2 + batches1 = batchTransmissions False smpBlockSize $ L.fromList cmds + all lenOk1 batches1 `shouldBe` False + length batches1 `shouldBe` 211 + let batches1' = take 60 batches1 <> drop 61 batches1 + all lenOk1 batches1' `shouldBe` True + length batches1' `shouldBe` 210 + let batches = batchTransmissions True smpBlockSize $ L.fromList cmds + length batches `shouldBe` 4 + [TBTransmissions s1 n1 _, TBError TELargeMsg _, TBTransmissions s2 n2 _, TBTransmissions s3 n3 _] <- pure batches + (n1, n2, n3) `shouldBe` (60, 14, 136) all lenOk [s1, s2, s3] `shouldBe` True testClientBatchSubscriptions :: IO () testClientBatchSubscriptions = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom - client <- atomically $ clientStub sessId - subs <- replicateM 200 $ randomSUBCmd client + client <- testClientStub + subs <- replicateM 250 $ randomSUBCmd client let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs all lenOk1 batches1 `shouldBe` True let batches = batchTransmissions' True smpBlockSize $ L.fromList subs length batches `shouldBe` 3 [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches - (n1, n2, n3) `shouldBe` (20, 90, 90) - (length rs1, length rs2, length rs3) `shouldBe` (20, 90, 90) + (n1, n2, n3) `shouldBe` (36, 107, 107) + (length rs1, length rs2, length rs3) `shouldBe` (36, 107, 107) + all lenOk [s1, s2, s3] `shouldBe` True + +testClientBatchSubscriptionsV7 :: IO () +testClientBatchSubscriptionsV7 = do + client <- clientStubV7 + subs <- replicateM 300 $ randomSUBCmdV7 client + let batches1 = batchTransmissions' False smpBlockSize $ L.fromList subs + all lenOk1 batches1 `shouldBe` True + let batches = batchTransmissions' True smpBlockSize $ L.fromList subs + length batches `shouldBe` 3 + [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches + (n1, n2, n3) `shouldBe` (28, 136, 136) + (length rs1, length rs2, length rs3) `shouldBe` (28, 136, 136) all lenOk [s1, s2, s3] `shouldBe` True testClientBatchWithMessage :: IO () testClientBatchWithMessage = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom - client <- atomically $ clientStub sessId + client <- testClientStub subs1 <- replicateM 60 $ randomSUBCmd client send <- randomSENDCmd client 8000 subs2 <- replicateM 40 $ randomSUBCmd client @@ -101,71 +174,176 @@ testClientBatchWithMessage = do let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds length batches `shouldBe` 2 [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches - (n1, n2) `shouldBe` (55, 46) - (length rs1, length rs2) `shouldBe` (55, 46) + (n1, n2) `shouldBe` (47, 54) + (length rs1, length rs2) `shouldBe` (47, 54) + all lenOk [s1, s2] `shouldBe` True + +testClientBatchWithMessageV7 :: IO () +testClientBatchWithMessageV7 = do + client <- clientStubV7 + subs1 <- replicateM 60 $ randomSUBCmdV7 client + send <- randomSENDCmdV7 client 8000 + subs2 <- replicateM 40 $ randomSUBCmdV7 client + let cmds = subs1 <> [send] <> subs2 + batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds + all lenOk1 batches1 `shouldBe` True + length batches1 `shouldBe` 101 + let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds + length batches `shouldBe` 2 + [TBTransmissions s1 n1 rs1, TBTransmissions s2 n2 rs2] <- pure batches + (n1, n2) `shouldBe` (32, 69) + (length rs1, length rs2) `shouldBe` (32, 69) all lenOk [s1, s2] `shouldBe` True testClientBatchWithLargeMessage :: IO () testClientBatchWithLargeMessage = do - sessId <- atomically . C.randomBytes 32 =<< C.newRandom - client <- atomically $ clientStub sessId - subs1 <- replicateM 60 $ randomSUBCmd client + client <- testClientStub + subs1 <- replicateM 50 $ randomSUBCmd client send <- randomSENDCmd client 17000 - subs2 <- replicateM 100 $ randomSUBCmd client + subs2 <- replicateM 150 $ randomSUBCmd client let cmds = subs1 <> [send] <> subs2 batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds all lenOk1 batches1 `shouldBe` False - length batches1 `shouldBe` 161 - let batches1' = take 60 batches1 <> drop 61 batches1 + length batches1 `shouldBe` 201 + let batches1' = take 50 batches1 <> drop 51 batches1 all lenOk1 batches1' `shouldBe` True - length batches1' `shouldBe` 160 + length batches1' `shouldBe` 200 -- let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds length batches `shouldBe` 4 - [TBTransmissions s1 n1 rs1, TBLargeTransmission _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches - (n1, n2, n3) `shouldBe` (60, 10, 90) - (length rs1, length rs2, length rs3) `shouldBe` (60, 10, 90) + [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches + (n1, n2, n3) `shouldBe` (50, 43, 107) + (length rs1, length rs2, length rs3) `shouldBe` (50, 43, 107) all lenOk [s1, s2, s3] `shouldBe` True -- let cmds' = [send] <> subs1 <> subs2 let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds' length batches' `shouldBe` 3 - [TBLargeTransmission _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches' - (n1', n2') `shouldBe` (70, 90) - (length rs1', length rs2') `shouldBe` (70, 90) + [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches' + (n1', n2') `shouldBe` (93, 107) + (length rs1', length rs2') `shouldBe` (93, 107) all lenOk [s1', s2'] `shouldBe` True -randomSUB :: ByteString -> IO (Maybe C.ASignature, ByteString) -randomSUB sessId = do +testClientBatchWithLargeMessageV7 :: IO () +testClientBatchWithLargeMessageV7 = do + client <- clientStubV7 + subs1 <- replicateM 60 $ randomSUBCmdV7 client + send <- randomSENDCmdV7 client 17000 + subs2 <- replicateM 150 $ randomSUBCmdV7 client + let cmds = subs1 <> [send] <> subs2 + batches1 = batchTransmissions' False smpBlockSize $ L.fromList cmds + all lenOk1 batches1 `shouldBe` False + length batches1 `shouldBe` 211 + let batches1' = take 60 batches1 <> drop 61 batches1 + all lenOk1 batches1' `shouldBe` True + length batches1' `shouldBe` 210 + -- + let batches = batchTransmissions' True smpBlockSize $ L.fromList cmds + length batches `shouldBe` 4 + [TBTransmissions s1 n1 rs1, TBError TELargeMsg _, TBTransmissions s2 n2 rs2, TBTransmissions s3 n3 rs3] <- pure batches + (n1, n2, n3) `shouldBe` (60, 14, 136) + (length rs1, length rs2, length rs3) `shouldBe` (60, 14, 136) + all lenOk [s1, s2, s3] `shouldBe` True + -- + let cmds' = [send] <> subs1 <> subs2 + let batches' = batchTransmissions' True smpBlockSize $ L.fromList cmds' + length batches' `shouldBe` 3 + [TBError TELargeMsg _, TBTransmissions s1' n1' rs1', TBTransmissions s2' n2' rs2'] <- pure batches' + (n1', n2') `shouldBe` (74, 136) + (length rs1', length rs2') `shouldBe` (74, 136) + all lenOk [s1', s2'] `shouldBe` True + +testClientStub :: IO (ProtocolClient ErrorType BrokerMsg) +testClientStub = do + g <- C.newRandom + sessId <- atomically $ C.randomBytes 32 g + atomically $ clientStub g sessId currentClientSMPRelayVersion Nothing + +clientStubV7 :: IO (ProtocolClient ErrorType BrokerMsg) +clientStubV7 = do + g <- C.newRandom + sessId <- atomically $ C.randomBytes 32 g + (rKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g + thAuth_ <- testTHandleAuth authCmdsSMPVersion g rKey + atomically $ clientStub g sessId authCmdsSMPVersion thAuth_ + +randomSUB :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) +randomSUB = randomSUB_ C.SEd25519 currentClientSMPRelayVersion + +randomSUBv7 :: ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) +randomSUBv7 = randomSUB_ C.SEd25519 authCmdsSMPVersion + +randomSUB_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> Version -> ByteString -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) +randomSUB_ a v sessId = do g <- C.newRandom rId <- atomically $ C.randomBytes 24 g - corrId <- atomically $ CorrId <$> C.randomBytes 3 g - (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g - let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, rId, Cmd SRecipient SUB) - pure (Just $ C.sign rpKey s, s) + corrId <- atomically $ CorrId <$> C.randomBytes 24 g + (rKey, rpKey) <- atomically $ C.generateAuthKeyPair a g + thAuth_ <- testTHandleAuth v g rKey + let thParams = testTHandleParams v sessId + TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, rId, Cmd SRecipient SUB) + pure $ (,tToSend) <$> authTransmission thAuth_ (Just rpKey) corrId tForAuth randomSUBCmd :: ProtocolClient ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) -randomSUBCmd c = do +randomSUBCmd = randomSUBCmd_ C.SEd25519 + +randomSUBCmdV7 :: ProtocolClient ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) +randomSUBCmdV7 = randomSUBCmd_ C.SEd25519 -- same as v6 + +randomSUBCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) +randomSUBCmd_ a c = do g <- C.newRandom rId <- atomically $ C.randomBytes 24 g - (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (_, rpKey) <- atomically $ C.generateAuthKeyPair a g mkTransmission c (Just rpKey, rId, Cmd SRecipient SUB) -randomSEND :: ByteString -> Int -> IO (Maybe C.ASignature, ByteString) -randomSEND sessId len = do +randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) +randomSEND = randomSEND_ C.SEd25519 currentClientSMPRelayVersion + +randomSENDv7 :: ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) +randomSENDv7 = randomSEND_ C.SX25519 authCmdsSMPVersion + +randomSEND_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> Version -> ByteString -> Int -> IO (Either TransportError (Maybe TransmissionAuth, ByteString)) +randomSEND_ a v sessId len = do g <- C.newRandom sId <- atomically $ C.randomBytes 24 g corrId <- atomically $ CorrId <$> C.randomBytes 3 g - (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (sKey, spKey) <- atomically $ C.generateAuthKeyPair a g + thAuth_ <- testTHandleAuth v g sKey msg <- atomically $ C.randomBytes len g - let s = encodeTransmission (maxVersion supportedSMPServerVRange) sessId (corrId, sId, Cmd SSender $ SEND noMsgFlags msg) - pure (Just $ C.sign rpKey s, s) + let thParams = testTHandleParams v sessId + TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (corrId, sId, Cmd SSender $ SEND noMsgFlags msg) + pure $ (,tToSend) <$> authTransmission thAuth_ (Just spKey) corrId tForAuth + +testTHandleParams :: Version -> ByteString -> THandleParams +testTHandleParams v sessionId = + THandleParams + { sessionId, + blockSize = smpBlockSize, + thVersion = v, + thAuth = Nothing, + implySessId = v >= authCmdsSMPVersion, + batch = True + } + +testTHandleAuth :: Version -> TVar ChaChaDRG -> C.APublicAuthKey -> IO (Maybe THandleAuth) +testTHandleAuth v g (C.APublicAuthKey a k) = case a of + C.SX25519 | v >= authCmdsSMPVersion -> do + (_, privKey) <- atomically $ C.generateKeyPair g + pure $ Just THandleAuth {peerPubKey = k, privKey} + _ -> pure Nothing randomSENDCmd :: ProtocolClient ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) -randomSENDCmd c len = do +randomSENDCmd = randomSENDCmd_ C.SEd25519 + +randomSENDCmdV7 :: ProtocolClient ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) +randomSENDCmdV7 = randomSENDCmd_ C.SX25519 + +randomSENDCmd_ :: (C.AlgorithmI a, C.AuthAlgorithm a) => C.SAlgorithm a -> ProtocolClient ErrorType BrokerMsg -> Int -> IO (PCTransmission ErrorType BrokerMsg) +randomSENDCmd_ a c len = do g <- C.newRandom sId <- atomically $ C.randomBytes 24 g - (_, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (_, rpKey) <- atomically $ C.generateAuthKeyPair a g msg <- atomically $ C.randomBytes len g mkTransmission c (Just rpKey, sId, Cmd SSender $ SEND noMsgFlags msg) diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs index 61dd638fe..65b818979 100644 --- a/tests/FileDescriptionTests.hs +++ b/tests/FileDescriptionTests.hs @@ -92,7 +92,7 @@ fileDesc = where defaultChunkSize = FileSize $ mb 8 replicaId = ChunkReplicaId "abc" - replicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" + replicaKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" chunkDigest = FileDigest "ghi" yamlFileDesc :: YAMLFileDescription diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index 02ce7b997..08e0c7876 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -30,8 +30,8 @@ import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Server as H import Network.Socket import SMPClient (serverBracket) -import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig) -import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig) +import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig) +import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Notifications.Server (runNtfServerBlocking) @@ -45,6 +45,7 @@ import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), http2TLSParams) import Simplex.Messaging.Transport.HTTP2.Server import Simplex.Messaging.Transport.Server +import Simplex.Messaging.Version (mkVersionRange) import Test.Hspec import UnliftIO.Async import UnliftIO.Concurrent @@ -72,8 +73,10 @@ ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log" testNtfClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a testNtfClient client = do Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> - liftIO (runExceptT $ ntfClientHandshake h testKeyHash supportedNTFServerVRange) >>= \case + runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> do + g <- liftIO C.newRandom + ks <- atomically $ C.generateKeyPair g + liftIO (runExceptT $ ntfClientHandshake h ks testKeyHash supportedClientNTFVRange) >>= \case Right th -> client th Left e -> error $ show e @@ -104,9 +107,17 @@ ntfServerCfg = logStatsStartTime = 0, serverStatsLogFile = "tests/ntf-server-stats.daily.log", serverStatsBackupFile = Nothing, + ntfServerVRange = supportedServerNTFVRange, transportConfig = defaultTransportServerConfig } +ntfServerCfgV2 :: NtfServerConfig +ntfServerCfgV2 = + ntfServerCfg + { ntfServerVRange = mkVersionRange 1 authBatchCmdsNTFVersion, + smpAgentCfg = defaultSMPClientAgentConfig {smpCfg = (smpCfg defaultSMPClientAgentConfig) {serverVRange = mkVersionRange 4 authCmdsSMPVersion}} + } + withNtfServerStoreLog :: ATransport -> (ThreadId -> IO a) -> IO a withNtfServerStoreLog t = withNtfServerCfg ntfServerCfg {storeLogFile = Just ntfTestStoreLogFile, transports = [(ntfTestPort, t)]} @@ -135,14 +146,14 @@ ntfServerTest :: forall c smp. (Transport c, Encoding smp) => TProxy c -> - (Maybe C.ASignature, ByteString, ByteString, smp) -> - IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) + (Maybe TransmissionAuth, ByteString, ByteString, smp) -> + IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h where - tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO () - tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do + tPut' :: THandle c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO () + tPut' h@THandle {params = THandleParams {sessionId}} (sig, corrId, queueId, smp) = do let t' = smpEncode (sessionId, corrId, queueId, smp) - [Right ()] <- tPut h [(sig, t')] + [Right ()] <- tPut h [Right (sig, t')] pure () tGet' h = do [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index b46ea311d..e29a292ee 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -59,25 +59,30 @@ ntfSyntaxTests (ATransport t) = do where (>#>) :: Encoding smp => - (Maybe C.ASignature, ByteString, ByteString, smp) -> - (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) -> + (Maybe TransmissionAuth, ByteString, ByteString, smp) -> + (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) -> Expectation command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> SignedTransmission ErrorType NtfResponse pattern RespNtf corrId queueId command <- (_, _, (corrId, queueId, Right command)) -sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) -sendRecvNtf h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do - let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) - Right () <- tPut1 h (sgn, t) +sendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> (Maybe TransmissionAuth, ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) +sendRecvNtf h@THandle {params} (sgn, corrId, qId, cmd) = do + let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) + Right () <- tPut1 h (sgn, tToSend) tGet1 h -signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) -signSendRecvNtf h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do - let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) - Right () <- tPut1 h (Just $ C.sign pk t, t) +signSendRecvNtf :: forall c e. (Transport c, NtfEntityI e) => THandle c -> C.APrivateAuthKey -> (ByteString, ByteString, NtfCommand e) -> IO (SignedTransmission ErrorType NtfResponse) +signSendRecvNtf h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) + Right () <- tPut1 h (authorize tForAuth, tToSend) tGet1 h + where + authorize t = case a of + C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t + C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t + _ -> Nothing (.->) :: J.Value -> J.Key -> Either String ByteString v .-> key = @@ -89,9 +94,9 @@ testNotificationSubscription (ATransport t) = -- hangs on Ubuntu 20/22 xit' "should create notification subscription and notify when message is received" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (tknPub, tknKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g let tkn = DeviceToken PPApnsTest "abcd" withAPNSMockServer $ \APNSMockServer {apnsQ} -> diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 1a70f6588..c85499c12 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -35,7 +35,8 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Server (runSMPAgentBlocking) import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore (dbNew)) import Simplex.Messaging.Agent.Store.SQLite.Common (withTransaction') -import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig) +import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultSMPClientConfig, defaultNetworkConfig) +import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth) import Simplex.Messaging.Transport @@ -204,8 +205,8 @@ agentCfg = { tcpPort = agentTestPort, tbqSize = 4, -- database = testDB, - smpCfg = defaultClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS), networkConfig}, - ntfCfg = defaultClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS), networkConfig}, + smpCfg = defaultSMPClientConfig {qSize = 1, defaultTransport = (testPort, transport @TLS), networkConfig}, + ntfCfg = defaultNTFClientConfig {qSize = 1, defaultTransport = (ntfTestPort, transport @TLS), networkConfig}, reconnectInterval = fastRetryInterval, xftpNotifyErrsOnRetry = False, ntfWorkerDelay = 100, diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 5bff0405c..e2dccf9fa 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -26,7 +26,7 @@ import Simplex.Messaging.Server.Env.STM import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import Simplex.Messaging.Transport.Server -import Simplex.Messaging.Version +import Simplex.Messaging.Version (VersionRange, mkVersionRange) import System.Environment (lookupEnv) import System.Info (os) import Test.Hspec @@ -68,16 +68,18 @@ xit'' d t = do (if ci == Just "true" then xit else it) d t testSMPClient :: (Transport c, MonadUnliftIO m, MonadFail m) => (THandle c -> m a) -> m a -testSMPClient client = do +testSMPClient = testSMPClientVR supportedClientSMPRelayVRange + +testSMPClientVR :: (Transport c, MonadUnliftIO m, MonadFail m) => VersionRange -> (THandle c -> m a) -> m a +testSMPClientVR vr client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost - runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> - liftIO (runExceptT $ smpClientHandshake h testKeyHash supportedSMPServerVRange) >>= \case + runTransportClient defaultTransportClientConfig Nothing useHost testPort (Just testKeyHash) $ \h -> do + g <- liftIO C.newRandom + ks <- atomically $ C.generateKeyPair g + liftIO (runExceptT $ smpClientHandshake h ks testKeyHash vr) >>= \case Right th -> client th Left e -> error $ show e -cfgV2 :: ServerConfig -cfgV2 = cfg {smpServerVRange = mkVersionRange 1 2} - cfg :: ServerConfig cfg = ServerConfig @@ -101,13 +103,13 @@ cfg = caCertificateFile = "tests/fixtures/ca.crt", privateKeyFile = "tests/fixtures/server.key", certificateFile = "tests/fixtures/server.crt", - smpServerVRange = supportedSMPServerVRange, + smpServerVRange = supportedServerSMPRelayVRange, transportConfig = defaultTransportServerConfig, controlPort = Nothing } -withSmpServerStoreMsgLogOnV2 :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a -withSmpServerStoreMsgLogOnV2 t = withSmpServerConfigOn t cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile} +cfgV7 :: ServerConfig +cfgV7 = cfg {smpServerVRange = mkVersionRange 4 authCmdsSMPVersion} withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile} @@ -143,28 +145,34 @@ withSmpServerOn t port' = withSmpServerThreadOn t port' . const withSmpServer :: HasCallStack => ATransport -> IO a -> IO a withSmpServer t = withSmpServerOn t testPort +withSmpServerV7 :: HasCallStack => ATransport -> IO a -> IO a +withSmpServerV7 t = withSmpServerConfigOn t cfgV7 testPort . const + runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandle c -> IO a) -> IO a runSmpTest test = withSmpServer (transport @c) $ testSMPClient test runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] -> IO a) -> IO a -runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients [] +runSmpTestN = runSmpTestNCfg cfg supportedClientSMPRelayVRange + +runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => ServerConfig -> VersionRange -> Int -> (HasCallStack => [THandle c] -> IO a) -> IO a +runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients [] where run :: Int -> [THandle c] -> IO a run 0 hs = test hs - run n hs = testSMPClient $ \h -> run (n - 1) (h : hs) + run n hs = testSMPClientVR clntVR $ \h -> run (n - 1) (h : hs) smpServerTest :: forall c smp. (Transport c, Encoding smp) => TProxy c -> - (Maybe C.ASignature, ByteString, ByteString, smp) -> - IO (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) + (Maybe TransmissionAuth, ByteString, ByteString, smp) -> + IO (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h where - tPut' :: THandle c -> (Maybe C.ASignature, ByteString, ByteString, smp) -> IO () - tPut' h@THandle {sessionId} (sig, corrId, queueId, smp) = do - let t' = smpEncode (sessionId, corrId, queueId, smp) - [Right ()] <- tPut h [(sig, t')] + tPut' :: THandle c -> (Maybe TransmissionAuth, ByteString, ByteString, smp) -> IO () + tPut' h@THandle {params = THandleParams {sessionId}} (sig, corrId, queueId, smp) = do + let t' = smpEncode (sessionId,corrId, queueId, smp) + [Right ()] <- tPut h [Right (sig, t')] pure () tGet' h = do [(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h @@ -177,7 +185,10 @@ smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] - smpTestN n test' = runSmpTestN n test' `shouldReturn` () smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> IO ()) -> Expectation -smpTest2 _ test' = smpTestN 2 _test +smpTest2 = smpTest2Cfg cfg supportedClientSMPRelayVRange + +smpTest2Cfg :: forall c. (HasCallStack, Transport c) => ServerConfig -> VersionRange -> TProxy c -> (HasCallStack => THandle c -> THandle c -> IO ()) -> Expectation +smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` () where _test :: HasCallStack => [THandle c] -> IO () _test [h1, h2] = test' h1 h2 diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 4bd468f16..dc010c893 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} @@ -33,6 +34,7 @@ import Simplex.Messaging.Server.Env.STM (ServerConfig (..)) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Stats (PeriodStatsData (..), ServerStatsData (..)) import Simplex.Messaging.Transport +import Simplex.Messaging.Version (mkVersionRange) import System.Directory (removeFile) import System.TimeIt (timeItT) import System.Timeout @@ -43,8 +45,7 @@ serverTests :: ATransport -> Spec serverTests t@(ATransport t') = do describe "SMP syntax" $ syntaxTests t describe "SMP queues" $ do - describe "NEW and KEY commands, SEND messages (v2)" $ testCreateSecureV2 t' - describe "NEW and KEY commands, SEND messages (v3)" $ testCreateSecure t + describe "NEW and KEY commands, SEND messages" $ testCreateSecure t describe "NEW, OFF and DEL commands, SEND messages" $ testCreateDelete t describe "Stress test" $ stressTest t describe "allowNewQueues setting" $ testAllowNewQueues t' @@ -56,9 +57,7 @@ serverTests t@(ATransport t') = do describe "Exceeding queue quota" $ testExceedQueueQuota t' describe "Store log" $ testWithStoreLog t describe "Restore messages" $ testRestoreMessages t - describe "Restore messages (old / v2)" $ do - testRestoreMessagesV2 t - testRestoreExpireMessages t + describe "Restore messages (old / v2)" $ testRestoreExpireMessages t describe "Timing of AUTH error" $ testTiming t describe "Message notifications" $ testMessageNotifications t describe "Message expiration" $ do @@ -75,21 +74,29 @@ pattern Ids rId sId srvDh <- IDS (QIK rId sId srvDh) pattern Msg :: MsgId -> MsgBody -> BrokerMsg pattern Msg msgId body <- MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} -sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe C.ASignature, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) -sendRecv h@THandle {thVersion, sessionId} (sgn, corrId, qId, cmd) = do - let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) - Right () <- tPut1 h (sgn, t) +sendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> (Maybe TransmissionAuth, ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) +sendRecv h@THandle {params} (sgn, corrId, qId, cmd) = do + let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) + Right () <- tPut1 h (sgn, tToSend) tGet1 h -signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) -signSendRecv h@THandle {thVersion, sessionId} pk (corrId, qId, cmd) = do - let t = encodeTransmission thVersion sessionId (CorrId corrId, qId, cmd) - Right () <- tPut1 h (Just $ C.sign pk t, t) +signSendRecv :: forall c p. (Transport c, PartyI p) => THandle c -> C.APrivateAuthKey -> (ByteString, ByteString, Command p) -> IO (SignedTransmission ErrorType BrokerMsg) +signSendRecv h@THandle {params} (C.APrivateAuthKey a pk) (corrId, qId, cmd) = do + let TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth params (CorrId corrId, qId, cmd) + Right () <- tPut1 h (authorize tForAuth, tToSend) tGet1 h + where + authorize t = case a of + C.SEd25519 -> Just . TASignature . C.ASignature C.SEd25519 $ C.sign' pk t + C.SEd448 -> Just . TASignature . C.ASignature C.SEd448 $ C.sign' pk t + C.SX25519 -> (\THandleAuth {peerPubKey} -> TAAuthenticator $ C.cbAuthenticate peerPubKey pk (C.cbNonce corrId) t) <$> thAuth params +#if !MIN_VERSION_base(4,18,0) + _sx448 -> undefined -- ghc8107 fails to the branch excluded by types +#endif tPut1 :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ()) tPut1 h t = do - [r] <- tPut h [t] + [r] <- tPut h [Right t] pure r tGet1 :: (ProtocolEncoding err cmd, Transport c, MonadIO m, MonadFail m) => THandle c -> m (SignedTransmission err cmd) @@ -116,77 +123,12 @@ decryptMsgV3 dhShared nonce body = Right ClientRcvMsgQuota {} -> Left "ClientRcvMsgQuota" Left e -> Left e -testCreateSecureV2 :: forall c. Transport c => TProxy c -> Spec -testCreateSecureV2 _ = - it "should create (NEW) and secure (KEY) queue" $ - withSmpServerConfigOn (transport @c) cfgV2 testPort $ \_ -> testSMPClient @c $ \h -> do - g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g - (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g - Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) - let dec = decryptMsgV2 $ C.dh' srvDh dhPriv - (rId1, "") #== "creates queue" - - Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, _SEND "hello") - (ok1, OK) #== "accepts unsigned SEND" - (sId1, sId) #== "same queue ID in response 1" - - Resp "" _ (Msg mId1 msg1) <- tGet1 h - (dec mId1 msg1, Right "hello") #== "delivers message" - - Resp "cdab" _ ok4 <- signSendRecv h rKey ("cdab", rId, ACK mId1) - (ok4, OK) #== "replies OK when message acknowledged if no more messages" - - Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, ACK mId1) - (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" - - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g - Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, _SEND "hello") - (err1, ERR AUTH) #== "rejects signed SEND" - (sId2, sId) #== "same queue ID in response 2" - - Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, KEY sPub) - (err2, ERR AUTH) #== "rejects KEY with wrong signature" - - Resp "cdab" _ err3 <- signSendRecv h rKey ("cdab", sId, KEY sPub) - (err3, ERR AUTH) #== "rejects KEY with sender's ID" - - Resp "dabc" rId2 ok2 <- signSendRecv h rKey ("dabc", rId, KEY sPub) - (ok2, OK) #== "secures queue" - (rId2, rId) #== "same queue ID in response 3" - - Resp "abcd" _ OK <- signSendRecv h rKey ("abcd", rId, KEY sPub) - (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g - Resp "abcd" _ err4 <- signSendRecv h rKey ("abcd", rId, KEY sPub') - (err4, ERR AUTH) #== "rejects if secured with different key" - - Resp "bcda" _ ok3 <- signSendRecv h sKey ("bcda", sId, _SEND "hello again") - (ok3, OK) #== "accepts signed SEND" - - Resp "" _ (Msg mId2 msg2) <- tGet1 h - (dec mId2 msg2, Right "hello again") #== "delivers message 2" - - Resp "cdab" _ ok5 <- signSendRecv h rKey ("cdab", rId, ACK mId2) - (ok5, OK) #== "replies OK when message acknowledged 2" - - Resp "dabc" _ err5 <- sendRecv h ("", "dabc", sId, _SEND "hello") - (err5, ERR AUTH) #== "rejects unsigned SEND" - - let maxAllowedMessage = B.replicate maxMessageLength '-' - Resp "bcda" _ OK <- signSendRecv h sKey ("bcda", sId, _SEND maxAllowedMessage) - Resp "" _ (Msg mId3 msg3) <- tGet1 h - (dec mId3 msg3, Right maxAllowedMessage) #== "delivers message of max size" - - let biggerMessage = B.replicate (maxMessageLength + 1) '-' - Resp "bcda" _ (ERR LARGE_MSG) <- signSendRecv h sKey ("bcda", sId, _SEND biggerMessage) - pure () - testCreateSecure :: ATransport -> Spec testCreateSecure (ATransport t) = it "should create (NEW) and secure (KEY) queue" $ smpTest2 t $ \r s -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv r rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv @@ -205,7 +147,7 @@ testCreateSecure (ATransport t) = Resp "dabc" _ err6 <- signSendRecv r rKey ("dabc", rId, ACK mId1) (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "abcd" sId2 err1 <- signSendRecv s sKey ("abcd", sId, _SEND "hello") (err1, ERR AUTH) #== "rejects signed SEND" (sId2, sId) #== "same queue ID in response 2" @@ -221,7 +163,7 @@ testCreateSecure (ATransport t) = (rId2, rId) #== "same queue ID in response 3" Resp "abcd" _ OK <- signSendRecv r rKey ("abcd", rId, KEY sPub) - (sPub', _) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (sPub', _) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "abcd" _ err4 <- signSendRecv r rKey ("abcd", rId, KEY sPub') (err4, ERR AUTH) #== "rejects if secured with different key" @@ -251,13 +193,13 @@ testCreateDelete (ATransport t) = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ smpTest2 t $ \rh sh -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" rId1 (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv (rId1, "") #== "creates queue" - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, KEY sPub) (ok1, OK) #== "secures queue" @@ -322,7 +264,7 @@ stressTest (ATransport t) = it "should create many queues, disconnect and re-connect" $ smpTest3 t $ \h1 h2 h3 -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g rIds <- forM ([1 .. 50] :: [Int]) . const $ do Resp "" "" (Ids rId _ _) <- signSendRecv h1 rKey ("", "", NEW rPub dhPub Nothing SMSubscribe) @@ -341,7 +283,7 @@ testAllowNewQueues t = withSmpServerConfigOn (ATransport t) cfg {allowNewQueues = False} testPort $ \_ -> testSMPClient @c $ \h -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" "" (ERR AUTH) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) pure () @@ -351,13 +293,13 @@ testDuplex (ATransport t) = it "should create 2 simplex connections and exchange messages" $ smpTest2 t $ \alice bob -> do g <- C.newRandom - (arPub, arKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (arPub, arKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (aDhPub, aDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" _ (Ids aRcv aSnd aSrvDh) <- signSendRecv alice arKey ("abcd", "", NEW arPub aDhPub Nothing SMSubscribe) let aDec = decryptMsgV3 $ C.dh' aSrvDh aDhPriv -- aSnd ID is passed to Bob out-of-band - (bsPub, bsKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (bsPub, bsKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, _SEND $ "key " <> strEncode bsPub) -- "key ..." is ad-hoc, not a part of SMP protocol @@ -367,7 +309,7 @@ testDuplex (ATransport t) = (bobKey, strEncode bsPub) #== "key received from Bob" Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, KEY bsPub) - (brPub, brKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (brPub, brKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", "", NEW brPub bDhPub Nothing SMSubscribe) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv @@ -379,7 +321,7 @@ testDuplex (ATransport t) = Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2 (bId, encode bSnd) #== "reply queue ID received from Bob" - (asPub, asKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (asPub, asKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub) -- "key ..." is ad-hoc, not a part of SMP protocol @@ -406,7 +348,7 @@ testSwitchSub (ATransport t) = it "should create simplex connections and switch subscription to another TCP connection" $ smpTest3 t $ \rh1 rh2 sh -> do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" _ (Ids rId sId srvDh) <- signSendRecv rh1 rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv @@ -446,7 +388,7 @@ testGetCommand :: forall c. Transport c => TProxy c -> Spec testGetCommand t = it "should retrieve messages from the queue using GET command" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g smpTest t $ \sh -> do queue <- newEmptyTMVarIO testSMPClient @c $ \rh -> @@ -465,7 +407,7 @@ testGetSubCommands :: forall c. Transport c => TProxy c -> Spec testGetSubCommands t = it "should retrieve messages with GET and receive with SUB, only one ACK would work" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g smpTest3 t $ \rh1 rh2 sh -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh1 sPub let dec = decryptMsgV3 dhShared @@ -517,7 +459,7 @@ testExceedQueueQuota t = withSmpServerConfigOn (ATransport t) cfg {msgQueueQuota = 2} testPort $ \_ -> testSMPClient @c $ \sh -> testSMPClient @c $ \rh -> do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub let dec = decryptMsgV3 dhShared Resp "1" _ OK <- signSendRecv sh sKey ("1", sId, _SEND "hello 1") @@ -542,9 +484,9 @@ testWithStoreLog :: ATransport -> Spec testWithStoreLog at@(ATransport t) = it "should store simplex queues to log and restore them after server restart" $ do g <- C.newRandom - (sPub1, sKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (sPub2, sKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub1, sKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (sPub2, sKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId1 <- newTVarIO "" recipientKey1 <- newTVarIO Nothing dhShared1 <- newTVarIO Nothing @@ -631,7 +573,7 @@ testRestoreMessages at@(ATransport t) = removeFileIfExists testServerStatsBackupFile g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing @@ -729,87 +671,17 @@ checkStats s qs sent received = do S.toList _week `shouldBe` qs S.toList _month `shouldBe` qs -testRestoreMessagesV2 :: ATransport -> Spec -testRestoreMessagesV2 at@(ATransport t) = - it "should store messages on exit and restore on start" $ do - g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - recipientId <- newTVarIO "" - recipientKey <- newTVarIO Nothing - dhShared <- newTVarIO Nothing - senderId <- newTVarIO "" - - withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do - runClient t $ \h1 -> do - (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub - atomically $ do - writeTVar recipientId rId - writeTVar recipientKey $ Just rKey - writeTVar dhShared $ Just dh - writeTVar senderId sId - Resp "1" _ OK <- signSendRecv h sKey ("1", sId, _SEND "hello") - Resp "" _ (Msg mId1 msg1) <- tGet1 h1 - Resp "1a" _ OK <- signSendRecv h1 rKey ("1a", rId, ACK mId1) - (decryptMsgV2 dh mId1 msg1, Right "hello") #== "message delivered" - -- messages below are delivered after server restart - sId <- readTVarIO senderId - Resp "2" _ OK <- signSendRecv h sKey ("2", sId, _SEND "hello 2") - Resp "3" _ OK <- signSendRecv h sKey ("3", sId, _SEND "hello 3") - Resp "4" _ OK <- signSendRecv h sKey ("4", sId, _SEND "hello 4") - pure () - - logSize testStoreLogFile `shouldReturn` 2 - logSize testStoreMsgsFile `shouldReturn` 3 - - withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do - rId <- readTVarIO recipientId - Just rKey <- readTVarIO recipientKey - Just dh <- readTVarIO dhShared - let dec = decryptMsgV2 dh - Resp "2" _ (Msg mId2 msg2) <- signSendRecv h rKey ("2", rId, SUB) - (dec mId2 msg2, Right "hello 2") #== "restored message delivered" - Resp "3" _ (Msg mId3 msg3) <- signSendRecv h rKey ("3", rId, ACK mId2) - (dec mId3 msg3, Right "hello 3") #== "restored message delivered" - Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, ACK mId3) - (dec mId4 msg4, Right "hello 4") #== "restored message delivered" - - logSize testStoreLogFile `shouldReturn` 1 - -- the last message is not removed because it was not ACK'd - logSize testStoreMsgsFile `shouldReturn` 1 - - withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do - rId <- readTVarIO recipientId - Just rKey <- readTVarIO recipientKey - Just dh <- readTVarIO dhShared - Resp "4" _ (Msg mId4 msg4) <- signSendRecv h rKey ("4", rId, SUB) - Resp "5" _ OK <- signSendRecv h rKey ("5", rId, ACK mId4) - (decryptMsgV2 dh mId4 msg4, Right "hello 4") #== "restored message delivered" - - logSize testStoreLogFile `shouldReturn` 1 - logSize testStoreMsgsFile `shouldReturn` 0 - - removeFile testStoreLogFile - removeFile testStoreMsgsFile - where - runTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> ThreadId -> Expectation - runTest _ test' server = do - testSMPClient test' `shouldReturn` () - killThread server - - runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation - runClient _ test' = testSMPClient test' `shouldReturn` () - testRestoreExpireMessages :: ATransport -> Spec testRestoreExpireMessages at@(ATransport t) = it "should store messages on exit and restore on start" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g recipientId <- newTVarIO "" recipientKey <- newTVarIO Nothing dhShared <- newTVarIO Nothing senderId <- newTVarIO "" - withSmpServerStoreMsgLogOnV2 at testPort . runTest t $ \h -> do + withSmpServerStoreMsgLogOn at testPort . runTest t $ \h -> do runClient t $ \h1 -> do (sId, rId, rKey, dh) <- createAndSecureQueue h1 sPub atomically $ do @@ -830,7 +702,7 @@ testRestoreExpireMessages at@(ATransport t) = length (B.lines msgs) `shouldBe` 4 let expCfg1 = Just ExpirationConfig {ttl = 86400, checkInterval = 43200} - cfg1 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} + cfg1 = cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg1, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg1 testPort . runTest t $ \_ -> pure () logSize testStoreLogFile `shouldReturn` 1 @@ -838,7 +710,7 @@ testRestoreExpireMessages at@(ATransport t) = msgs' `shouldBe` msgs let expCfg2 = Just ExpirationConfig {ttl = 2, checkInterval = 43200} - cfg2 = cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} + cfg2 = cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, messageExpiration = expCfg2, serverStatsBackupFile = Just testServerStatsBackupFile} withSmpServerConfigOn at cfg2 testPort . runTest t $ \_ -> pure () logSize testStoreLogFile `shouldReturn` 1 @@ -857,10 +729,10 @@ testRestoreExpireMessages at@(ATransport t) = runClient :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () -createAndSecureQueue :: Transport c => THandle c -> SndPublicVerifyKey -> IO (SenderId, RecipientId, RcvPrivateSignKey, RcvDhSecret) +createAndSecureQueue :: Transport c => THandle c -> SndPublicAuthKey -> IO (SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret) createAndSecureQueue h sPub = do g <- C.newRandom - (rPub, rKey) <- atomically $ C.generateSignatureKeyPair C.SEd448 g + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv h rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dhShared = C.dh' srvDh dhPriv @@ -870,32 +742,41 @@ createAndSecureQueue h sPub = do testTiming :: ATransport -> Spec testTiming (ATransport t) = - it "should have similar time for auth error, whether queue exists or not, for all key sizes" $ - smpTest2 t $ \rh sh -> - mapM_ (testSameTiming rh sh) timingTests + describe "should have similar time for auth error, whether queue exists or not, for all key types" $ + forM_ timingTests $ \tst -> + it (testName tst) $ + smpTest2Cfg cfgV7 (mkVersionRange 4 authCmdsSMPVersion) t $ \rh sh -> + testSameTiming rh sh tst where - timingTests :: [(Int, Int, Int)] + testName :: (C.AuthAlg, C.AuthAlg, Int) -> String + testName (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, _) = unwords ["queue key:", show goodKeyAlg, "/ used key:", show badKeyAlg] + timingTests :: [(C.AuthAlg, C.AuthAlg, Int)] timingTests = - [ (32, 32, 300), - (32, 57, 150), - (57, 32, 300), - (57, 57, 150) + [ (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd25519, 200), -- correct key type + -- (C.AuthAlg C.SEd25519, C.AuthAlg C.SEd448, 150), + -- (C.AuthAlg C.SEd25519, C.AuthAlg C.SX25519, 200), + (C.AuthAlg C.SEd448, C.AuthAlg C.SEd25519, 200), + (C.AuthAlg C.SEd448, C.AuthAlg C.SEd448, 150), -- correct key type + (C.AuthAlg C.SEd448, C.AuthAlg C.SX25519, 200), + (C.AuthAlg C.SX25519, C.AuthAlg C.SEd25519, 200), + (C.AuthAlg C.SX25519, C.AuthAlg C.SEd448, 150), + (C.AuthAlg C.SX25519, C.AuthAlg C.SX25519, 200) -- correct key type ] timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const - similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 - testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation - testSameTiming rh sh (goodKeySize, badKeySize, n) = do + similarTime t1 t2 = abs (t2 / t1 - 1) < 0.15 -- normally the difference between "no queue" and "wrong key" is less than 5% + testSameTiming :: forall c. Transport c => THandle c -> THandle c -> (C.AuthAlg, C.AuthAlg, Int) -> Expectation + testSameTiming rh sh (C.AuthAlg goodKeyAlg, C.AuthAlg badKeyAlg, n) = do g <- C.newRandom - (rPub, rKey) <- generateKeys g goodKeySize + (rPub, rKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g (dhPub, dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" "" (Ids rId sId srvDh) <- signSendRecv rh rKey ("abcd", "", NEW rPub dhPub Nothing SMSubscribe) let dec = decryptMsgV3 $ C.dh' srvDh dhPriv Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, SUB) - (_, badKey) <- generateKeys g badKeySize - -- runTimingTest rh badKey rId "SUB" + (_, badKey) <- atomically $ C.generateAuthKeyPair badKeyAlg g + runTimingTest rh badKey rId SUB - (sPub, sKey) <- generateKeys g goodKeySize + (sPub, sKey) <- atomically $ C.generateAuthKeyPair goodKeyAlg g Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, KEY sPub) Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, _SEND "hello") @@ -904,12 +785,13 @@ testTiming (ATransport t) = runTimingTest sh badKey sId $ _SEND "hello" where - generateKeys g = \case - 32 -> atomically $ C.generateSignatureKeyPair C.SEd25519 g - 57 -> atomically $ C.generateSignatureKeyPair C.SEd448 g - _ -> error "unsupported key size" + runTimingTest :: PartyI p => THandle c -> C.APrivateAuthKey -> ByteString -> Command p -> IO () runTimingTest h badKey qId cmd = do threadDelay 100000 + _ <- timeRepeat n $ do -- "warm up" the server + Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd) + return () + threadDelay 100000 timeWrongKey <- timeRepeat n $ do Resp "cdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdab", qId, cmd) return () @@ -918,22 +800,21 @@ testTiming (ATransport t) = Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd) return () let ok = similarTime timeNoQueue timeWrongKey - unless ok $ - (putStrLn . unwords . map show) - [ fromIntegral goodKeySize, - fromIntegral badKeySize, - timeWrongKey, - timeNoQueue, - abs (timeWrongKey / timeNoQueue - 1) - ] + unless ok . putStrLn . unwords $ + [ show goodKeyAlg, + show badKeyAlg, + show timeWrongKey, + show timeNoQueue, + show $ timeWrongKey / timeNoQueue - 1 + ] ok `shouldBe` True testMessageNotifications :: ATransport -> Spec testMessageNotifications (ATransport t) = it "should create simplex connection, subscribe notifier and deliver notifications" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (nPub, nKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (nPub, nKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g smpTest4 t $ \rh sh nh1 nh2 -> do (sId, rId, rKey, dhShared) <- createAndSecureQueue rh sPub let dec = decryptMsgV3 dhShared @@ -969,7 +850,7 @@ testMsgExpireOnSend :: forall c. Transport c => TProxy c -> Spec testMsgExpireOnSend t = it "should expire messages that are not received before messageTTL on SEND" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -990,7 +871,7 @@ testMsgExpireOnInterval t = -- fails on ubuntu xit' "should expire messages that are not received before messageTTL after expiry interval" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -1009,7 +890,7 @@ testMsgNOTExpireOnInterval :: forall c. Transport c => TProxy c -> Spec testMsgNOTExpireOnInterval t = it "should NOT expire messages that are not received before messageTTL if expiry interval is large" $ do g <- C.newRandom - (sPub, sKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let cfg' = cfg {messageExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 10000}} withSmpServerConfigOn (ATransport t) cfg' testPort $ \_ -> testSMPClient @c $ \sh -> do @@ -1030,8 +911,8 @@ samplePubKey = C.APublicVerifyKey C.SEd25519 "MCowBQYDK2VwAyEAfAOflyvbJv1fszgzkQ sampleDhPubKey :: C.PublicKey 'C.X25519 sampleDhPubKey = "MCowBQYDK2VuAyEAriy+HcARIhqsgSjVnjKqoft+y6pxrxdY68zn4+LjYhQ=" -sampleSig :: Maybe C.ASignature -sampleSig = "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA==" +sampleSig :: Maybe TransmissionAuth +sampleSig = Just $ TASignature "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA==" noAuth :: (Char, Maybe BasicAuth) noAuth = ('A', Nothing) @@ -1075,7 +956,7 @@ syntaxTests (ATransport t) = do it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) (>#>) :: Encoding smp => - (Maybe C.ASignature, ByteString, ByteString, smp) -> - (Maybe C.ASignature, ByteString, ByteString, BrokerMsg) -> + (Maybe TransmissionAuth, ByteString, ByteString, smp) -> + (Maybe TransmissionAuth, ByteString, ByteString, BrokerMsg) -> Expectation command >#> response = withFrozenCallStack $ smpServerTest t command `shouldReturn` response diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index ead057122..a11ba515a 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -86,8 +86,8 @@ testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDeliver runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkDelivery s r = do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -106,10 +106,10 @@ runTestFileChunkDelivery s r = do testFileChunkDeliveryAddRecipients :: Expectation testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey1, rpKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey2, rpKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey3, rpKey3) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey3, rpKey3) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -133,8 +133,8 @@ testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkDelete s r = do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -162,8 +162,8 @@ testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkAck s r = do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -183,8 +183,8 @@ runTestFileChunkAck s r = do testWrongChunkSize :: Expectation testWrongChunkSize = xftpTest $ \c -> do g <- C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, _rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, _rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g B.writeFile testChunkPath =<< atomically (C.randomBytes (kb 96) g) digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = kb 96, digest} @@ -196,8 +196,8 @@ testFileChunkExpiration :: Expectation testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $ \_ -> testXFTPClient $ \c -> runRight_ $ do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -235,8 +235,8 @@ testFileStorageQuota :: Expectation testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $ \_ -> testXFTPClient $ \c -> runRight_ $ do g <- liftIO C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- liftIO $ createTestChunk testChunkPath digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} @@ -263,9 +263,9 @@ testFileLog :: Expectation testFileLog = do g <- C.newRandom bytes <- liftIO $ createTestChunk testChunkPath - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey1, rpKey1) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey2, rpKey2) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath sIdVar <- newTVarIO "" rIdVar1 <- newTVarIO "" @@ -356,8 +356,8 @@ testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success = withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $ \_ -> testXFTPClient $ \c -> do g <- C.newRandom - (sndKey, spKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g - (rcvKey, rpKey) <- atomically $ C.generateSignatureKeyPair C.SEd25519 g + (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g bytes <- createTestChunk testChunkPath digest <- LC.sha256Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest}