diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs index ba8cfe702..75c5080ec 100644 --- a/apps/smp-server/Main.hs +++ b/apps/smp-server/Main.hs @@ -101,7 +101,7 @@ getConfig opts = do storeLog <- liftIO $ openStoreLog opts ini pure $ makeConfig ini pk storeLog -makeConfig :: IniOpts -> C.PrivateKey -> Maybe (StoreLog 'ReadMode) -> ServerConfig +makeConfig :: IniOpts -> C.PrivateKey 'C.RSA -> Maybe (StoreLog 'ReadMode) -> ServerConfig makeConfig IniOpts {serverPort, blockSize, enableWebsockets} pk storeLog = let transports = (serverPort, transport @TCP) : [("80", transport @WS) | enableWebsockets] in serverConfig {serverPrivateKey = pk, storeLog, blockSize, transports} @@ -200,11 +200,11 @@ createIni ServerOpts {enableStoreLog} = do enableWebsockets = True } -readKey :: IniOpts -> ExceptT String IO C.PrivateKey +readKey :: IniOpts -> ExceptT String IO (C.PrivateKey 'C.RSA) readKey IniOpts {serverKeyFile} = do fileExists serverKeyFile liftIO (S.readKeyFile serverKeyFile) >>= \case - [S.Unprotected (PrivKeyRSA pk)] -> pure $ C.PrivateKey pk + [S.Unprotected (PrivKeyRSA pk)] -> pure $ C.PrivateKeyRSA pk [_] -> err "not RSA key" [] -> err "invalid key file format" _ -> err "more than one key" @@ -212,10 +212,10 @@ readKey IniOpts {serverKeyFile} = do err :: String -> ExceptT String IO b err e = throwE $ e <> ": " <> serverKeyFile -createKey :: IniOpts -> IO C.PrivateKey +createKey :: IniOpts -> IO (C.PrivateKey 'C.RSA) createKey IniOpts {serverKeyFile} = do - (_, pk) <- C.generateKeyPair newKeySize - S.writeKeyFile S.TraditionalFormat serverKeyFile [PrivKeyRSA $ C.rsaPrivateKey pk] + (_, pk) <- C.generateKeyPair' newKeySize C.SRSA + S.writeKeyFile S.TraditionalFormat serverKeyFile [C.privateToX509 pk] pure pk fileExists :: FilePath -> ExceptT String IO () @@ -233,8 +233,8 @@ confirm msg = do ok <- getLine when (map toLower ok /= "y") exitFailure -serverKeyHash :: C.PrivateKey -> B.ByteString -serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey' +serverKeyHash :: C.PrivateKey 'C.RSA -> B.ByteString +serverKeyHash = encode . C.unKeyHash . C.publicKeyHash . C.publicKey openStoreLog :: ServerOpts -> IniOpts -> IO (Maybe (StoreLog 'ReadMode)) openStoreLog ServerOpts {enableStoreLog = l} IniOpts {enableStoreLog = l', storeLogFile = f} diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 7b48bcc04..bdc76278e 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -264,7 +264,7 @@ joinConn c connId qInfo cInfo = do activateQueueJoining c connId' sq verifyKey $ retryInterval cfg pure connId' -activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () +activateQueueJoining :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m () activateQueueJoining c connId sq verifyKey retryInterval = activateQueue c connId sq verifyKey retryInterval createReplyQueue where @@ -314,8 +314,8 @@ subscribeConnection' c connId = _ -> throwError $ INTERNAL "unexpected queue status" SomeConn _ (RcvConnection _ rq) -> subscribeQueue c rq connId where - verifyKey :: SndQueue -> C.PublicKey - verifyKey = C.publicKey' . signKey + verifyKey :: SndQueue -> C.APublicVerifyKey + verifyKey = C.publicKey . signKey activateSecuredQueue :: RcvQueue -> SndQueue -> m () activateSecuredQueue rq sq = do activateQueueInitiating c connId sq (verifyKey sq) =<< resumeInterval @@ -582,11 +582,11 @@ confirmQueue c sq senderKey cInfo = do sendConfirmation c sq senderKey cInfo withStore $ \st -> setSndQueueStatus st sq Confirmed -activateQueueInitiating :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () +activateQueueInitiating :: AgentMonad m => AgentClient -> ConnId -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m () activateQueueInitiating c connId sq verifyKey retryInterval = activateQueue c connId sq verifyKey retryInterval $ notifyConnected c connId -activateQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> VerificationKey -> RetryInterval -> m () -> m () +activateQueue :: forall m. AgentMonad m => AgentClient -> ConnId -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m () -> m () activateQueue c connId sq verifyKey retryInterval afterActivation = getActivation c connId >>= \case Nothing -> async runActivation >>= addActivation c connId @@ -603,11 +603,20 @@ notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m () notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON) newSndQueue :: - (MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> m (SndQueue, SenderPublicKey, VerificationKey) -newSndQueue (SMPQueueInfo smpServer senderId encryptKey) = do + (MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> m (SndQueue, SenderPublicKey, C.APublicVerifyKey) +newSndQueue qInfo = + asks (cmdSignAlg . config) >>= \case + C.SignAlg a -> newSndQueue_ a qInfo + +newSndQueue_ :: + (C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m, MonadReader Env m) => + C.SAlgorithm a -> + SMPQueueInfo -> + m (SndQueue, SenderPublicKey, C.APublicVerifyKey) +newSndQueue_ a (SMPQueueInfo smpServer senderId encryptKey) = do size <- asks $ rsaKeySize . config - (senderKey, sndPrivateKey) <- liftIO $ C.generateKeyPair size - (verifyKey, signKey) <- liftIO $ C.generateKeyPair size + (senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a + (verifyKey, signKey) <- liftIO $ C.generateSignatureKeyPair size C.SRSA let sndQueue = SndQueue { server = smpServer, diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 031403a4a..9e86fe777 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -224,13 +224,23 @@ smpClientError = \case e -> INTERNAL $ show e newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueInfo) -newRcvQueue c srv = do +newRcvQueue c srv = + asks (cmdSignAlg . config) >>= \case + C.SignAlg a -> newRcvQueue_ a c srv + +newRcvQueue_ :: + (C.SignatureAlgorithm a, C.AlgorithmI a, AgentMonad m) => + C.SAlgorithm a -> + AgentClient -> + SMPServer -> + m (RcvQueue, SMPQueueInfo) +newRcvQueue_ a c srv = do size <- asks $ rsaKeySize . config - (recipientKey, rcvPrivateKey) <- liftIO $ C.generateKeyPair size + (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a logServer "-->" c srv "" "NEW" (rcvId, sId) <- withSMP c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sId] - (encryptKey, decryptKey) <- liftIO $ C.generateKeyPair size + (encryptKey, decryptKey) <- liftIO $ C.generateEncryptionKeyPair size C.SRSA let rq = RcvQueue { server = srv, @@ -299,7 +309,7 @@ sendConfirmation c sq@SndQueue {server, sndId} senderKey cInfo = mkConfirmation :: SMPClient -> m MsgBody mkConfirmation smp = encryptAndSign smp sq . serializeSMPMessage $ SMPConfirmation senderKey cInfo -sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> VerificationKey -> RetryInterval -> m () +sendHello :: forall m. AgentMonad m => AgentClient -> SndQueue -> C.APublicVerifyKey -> RetryInterval -> m () sendHello c sq@SndQueue {server, sndId, sndPrivateKey} verifyKey ri = withLogSMP_ c server sndId "SEND (retrying)" $ \smp -> do msg <- mkHello smp $ AckMode On @@ -350,23 +360,27 @@ encryptAndSign smp SndQueue {encryptKey, signKey} msg = do paddedSize <- asks $ (blockSize smp -) . reservedMsgSize liftError cryptoError $ do enc <- C.encrypt encryptKey paddedSize msg - C.Signature sig <- C.sign signKey enc - pure $ sig <> enc + sig <- C.sign signKey enc + pure $ C.signatureBytes sig <> enc decryptAndVerify :: AgentMonad m => RcvQueue -> ByteString -> m ByteString decryptAndVerify RcvQueue {decryptKey, verifyKey} msg = verifyMessage verifyKey msg >>= liftError cryptoError . C.decrypt decryptKey -verifyMessage :: AgentMonad m => Maybe VerificationKey -> ByteString -> m ByteString +verifyMessage :: AgentMonad m => Maybe C.APublicVerifyKey -> ByteString -> m ByteString verifyMessage verifyKey msg = do - size <- asks $ rsaKeySize . config - let (sig, enc) = B.splitAt size msg + sigSize <- asks $ rsaKeySize . config + let (s, enc) = B.splitAt sigSize msg case verifyKey of Nothing -> pure enc - Just k - | C.verify k (C.Signature sig) enc -> pure enc - | otherwise -> throwError $ AGENT A_SIGNATURE + Just k -> + case C.decodeSignature $ B.take (C.signatureSize k) s of + Left _ -> throwError $ AGENT A_SIGNATURE + Right sig -> + if C.verify k sig enc + then pure enc + else throwError $ AGENT A_SIGNATURE cryptoError :: C.CryptoError -> AgentErrorType cryptoError = \case diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 6a063d4dd..1e9b367cd 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -16,6 +16,7 @@ import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client +import qualified Simplex.Messaging.Crypto as C import System.Random (StdGen, newStdGen) import UnliftIO.STM @@ -23,6 +24,7 @@ data AgentConfig = AgentConfig { tcpPort :: ServiceName, smpServers :: NonEmpty SMPServer, rsaKeySize :: Int, + cmdSignAlg :: C.SignAlg, connIdBytes :: Int, tbqSize :: Natural, dbFile :: FilePath, @@ -41,6 +43,7 @@ defaultAgentConfig = { tcpPort = "5224", smpServers = undefined, rsaKeySize = 2048 `div` 8, + cmdSignAlg = C.SignAlg C.SEd448, connIdBytes = 12, tbqSize = 16, dbFile = "smp-agent.db", diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 0614a2df8..09f9a3613 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -55,10 +55,6 @@ module Simplex.Messaging.Agent.Protocol MsgIntegrity (..), MsgErrorType (..), QueueStatus (..), - SignatureKey, - VerificationKey, - EncryptionKey, - DecryptionKey, ACorrId, AgentMsgId, @@ -223,7 +219,7 @@ data SMPMessage -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents data AMessage where -- | the first message in the queue to validate it is secured - HELLO :: VerificationKey -> AckMode -> AMessage + HELLO :: C.APublicVerifyKey -> AckMode -> AMessage -- | reply queue information REPLY :: SMPQueueInfo -> AMessage -- | agent envelope for the client message @@ -238,7 +234,7 @@ parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE smpMessageP = A.endOfLine *> smpClientMessageP <|> smpConfirmationP smpConfirmationP :: Parser SMPMessage - smpConfirmationP = "KEY " *> (SMPConfirmation <$> C.pubKeyP <* A.endOfLine <* A.endOfLine <*> binaryBodyP <* A.endOfLine) + smpConfirmationP = "KEY " *> (SMPConfirmation <$> C.strKeyP <* A.endOfLine <* A.endOfLine <*> binaryBodyP <* A.endOfLine) smpClientMessageP :: Parser SMPMessage smpClientMessageP = @@ -253,7 +249,7 @@ parseSMPMessage = parse (smpMessageP <* A.endOfLine) $ AGENT A_MESSAGE -- | Serialize SMP message. serializeSMPMessage :: SMPMessage -> ByteString serializeSMPMessage = \case - SMPConfirmation sKey cInfo -> smpMessage ("KEY " <> C.serializePubKey sKey) "" (serializeBinary cInfo) <> "\n" + SMPConfirmation sKey cInfo -> smpMessage ("KEY " <> C.serializeKey sKey) "" (serializeBinary cInfo) <> "\n" SMPMessage {senderMsgId, senderTimestamp, previousMsgHash, agentMessage} -> let header = messageHeader senderMsgId senderTimestamp previousMsgHash body = serializeAgentMessage agentMessage @@ -269,7 +265,7 @@ agentMessageP = <|> "REPLY " *> reply <|> "MSG " *> a_msg where - hello = HELLO <$> C.pubKeyP <*> ackMode + hello = HELLO <$> C.strKeyP <*> ackMode reply = REPLY <$> smpQueueInfoP a_msg = A_MSG <$> binaryBodyP <* A.endOfLine ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On) @@ -277,7 +273,7 @@ agentMessageP = -- | SMP queue information parser. smpQueueInfoP :: Parser SMPQueueInfo smpQueueInfoP = - "smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.pubKeyP) + "smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.strKeyP) -- | SMP server location parser. smpServerP :: Parser SMPServer @@ -289,14 +285,14 @@ smpServerP = SMPServer <$> server <*> optional port <*> optional kHash serializeAgentMessage :: AMessage -> ByteString serializeAgentMessage = \case - HELLO verifyKey ackMode -> "HELLO " <> C.serializePubKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else "" + HELLO verifyKey ackMode -> "HELLO " <> C.serializeKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else "" REPLY qInfo -> "REPLY " <> serializeSmpQueueInfo qInfo A_MSG body -> "MSG " <> serializeBinary body <> "\n" -- | Serialize SMP queue information that is sent out-of-band. serializeSmpQueueInfo :: SMPQueueInfo -> ByteString serializeSmpQueueInfo (SMPQueueInfo srv qId ek) = - B.intercalate "::" ["smp", serializeServer srv, encode qId, C.serializePubKey ek] + B.intercalate "::" ["smp", serializeServer srv, encode qId, C.serializeKey ek] -- | Serialize SMP server location. serializeServer :: SMPServer -> ByteString @@ -332,21 +328,9 @@ newtype AckMode = AckMode OnOff deriving (Eq, Show) -- | SMP queue information sent out-of-band. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages -data SMPQueueInfo = SMPQueueInfo SMPServer SMP.SenderId EncryptionKey +data SMPQueueInfo = SMPQueueInfo SMPServer SMP.SenderId C.APublicEncryptKey deriving (Eq, Show) --- | Public key used to E2E encrypt SMP messages. -type EncryptionKey = C.PublicKey - --- | Private key used to E2E decrypt SMP messages. -type DecryptionKey = C.PrivateKey - --- | Private key used to sign SMP commands -type SignatureKey = C.PrivateKey - --- | Public key used by SMP server to authorize (verify) SMP commands. -type VerificationKey = C.PublicKey - data QueueDirection = SND | RCV deriving (Show) -- | SMP queue status. @@ -437,7 +421,7 @@ data SMPAgentError A_PROHIBITED | -- | cannot RSA/AES-decrypt or parse decrypted header A_ENCRYPTION - | -- | invalid RSA signature + | -- | invalid signature A_SIGNATURE deriving (Eq, Generic, Read, Show, Exception) diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index f6bdec954..2eba1b814 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -18,6 +18,7 @@ import Data.Kind (Type) import Data.Time (UTCTime) import Data.Type.Equality import Simplex.Messaging.Agent.Protocol +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol ( MsgBody, MsgId, @@ -41,7 +42,7 @@ class Monad m => MonadAgentStore s m where upgradeRcvConnToDuplex :: s -> ConnId -> SndQueue -> m () upgradeSndConnToDuplex :: s -> ConnId -> RcvQueue -> m () setRcvQueueStatus :: s -> RcvQueue -> QueueStatus -> m () - setRcvQueueActive :: s -> RcvQueue -> VerificationKey -> m () + setRcvQueueActive :: s -> RcvQueue -> C.APublicVerifyKey -> m () setSndQueueStatus :: s -> SndQueue -> QueueStatus -> m () -- Confirmations @@ -70,8 +71,8 @@ data RcvQueue = RcvQueue rcvId :: SMP.RecipientId, rcvPrivateKey :: RecipientPrivateKey, sndId :: Maybe SMP.SenderId, - decryptKey :: DecryptionKey, - verifyKey :: Maybe VerificationKey, + decryptKey :: C.APrivateDecryptKey, + verifyKey :: Maybe C.APublicVerifyKey, status :: QueueStatus } deriving (Eq, Show) @@ -81,8 +82,8 @@ data SndQueue = SndQueue { server :: SMPServer, sndId :: SMP.SenderId, sndPrivateKey :: SenderPrivateKey, - encryptKey :: EncryptionKey, - signKey :: SignatureKey, + encryptKey :: C.APublicEncryptKey, + signKey :: C.APrivateSignKey, status :: QueueStatus } deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 177dd2950..7e2f09bdc 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -51,6 +51,7 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration) import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Parsers (blobFieldParser) import Simplex.Messaging.Protocol (MsgBody) import qualified Simplex.Messaging.Protocol as SMP @@ -248,7 +249,7 @@ instance (MonadUnliftIO m, MonadError StoreError m) => MonadAgentStore SQLiteSto |] [":status" := status, ":host" := host, ":port" := serializePort_ port, ":rcv_id" := rcvId] - setRcvQueueActive :: SQLiteStore -> RcvQueue -> VerificationKey -> m () + setRcvQueueActive :: SQLiteStore -> RcvQueue -> C.APublicVerifyKey -> m () setRcvQueueActive st RcvQueue {rcvId, server = SMPServer {host, port}} verifyKey = -- ? throw error if queue does not exist? liftIO . withTransaction st $ \db -> diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 7c845d809..0dc0ac929 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -82,7 +82,7 @@ data SMPClient = SMPClient tcpTimeout :: Int, clientCorrId :: TVar Natural, sentCommands :: TVar (Map CorrId Request), - sndQ :: TBQueue SignedRawTransmission, + sndQ :: TBQueue SentRawTransmission, rcvQ :: TBQueue SignedTransmissionOrError, msgQ :: TBQueue SMPServerTransmission, blockSize :: Int @@ -333,14 +333,14 @@ suspendSMPQueue = okSMPCommand $ Cmd SRecipient OFF deleteSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO () deleteSMPQueue = okSMPCommand $ Cmd SRecipient DEL -okSMPCommand :: Cmd -> SMPClient -> C.PrivateKey -> QueueId -> ExceptT SMPClientError IO () +okSMPCommand :: Cmd -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO () okSMPCommand cmd c pKey qId = sendSMPCommand c (Just pKey) qId cmd >>= \case Cmd _ OK -> return () _ -> throwE SMPUnexpectedResponse -- | Send any SMP command ('Cmd' type). -sendSMPCommand :: SMPClient -> Maybe C.PrivateKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd +sendSMPCommand :: SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId cmd = do corrId <- lift_ getNextCorrId t <- signTransmission $ serializeTransmission (corrId, qId, cmd) @@ -354,20 +354,20 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId i <- stateTVar clientCorrId $ \i -> (i, i + 1) pure . CorrId $ bshow i - signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission + signTransmission :: ByteString -> ExceptT SMPClientError IO SentRawTransmission signTransmission t = case pKey of - Nothing -> return ("", t) + Nothing -> return (Nothing, t) Just pk -> do sig <- liftError SMPSignatureError $ C.sign pk t - return (sig, t) + return (Just sig, t) -- two separate "atomically" needed to avoid blocking - sendRecv :: CorrId -> SignedRawTransmission -> IO Response + sendRecv :: CorrId -> SentRawTransmission -> IO Response sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar where withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a - send :: CorrId -> SignedRawTransmission -> STM (TMVar Response) + send :: CorrId -> SentRawTransmission -> STM (TMVar Response) send corrId t = do r <- newEmptyTMVar modifyTVar sentCommands . M.insert corrId $ Request qId r diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index a92c75ffd..b4ffbc9ee 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -1,11 +1,19 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -- | -- Module : Simplex.Messaging.Crypto @@ -19,28 +27,50 @@ -- This module provides cryptography implementation for SMP protocols based on -- . module Simplex.Messaging.Crypto - ( -- * RSA keys + ( -- * Cryptographic keys + Algorithm (..), + SAlgorithm (..), + Alg (..), + SignAlg (..), PrivateKey (..), PublicKey (..), + APrivateKey (..), + APublicKey (..), + APrivateSignKey (..), + APublicVerifyKey (..), + APrivateDecryptKey (..), + APublicEncryptKey (..), + CryptoKey (..), + CryptoPrivateKey (..), KeyPair, KeyHash (..), generateKeyPair, - publicKey', - publicKeySize, - validKeySize, + generateKeyPair', + generateSignatureKeyPair, + generateEncryptionKeyPair, + privateToX509, -- * E2E hybrid encryption scheme encrypt, + encrypt', decrypt, + decrypt', -- * RSA OAEP encryption encryptOAEP, decryptOAEP, - -- * RSA PSS signing + -- * sign/verify Signature (..), + ASignature (..), + CryptoSignature (..), + SignatureSize (..), + SignatureAlgorithm, + AlgorithmI (..), sign, verify, + verify', + validSignatureSize, -- * AES256 AEAD-GCM scheme Key (..), @@ -56,13 +86,7 @@ module Simplex.Messaging.Crypto ivP, -- * Encoding of RSA keys - serializePrivKey, - serializePubKey, - encodePubKey, publicKeyHash, - privKeyP, - pubKeyP, - binaryPubKeyP, -- * SHA256 hash sha256Hash, @@ -81,6 +105,10 @@ import qualified Crypto.Error as CE import Crypto.Hash (Digest, SHA256 (..), hash) import Crypto.Number.Generate (generateMax) import Crypto.Number.Prime (findPrimeFrom) +import qualified Crypto.PubKey.Curve25519 as X25519 +import qualified Crypto.PubKey.Curve448 as X448 +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA as R import qualified Crypto.PubKey.RSA.OAEP as OAEP import qualified Crypto.PubKey.RSA.PSS as PSS @@ -97,42 +125,507 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w, w2c) import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Constraint (Dict (..)) +import Data.Kind (Constraint, Type) import Data.String +import Data.Type.Equality import Data.X509 import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) +import GHC.TypeLits (ErrorMessage (..), TypeError) import Network.Transport.Internal (decodeWord32, encodeWord32) import Simplex.Messaging.Parsers (base64P, blobFieldParser, parseAll, parseString) import Simplex.Messaging.Util (liftEitherError, (<$?>)) --- | A newtype of 'Crypto.PubKey.RSA.PublicKey'. -newtype PublicKey = PublicKey {rsaPublicKey :: R.PublicKey} deriving (Eq, Show) +-- | Cryptographic algorithms. +data Algorithm = RSA | Ed25519 | Ed448 | X25519 | X448 --- | A newtype of 'Crypto.PubKey.RSA.PrivateKey' (PublicKey may be inside). -newtype PrivateKey = PrivateKey {rsaPrivateKey :: R.PrivateKey} deriving (Eq, Show) +-- | Singleton types for 'Algorithm'. +data SAlgorithm :: Algorithm -> Type where + SRSA :: SAlgorithm RSA + SEd25519 :: SAlgorithm Ed25519 + SEd448 :: SAlgorithm Ed448 + SX25519 :: SAlgorithm X25519 + SX448 :: SAlgorithm X448 -instance IsString PrivateKey where - fromString = parseString $ decode >=> decodePrivKey +deriving instance Eq (SAlgorithm a) -instance IsString PublicKey where - fromString = parseString $ decode >=> decodePubKey +deriving instance Show (SAlgorithm a) -instance ToField PrivateKey where toField = toField . encodePrivKey +data Alg = forall a. AlgorithmI a => Alg (SAlgorithm a) -instance ToField PublicKey where toField = toField . encodePubKey +data SignAlg + = forall a. + (AlgorithmI a, SignatureAlgorithm a) => + SignAlg (SAlgorithm a) -instance FromField PrivateKey where fromField = blobFieldParser binaryPrivKeyP +class AlgorithmI (a :: Algorithm) where sAlgorithm :: SAlgorithm a -instance FromField PublicKey where fromField = blobFieldParser binaryPubKeyP +instance AlgorithmI RSA where sAlgorithm = SRSA + +instance AlgorithmI Ed25519 where sAlgorithm = SEd25519 + +instance AlgorithmI Ed448 where sAlgorithm = SEd448 + +instance AlgorithmI X25519 where sAlgorithm = SX25519 + +instance AlgorithmI X448 where sAlgorithm = SX448 + +instance TestEquality SAlgorithm where + testEquality SRSA SRSA = Just Refl + testEquality SEd25519 SEd25519 = Just Refl + testEquality SEd448 SEd448 = Just Refl + testEquality SX25519 SX25519 = Just Refl + testEquality SX448 SX448 = Just Refl + testEquality _ _ = Nothing + +-- | GADT for public keys. +data PublicKey (a :: Algorithm) where + PublicKeyRSA :: R.PublicKey -> PublicKey RSA + PublicKeyEd25519 :: Ed25519.PublicKey -> PublicKey Ed25519 + PublicKeyEd448 :: Ed448.PublicKey -> PublicKey Ed448 + PublicKeyX25519 :: X25519.PublicKey -> PublicKey X25519 + PublicKeyX448 :: X448.PublicKey -> PublicKey X448 + +deriving instance Eq (PublicKey a) + +deriving instance Show (PublicKey a) + +data APublicKey + = forall a. + AlgorithmI a => + APublicKey (SAlgorithm a) (PublicKey a) + +instance Eq APublicKey where + APublicKey a k == APublicKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APublicKey + +-- | GADT for private keys. +data PrivateKey (a :: Algorithm) where + PrivateKeyRSA :: {privateKeyRSA :: R.PrivateKey} -> PrivateKey RSA + PrivateKeyEd25519 :: Ed25519.SecretKey -> Ed25519.PublicKey -> PrivateKey Ed25519 + PrivateKeyEd448 :: Ed448.SecretKey -> Ed448.PublicKey -> PrivateKey Ed448 + PrivateKeyX25519 :: X25519.SecretKey -> PrivateKey X25519 + PrivateKeyX448 :: X448.SecretKey -> PrivateKey X448 + +deriving instance Eq (PrivateKey a) + +deriving instance Show (PrivateKey a) + +data APrivateKey + = forall a. + AlgorithmI a => + APrivateKey (SAlgorithm a) (PrivateKey a) + +instance Eq APrivateKey where + APrivateKey a k == APrivateKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APrivateKey + +class AlgorithmPrefix k where + algorithmPrefix :: k -> ByteString + +instance AlgorithmPrefix (SAlgorithm a) where + algorithmPrefix = \case + SRSA -> "rsa" + SEd25519 -> "ed25519" + SEd448 -> "ed448" + SX25519 -> "x25519" + SX448 -> "x448" + +instance AlgorithmI a => AlgorithmPrefix (PublicKey a) where + algorithmPrefix _ = algorithmPrefix $ sAlgorithm @a + +instance AlgorithmI a => AlgorithmPrefix (PrivateKey a) where + algorithmPrefix _ = algorithmPrefix $ sAlgorithm @a + +instance AlgorithmPrefix APublicKey where + algorithmPrefix (APublicKey a _) = algorithmPrefix a + +instance AlgorithmPrefix APrivateKey where + algorithmPrefix (APrivateKey a _) = algorithmPrefix a + +prefixAlgorithm :: ByteString -> Either String Alg +prefixAlgorithm = \case + "rsa" -> Right $ Alg SRSA + "ed25519" -> Right $ Alg SEd25519 + "ed448" -> Right $ Alg SEd448 + "x25519" -> Right $ Alg SX25519 + "x448" -> Right $ Alg SX448 + _ -> Left "unknown algorithm" + +algP :: Parser Alg +algP = prefixAlgorithm <$?> A.takeTill (== ':') + +type family SignatureAlgorithm (a :: Algorithm) :: Constraint where + SignatureAlgorithm RSA = () + SignatureAlgorithm Ed25519 = () + SignatureAlgorithm Ed448 = () + SignatureAlgorithm a = + (Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used to sign/verify")) + +signatureAlgorithm :: SAlgorithm a -> Maybe (Dict (SignatureAlgorithm a)) +signatureAlgorithm = \case + SRSA -> Just Dict + SEd25519 -> Just Dict + SEd448 -> Just Dict + _ -> Nothing + +data APrivateSignKey + = forall a. + (AlgorithmI a, SignatureAlgorithm a) => + APrivateSignKey (SAlgorithm a) (PrivateKey a) + +instance Eq APrivateSignKey where + APrivateSignKey a k == APrivateSignKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APrivateSignKey + +data APublicVerifyKey + = forall a. + (AlgorithmI a, SignatureAlgorithm a) => + APublicVerifyKey (SAlgorithm a) (PublicKey a) + +instance Eq APublicVerifyKey where + APublicVerifyKey a k == APublicVerifyKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APublicVerifyKey + +type family EncryptionAlgorithm (a :: Algorithm) :: Constraint where + EncryptionAlgorithm RSA = () + EncryptionAlgorithm a = + (Int ~ Bool, TypeError (Text "Algorithm " :<>: ShowType a :<>: Text " cannot be used to encrypt/decrypt")) + +encryptionAlgorithm :: SAlgorithm a -> Maybe (Dict (EncryptionAlgorithm a)) +encryptionAlgorithm = \case + SRSA -> Just Dict + _ -> Nothing + +data APrivateDecryptKey + = forall a. + (AlgorithmI a, EncryptionAlgorithm a) => + APrivateDecryptKey (SAlgorithm a) (PrivateKey a) + +instance Eq APrivateDecryptKey where + APrivateDecryptKey a k == APrivateDecryptKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APrivateDecryptKey + +data APublicEncryptKey + = forall a. + (AlgorithmI a, EncryptionAlgorithm a) => + APublicEncryptKey (SAlgorithm a) (PublicKey a) + +instance Eq APublicEncryptKey where + APublicEncryptKey a k == APublicEncryptKey a' k' = case testEquality a a' of + Just Refl -> k == k' + Nothing -> False + +deriving instance Show APublicEncryptKey + +-- | Class for all key types +class CryptoKey k where + keySize :: k -> Int + + validKeySize :: k -> Bool + + -- | base64 X509 key encoding with algorithm prefix + serializeKey :: k -> ByteString + + -- | binary X509 key encoding + encodeKey :: k -> ByteString + + -- | base64 X509 (with algorithm prefix) key parser + strKeyP :: Parser k + + -- | binary X509 key parser + binaryKeyP :: Parser k + +-- | X509 encoding of any public key. +instance CryptoKey APublicKey where + keySize (APublicKey _ k) = keySize k + validKeySize (APublicKey _ k) = validKeySize k + serializeKey (APublicKey _ k) = serializeKey k + encodeKey (APublicKey _ k) = encodeKey k + strKeyP = do + Alg a <- algP <* A.char ':' + k@(APublicKey a' _) <- decodePubKey <$?> base64P + case testEquality a a' of + Just Refl -> pure k + _ -> fail $ "public key algorithm " <> show a <> " does not match prefix" + binaryKeyP = decodePubKey <$?> A.takeByteString + +-- | X509 encoding of signature public key. +instance CryptoKey APublicVerifyKey where + keySize (APublicVerifyKey _ k) = keySize k + validKeySize (APublicVerifyKey _ k) = validKeySize k + serializeKey (APublicVerifyKey _ k) = serializeKey k + encodeKey (APublicVerifyKey _ k) = encodeKey k + strKeyP = pubVerifyKey <$?> strKeyP + binaryKeyP = pubVerifyKey <$?> binaryKeyP + +-- | X509 encoding of encryption public key. +instance CryptoKey APublicEncryptKey where + keySize (APublicEncryptKey _ k) = keySize k + validKeySize (APublicEncryptKey _ k) = validKeySize k + serializeKey (APublicEncryptKey _ k) = serializeKey k + encodeKey (APublicEncryptKey _ k) = encodeKey k + strKeyP = pubEncryptKey <$?> strKeyP + binaryKeyP = pubEncryptKey <$?> binaryKeyP + +-- | X509 encoding of 'PublicKey'. +instance forall a. AlgorithmI a => CryptoKey (PublicKey a) where + keySize = \case + PublicKeyRSA k -> R.public_size k + PublicKeyEd25519 _ -> Ed25519.publicKeySize + PublicKeyEd448 _ -> Ed448.publicKeySize + PublicKeyX25519 _ -> x25519_size + PublicKeyX448 _ -> x448_size + validKeySize = \case + PublicKeyRSA k -> validRSAKeySize $ R.public_size k + _ -> True + serializeKey k = algorithmPrefix k <> ":" <> encode (encodeKey k) + encodeKey = encodeASNKey . publicToX509 + strKeyP = pubKey' <$?> strKeyP + binaryKeyP = pubKey' <$?> binaryKeyP + +-- | X509 encoding of any private key. +instance CryptoKey APrivateKey where + keySize (APrivateKey _ k) = keySize k + validKeySize (APrivateKey _ k) = validKeySize k + serializeKey (APrivateKey _ k) = serializeKey k + encodeKey (APrivateKey _ k) = encodeKey k + strKeyP = do + Alg a <- algP <* A.char ':' + k@(APrivateKey a' _) <- decodePrivKey <$?> base64P + case testEquality a a' of + Just Refl -> pure k + _ -> fail $ "private key algorithm " <> show a <> " does not match prefix" + binaryKeyP = decodePrivKey <$?> A.takeByteString + +-- | X509 encoding of signature private key. +instance CryptoKey APrivateSignKey where + keySize (APrivateSignKey _ k) = keySize k + validKeySize (APrivateSignKey _ k) = validKeySize k + serializeKey (APrivateSignKey _ k) = serializeKey k + encodeKey (APrivateSignKey _ k) = encodeKey k + strKeyP = privSignKey <$?> strKeyP + binaryKeyP = privSignKey <$?> binaryKeyP + +-- | X509 encoding of encryption private key. +instance CryptoKey APrivateDecryptKey where + keySize (APrivateDecryptKey _ k) = keySize k + validKeySize (APrivateDecryptKey _ k) = validKeySize k + serializeKey (APrivateDecryptKey _ k) = serializeKey k + encodeKey (APrivateDecryptKey _ k) = encodeKey k + strKeyP = privDecryptKey <$?> strKeyP + binaryKeyP = privDecryptKey <$?> binaryKeyP + +-- | X509 encoding of 'PrivateKey'. +instance AlgorithmI a => CryptoKey (PrivateKey a) where + keySize = \case + PrivateKeyRSA k -> rsaPrivateKeySize k + PrivateKeyEd25519 _ _ -> Ed25519.secretKeySize + PrivateKeyEd448 _ _ -> Ed448.secretKeySize + PrivateKeyX25519 _ -> x25519_size + PrivateKeyX448 _ -> x448_size + validKeySize = \case + PrivateKeyRSA k -> validRSAKeySize $ rsaPrivateKeySize k + _ -> True + serializeKey k = algorithmPrefix k <> ":" <> encode (encodeKey k) + encodeKey = encodeASNKey . privateToX509 + strKeyP = privKey' <$?> strKeyP + binaryKeyP = privKey' <$?> binaryKeyP + +type family PublicKeyType pk where + PublicKeyType APrivateKey = APublicKey + PublicKeyType APrivateSignKey = APublicVerifyKey + PublicKeyType APrivateDecryptKey = APublicEncryptKey + PublicKeyType (PrivateKey a) = PublicKey a + +class CryptoPrivateKey pk where publicKey :: pk -> PublicKeyType pk + +instance CryptoPrivateKey APrivateKey where + publicKey (APrivateKey a k) = APublicKey a $ publicKey k + +instance CryptoPrivateKey APrivateSignKey where + publicKey (APrivateSignKey a k) = APublicVerifyKey a $ publicKey k + +instance CryptoPrivateKey APrivateDecryptKey where + publicKey (APrivateDecryptKey a k) = APublicEncryptKey a $ publicKey k + +instance CryptoPrivateKey (PrivateKey a) where + publicKey = \case + PrivateKeyRSA k -> PublicKeyRSA $ R.private_pub k + PrivateKeyEd25519 _ k -> PublicKeyEd25519 k + PrivateKeyEd448 _ k -> PublicKeyEd448 k + PrivateKeyX25519 k -> PublicKeyX25519 $ X25519.toPublic k + PrivateKeyX448 k -> PublicKeyX448 $ X448.toPublic k + +instance AlgorithmI a => IsString (PrivateKey a) where + fromString = parseString $ decode >=> decodePrivKey >=> privKey' + +instance AlgorithmI a => IsString (PublicKey a) where + fromString = parseString $ decode >=> decodePubKey >=> pubKey' -- | Tuple of RSA 'PublicKey' and 'PrivateKey'. -type KeyPair = (PublicKey, PrivateKey) +type KeyPair a = (PublicKey a, PrivateKey a) --- | RSA signature newtype. -newtype Signature = Signature {unSignature :: ByteString} deriving (Eq, Show) +type AKeyPair = (APublicKey, APrivateKey) -instance IsString Signature where - fromString = Signature . fromString +type ASignatureKeyPair = (APublicVerifyKey, APrivateSignKey) + +type AnEncryptionKeyPair = (APublicEncryptKey, APrivateDecryptKey) + +generateKeyPair :: AlgorithmI a => Int -> SAlgorithm a -> IO AKeyPair +generateKeyPair size a = bimap (APublicKey a) (APrivateKey a) <$> generateKeyPair' size a + +generateSignatureKeyPair :: + (AlgorithmI a, SignatureAlgorithm a) => Int -> SAlgorithm a -> IO ASignatureKeyPair +generateSignatureKeyPair size a = + bimap (APublicVerifyKey a) (APrivateSignKey a) <$> generateKeyPair' size a + +generateEncryptionKeyPair :: + (AlgorithmI a, EncryptionAlgorithm a) => Int -> SAlgorithm a -> IO AnEncryptionKeyPair +generateEncryptionKeyPair size a = + bimap (APublicEncryptKey a) (APrivateDecryptKey a) <$> generateKeyPair' size a + +generateKeyPair' :: Int -> SAlgorithm a -> IO (KeyPair a) +generateKeyPair' size = \case + SRSA -> generateKeyPairRSA size + SEd25519 -> + Ed25519.generateSecretKey >>= \pk -> + let k = Ed25519.toPublic pk + in pure (PublicKeyEd25519 k, PrivateKeyEd25519 pk k) + SEd448 -> + Ed448.generateSecretKey >>= \pk -> + let k = Ed448.toPublic pk + in pure (PublicKeyEd448 k, PrivateKeyEd448 pk k) + SX25519 -> + X25519.generateSecretKey >>= \pk -> + let k = X25519.toPublic pk + in pure (PublicKeyX25519 k, PrivateKeyX25519 pk) + SX448 -> + X448.generateSecretKey >>= \pk -> + let k = X448.toPublic pk + in pure (PublicKeyX448 k, PrivateKeyX448 pk) + +instance ToField APrivateSignKey where toField = toField . encodeKey + +instance ToField APublicVerifyKey where toField = toField . encodeKey + +instance ToField APrivateDecryptKey where toField = toField . encodeKey + +instance ToField APublicEncryptKey where toField = toField . encodeKey + +instance FromField APrivateSignKey where fromField = blobFieldParser binaryKeyP + +instance FromField APublicVerifyKey where fromField = blobFieldParser binaryKeyP + +instance FromField APrivateDecryptKey where fromField = blobFieldParser binaryKeyP + +instance FromField APublicEncryptKey where fromField = blobFieldParser binaryKeyP + +instance IsString (Maybe ASignature) where + fromString = parseString $ decode >=> decodeSignature + +data Signature (a :: Algorithm) where + SignatureRSA :: ByteString -> Signature RSA + SignatureEd25519 :: Ed25519.Signature -> Signature Ed25519 + SignatureEd448 :: Ed448.Signature -> Signature Ed448 + +deriving instance Eq (Signature a) + +deriving instance Show (Signature a) + +data ASignature + = forall a. + (AlgorithmI a, SignatureAlgorithm a) => + ASignature (SAlgorithm a) (Signature a) + +instance Eq ASignature where + ASignature a s == ASignature a' s' = case testEquality a a' of + Just Refl -> s == s' + _ -> False + +deriving instance Show ASignature + +class CryptoSignature s where + serializeSignature :: s -> ByteString + serializeSignature = encode . signatureBytes + signatureBytes :: s -> ByteString + decodeSignature :: ByteString -> Either String s + +instance CryptoSignature ASignature where + signatureBytes (ASignature _ sig) = signatureBytes sig + decodeSignature s + | l == Ed25519.signatureSize = + ASignature SEd25519 . SignatureEd25519 <$> ed Ed25519.signature s + | l == Ed448.signatureSize = + ASignature SEd448 . SignatureEd448 <$> ed Ed448.signature s + | l == 128 || l == 256 || l == 384 || l == 512 = rsa s + | otherwise = Left "bad signature size" + where + l = B.length s + ed alg = first show . CE.eitherCryptoError . alg + rsa = Right . ASignature SRSA . SignatureRSA + +instance CryptoSignature (Maybe ASignature) where + signatureBytes = maybe "" signatureBytes + decodeSignature s + | B.null s = Right Nothing + | otherwise = Just <$> decodeSignature s + +instance AlgorithmI a => CryptoSignature (Signature a) where + signatureBytes = \case + SignatureRSA s -> s + SignatureEd25519 s -> BA.convert s + SignatureEd448 s -> BA.convert s + decodeSignature s = do + ASignature a sig <- decodeSignature s + case testEquality a $ sAlgorithm @a of + Just Refl -> Right sig + _ -> Left "bad signature algorithm" + +class SignatureSize s where signatureSize :: s -> Int + +instance SignatureSize (Signature a) where + signatureSize = \case + SignatureRSA s -> B.length s + SignatureEd25519 _ -> Ed25519.signatureSize + SignatureEd448 _ -> Ed448.signatureSize + +instance SignatureSize APrivateSignKey where + signatureSize (APrivateSignKey _ k) = signatureSize k + +instance SignatureSize APublicVerifyKey where + signatureSize (APublicVerifyKey _ k) = signatureSize k + +instance SignatureAlgorithm a => SignatureSize (PrivateKey a) where + signatureSize = \case + PrivateKeyRSA k -> rsaPrivateKeySize k + PrivateKeyEd25519 _ _ -> Ed25519.signatureSize + PrivateKeyEd448 _ _ -> Ed448.signatureSize + +instance SignatureAlgorithm a => SignatureSize (PublicKey a) where + signatureSize = \case + PublicKeyRSA k -> R.public_size k + PublicKeyEd25519 _ -> Ed25519.signatureSize + PublicKeyEd448 _ -> Ed448.signatureSize + +rsaPrivateKeySize :: R.PrivateKey -> Int +rsaPrivateKeySize = R.public_size . R.private_pub -- | Various cryptographic or related errors. data CryptoError @@ -142,6 +635,8 @@ data CryptoError RSADecryptError R.Error | -- | RSA PSS signature error RSASignError R.Error + | -- | Unsupported signing algorithm + UnsupportedAlgorithm | -- | AES initialization error AESCipherError CE.CryptoError | -- | IV generation error @@ -164,8 +659,8 @@ authTagSize :: Int authTagSize = 128 `div` 8 -- | Generate RSA key pair. -generateKeyPair :: Int -> IO KeyPair -generateKeyPair size = loop +generateKeyPairRSA :: Int -> IO (KeyPair RSA) +generateKeyPairRSA size = loop where publicExponent = findPrimeFrom . (+ 3) <$> generateMax pubExpRange loop = do @@ -174,24 +669,20 @@ generateKeyPair size = loop d = R.private_d pk if d * d < n then loop - else pure (PublicKey k, PrivateKey pk) + else pure (PublicKeyRSA k, PrivateKeyRSA pk) -privateKeySize :: PrivateKey -> Int -privateKeySize = R.public_size . R.private_pub . rsaPrivateKey +x25519_size :: Int +x25519_size = 32 -publicKey' :: PrivateKey -> PublicKey -publicKey' = PublicKey . R.private_pub . rsaPrivateKey +x448_size :: Int +x448_size = 448 `quot` 8 -publicKeySize :: PublicKey -> Int -publicKeySize = R.public_size . rsaPublicKey +validRSAKeySize :: Int -> Bool +validRSAKeySize n = n == 128 || n == 256 || n == 384 || n == 512 -validKeySize :: Int -> Bool -validKeySize = \case - 128 -> True - 256 -> True - 384 -> True - 512 -> True - _ -> False +validSignatureSize :: Int -> Bool +validSignatureSize n = + n == Ed25519.signatureSize || n == Ed448.signatureSize || validRSAKeySize n data Header = Header { aesKey :: Key, @@ -217,8 +708,8 @@ instance ToField KeyHash where toField = toField . encode . unKeyHash instance FromField KeyHash where fromField = blobFieldParser $ KeyHash <$> base64P -- | Digest (hash) of binary X509 encoding of RSA public key. -publicKeyHash :: PublicKey -> KeyHash -publicKeyHash = KeyHash . sha256Hash . encodePubKey +publicKeyHash :: PublicKey RSA -> KeyHash +publicKeyHash = KeyHash . sha256Hash . encodeKey -- | SHA256 digest. sha256Hash :: ByteString -> ByteString @@ -249,28 +740,36 @@ parseHeader = first CryptoHeaderError . parseAll headerP -- * E2E hybrid encryption scheme --- | E2E encrypt SMP agent messages. +-- | Legacy hybrid E2E encryption of SMP agent messages (RSA-OAEP/AES-256-GCM-SHA256). -- -- https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption -encrypt :: PublicKey -> Int -> ByteString -> ExceptT CryptoError IO ByteString -encrypt k paddedSize msg = do +encrypt' :: PublicKey a -> Int -> ByteString -> ExceptT CryptoError IO ByteString +encrypt' k@(PublicKeyRSA _) paddedSize msg = do aesKey <- liftIO randomAesKey ivBytes <- liftIO randomIV (authTag, msg') <- encryptAES aesKey ivBytes paddedSize msg let header = Header {aesKey, ivBytes, authTag, msgSize = B.length msg} encHeader <- encryptOAEP k $ serializeHeader header return $ encHeader <> msg' +encrypt' _ _ _ = throwE UnsupportedAlgorithm --- | E2E decrypt SMP agent messages. +-- | Legacy hybrid E2E decryption of SMP agent messages (RSA-OAEP/AES-256-GCM-SHA256). -- -- https://github.com/simplex-chat/simplexmq/blob/master/rfcs/2021-01-26-crypto.md#e2e-encryption -decrypt :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString -decrypt pk msg'' = do - let (encHeader, msg') = B.splitAt (privateKeySize pk) msg'' +decrypt' :: PrivateKey a -> ByteString -> ExceptT CryptoError IO ByteString +decrypt' pk@(PrivateKeyRSA _) msg'' = do + let (encHeader, msg') = B.splitAt (keySize pk) msg'' header <- decryptOAEP pk encHeader Header {aesKey, ivBytes, authTag, msgSize} <- except $ parseHeader header msg <- decryptAES aesKey ivBytes msg' authTag return $ B.take msgSize msg +decrypt' _ _ = throwE UnsupportedAlgorithm + +encrypt :: APublicEncryptKey -> Int -> ByteString -> ExceptT CryptoError IO ByteString +encrypt (APublicEncryptKey _ k) = encrypt' k + +decrypt :: APrivateDecryptKey -> ByteString -> ExceptT CryptoError IO ByteString +decrypt (APrivateDecryptKey _ pk) = decrypt' pk -- | AEAD-GCM encryption. -- @@ -335,85 +834,115 @@ oaepParams = OAEP.defaultOAEPParams SHA256 -- | RSA OAEP encryption. -- -- Used as part of hybrid E2E encryption scheme and for SMP transport handshake. -encryptOAEP :: PublicKey -> ByteString -> ExceptT CryptoError IO ByteString -encryptOAEP (PublicKey k) aesKey = +encryptOAEP :: PublicKey RSA -> ByteString -> ExceptT CryptoError IO ByteString +encryptOAEP (PublicKeyRSA k) aesKey = liftEitherError RSAEncryptError $ OAEP.encrypt oaepParams k aesKey -- | RSA OAEP decryption. -- -- Used as part of hybrid E2E encryption scheme and for SMP transport handshake. -decryptOAEP :: PrivateKey -> ByteString -> ExceptT CryptoError IO ByteString -decryptOAEP pk encKey = +decryptOAEP :: PrivateKey RSA -> ByteString -> ExceptT CryptoError IO ByteString +decryptOAEP (PrivateKeyRSA pk) encKey = liftEitherError RSADecryptError $ - OAEP.decryptSafer oaepParams (rsaPrivateKey pk) encKey + OAEP.decryptSafer oaepParams pk encKey pssParams :: PSS.PSSParams SHA256 ByteString ByteString pssParams = PSS.defaultPSSParams SHA256 --- | RSA PSS message signing. +-- | Message signing. -- -- Used by SMP clients to sign SMP commands and by SMP agents to sign messages. -sign :: PrivateKey -> ByteString -> ExceptT CryptoError IO Signature -sign pk msg = ExceptT $ bimap RSASignError Signature <$> PSS.signSafer pssParams (rsaPrivateKey pk) msg +sign' :: SignatureAlgorithm a => PrivateKey a -> ByteString -> ExceptT CryptoError IO (Signature a) +sign' (PrivateKeyRSA pk) msg = ExceptT $ bimap RSASignError SignatureRSA <$> PSS.signSafer pssParams pk msg +sign' (PrivateKeyEd25519 pk k) msg = pure . SignatureEd25519 $ Ed25519.sign pk k msg +sign' (PrivateKeyEd448 pk k) msg = pure . SignatureEd448 $ Ed448.sign pk k msg --- | RSA PSS signature verification. +sign :: APrivateSignKey -> ByteString -> ExceptT CryptoError IO ASignature +sign (APrivateSignKey a k) = fmap (ASignature a) . sign' k + +-- | Signature verification. -- -- Used by SMP servers to authorize SMP commands and by SMP agents to verify messages. -verify :: PublicKey -> Signature -> ByteString -> Bool -verify (PublicKey k) (Signature sig) msg = PSS.verify pssParams k msg sig +verify' :: SignatureAlgorithm a => PublicKey a -> Signature a -> ByteString -> Bool +verify' (PublicKeyRSA k) (SignatureRSA sig) msg = PSS.verify pssParams k msg sig +verify' (PublicKeyEd25519 k) (SignatureEd25519 sig) msg = Ed25519.verify k msg sig +verify' (PublicKeyEd448 k) (SignatureEd448 sig) msg = Ed448.verify k msg sig --- | Base-64 X509 encoding of RSA public key. --- --- Used as part of SMP queue information (out-of-band message). -serializePubKey :: PublicKey -> ByteString -serializePubKey = ("rsa:" <>) . encode . encodePubKey +verify :: APublicVerifyKey -> ASignature -> ByteString -> Bool +verify (APublicVerifyKey a k) (ASignature a' sig) msg = case testEquality a a' of + Just Refl -> verify' k sig msg + _ -> False --- | Base-64 PKCS8 encoding of PSA private key. --- --- Not used as part of SMP protocols. -serializePrivKey :: PrivateKey -> ByteString -serializePrivKey = ("rsa:" <>) . encode . encodePrivKey +pubVerifyKey :: APublicKey -> Either String APublicVerifyKey +pubVerifyKey (APublicKey a k) = case signatureAlgorithm a of + Just Dict -> Right $ APublicVerifyKey a k + _ -> Left "key does not support signature algorithms" --- Base-64 X509 RSA public key parser. -pubKeyP :: Parser PublicKey -pubKeyP = decodePubKey <$?> ("rsa:" *> base64P) +pubEncryptKey :: APublicKey -> Either String APublicEncryptKey +pubEncryptKey (APublicKey a k) = case encryptionAlgorithm a of + Just Dict -> Right $ APublicEncryptKey a k + _ -> Left "key does not support encryption algorithms" --- Binary X509 RSA public key parser. -binaryPubKeyP :: Parser PublicKey -binaryPubKeyP = decodePubKey <$?> A.takeByteString +pubKey' :: forall a. AlgorithmI a => APublicKey -> Either String (PublicKey a) +pubKey' (APublicKey a k) = case testEquality a $ sAlgorithm @a of + Just Refl -> Right k + _ -> Left "bad key algorithm" --- Base-64 PKCS8 RSA private key parser. -privKeyP :: Parser PrivateKey -privKeyP = decodePrivKey <$?> ("rsa:" *> base64P) +privSignKey :: APrivateKey -> Either String APrivateSignKey +privSignKey (APrivateKey a k) = case signatureAlgorithm a of + Just Dict -> Right $ APrivateSignKey a k + _ -> Left "key does not support signature algorithms" --- Binary PKCS8 RSA private key parser. -binaryPrivKeyP :: Parser PrivateKey -binaryPrivKeyP = decodePrivKey <$?> A.takeByteString +privDecryptKey :: APrivateKey -> Either String APrivateDecryptKey +privDecryptKey (APrivateKey a k) = case encryptionAlgorithm a of + Just Dict -> Right $ APrivateDecryptKey a k + _ -> Left "key does not support encryption algorithms" --- Binary X509 encoding of 'PublicKey'. -encodePubKey :: PublicKey -> ByteString -encodePubKey = encodeKey . PubKeyRSA . rsaPublicKey +privKey' :: forall a. AlgorithmI a => APrivateKey -> Either String (PrivateKey a) +privKey' (APrivateKey a k) = case testEquality a $ sAlgorithm @a of + Just Refl -> Right k + _ -> Left "bad key algorithm" --- Binary PKCS8 encoding of 'PrivateKey'. -encodePrivKey :: PrivateKey -> ByteString -encodePrivKey = encodeKey . PrivKeyRSA . rsaPrivateKey +publicToX509 :: PublicKey a -> PubKey +publicToX509 = \case + PublicKeyRSA k -> PubKeyRSA k + PublicKeyEd25519 k -> PubKeyEd25519 k + PublicKeyEd448 k -> PubKeyEd448 k + PublicKeyX25519 k -> PubKeyX25519 k + PublicKeyX448 k -> PubKeyX448 k -encodeKey :: ASN1Object a => a -> ByteString -encodeKey k = toStrict . encodeASN1 DER $ toASN1 k [] +privateToX509 :: PrivateKey a -> PrivKey +privateToX509 = \case + PrivateKeyRSA k -> PrivKeyRSA k + PrivateKeyEd25519 k _ -> PrivKeyEd25519 k + PrivateKeyEd448 k _ -> PrivKeyEd448 k + PrivateKeyX25519 k -> PrivKeyX25519 k + PrivateKeyX448 k -> PrivKeyX448 k + +encodeASNKey :: ASN1Object a => a -> ByteString +encodeASNKey k = toStrict . encodeASN1 DER $ toASN1 k [] -- Decoding of binary X509 'PublicKey'. -decodePubKey :: ByteString -> Either String PublicKey +decodePubKey :: ByteString -> Either String APublicKey decodePubKey = decodeKey >=> \case - (PubKeyRSA k, []) -> Right $ PublicKey k + (PubKeyRSA k, []) -> Right . APublicKey SRSA $ PublicKeyRSA k + (PubKeyEd25519 k, []) -> Right . APublicKey SEd25519 $ PublicKeyEd25519 k + (PubKeyEd448 k, []) -> Right . APublicKey SEd448 $ PublicKeyEd448 k + (PubKeyX25519 k, []) -> Right . APublicKey SX25519 $ PublicKeyX25519 k + (PubKeyX448 k, []) -> Right . APublicKey SX448 $ PublicKeyX448 k r -> keyError r -- Decoding of binary PKCS8 'PrivateKey'. -decodePrivKey :: ByteString -> Either String PrivateKey +decodePrivKey :: ByteString -> Either String APrivateKey decodePrivKey = decodeKey >=> \case - (PrivKeyRSA pk, []) -> Right $ PrivateKey pk + (PrivKeyRSA pk, []) -> Right . APrivateKey SRSA $ PrivateKeyRSA pk + (PrivKeyEd25519 k, []) -> Right . APrivateKey SEd25519 . PrivateKeyEd25519 k $ Ed25519.toPublic k + (PrivKeyEd448 k, []) -> Right . APrivateKey SEd448 . PrivateKeyEd448 k $ Ed448.toPublic k + (PrivKeyX25519 k, []) -> Right . APrivateKey SX25519 $ PrivateKeyX25519 k + (PrivKeyX448 k, []) -> Right . APrivateKey SX448 $ PrivateKeyX448 k r -> keyError r decodeKey :: ASN1Object a => ByteString -> Either String (a, [ASN1]) @@ -421,5 +950,5 @@ decodeKey = fromASN1 <=< first show . decodeASN1 DER . fromStrict keyError :: (a, [ASN1]) -> Either String b keyError = \case - (_, []) -> Left "not RSA key" + (_, []) -> Left "unknown key algorithm" _ -> Left "more than one key" diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index d80f25ed5..f6d072aa2 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -34,6 +34,7 @@ module Simplex.Messaging.Protocol SignedTransmission, SignedTransmissionOrError, RawTransmission, + SentRawTransmission, SignedRawTransmission, CorrId (..), QueueId, @@ -76,6 +77,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.Kind +import Data.Maybe (isNothing) import Data.String import Data.Time.Clock import Data.Time.ISO8601 @@ -109,18 +111,21 @@ deriving instance Show Cmd type Transmission = (CorrId, QueueId, Cmd) -- | SMP transmission with signature. -type SignedTransmission = (C.Signature, Transmission) +type SignedTransmission = (Maybe C.ASignature, Transmission) type TransmissionOrError = (CorrId, QueueId, Either ErrorType Cmd) -- | signed parsed transmission, with parsing error. -type SignedTransmissionOrError = (C.Signature, TransmissionOrError) +type SignedTransmissionOrError = (Maybe C.ASignature, TransmissionOrError) -- | unparsed SMP transmission with signature. type RawTransmission = (ByteString, ByteString, ByteString, ByteString) --- | unparsed SMP transmission with signature. -type SignedRawTransmission = (C.Signature, ByteString) +-- | unparsed sent SMP transmission with signature. +type SignedRawTransmission = (Maybe C.ASignature, ByteString, ByteString, ByteString) + +-- | unparsed sent SMP transmission with signature. +type SentRawTransmission = (Maybe C.ASignature, ByteString) -- | SMP queue ID for the recipient. type RecipientId = QueueId @@ -177,24 +182,24 @@ instance IsString CorrId where -- | Recipient's private key used by the recipient to authorize (sign) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key. -type RecipientPrivateKey = C.PrivateKey +type RecipientPrivateKey = C.APrivateSignKey -- | Recipient's public key used by SMP server to verify authorization of SMP commands. -type RecipientPublicKey = C.PublicKey +type RecipientPublicKey = C.APublicVerifyKey -- | Sender's private key used by the recipient to authorize (sign) SMP commands. -- -- Only used by SMP agent, kept here so its definition is close to respective public key. -type SenderPrivateKey = C.PrivateKey +type SenderPrivateKey = C.APrivateSignKey -- | Sender's public key used by SMP server to verify authorization of SMP commands. -type SenderPublicKey = C.PublicKey +type SenderPublicKey = C.APublicVerifyKey -- | Private key used by push notifications server to authorize (sign) LSTN command. -type NotifierPrivateKey = C.PrivateKey +type NotifierPrivateKey = C.APrivateSignKey -- | Public key used by SMP server to verify authorization of LSTN command sent by push notifications server. -type NotifierPublicKey = C.PublicKey +type NotifierPublicKey = C.APublicVerifyKey -- | SMP message server ID. type MsgId = Encoded @@ -243,11 +248,11 @@ instance Arbitrary CommandError where arbitrary = genericArbitraryU -- | SMP transmission parser. transmissionP :: Parser RawTransmission transmissionP = do - signature <- segment + sig <- segment corrId <- segment queueId <- segment command <- A.takeByteString - return (signature, corrId, queueId, command) + return (sig, corrId, queueId, command) where segment = A.takeTill (== ' ') <* " " @@ -273,11 +278,11 @@ commandP = <|> "ERR " *> serverError <|> "PONG" $> Cmd SBroker PONG where - newCmd = Cmd SRecipient . NEW <$> C.pubKeyP + newCmd = Cmd SRecipient . NEW <$> C.strKeyP idsResp = Cmd SBroker <$> (IDS <$> (base64P <* A.space) <*> base64P) nIdsResp = Cmd SBroker . NID <$> base64P - keyCmd = Cmd SRecipient . KEY <$> C.pubKeyP - nKeyCmd = Cmd SRecipient . NKEY <$> C.pubKeyP + keyCmd = Cmd SRecipient . KEY <$> C.strKeyP + nKeyCmd = Cmd SRecipient . NKEY <$> C.strKeyP sendCmd = do size <- A.decimal <* A.space Cmd SSender . SEND <$> A.take size <* A.space @@ -297,9 +302,9 @@ parseCommand = parse (commandP <* " " <* A.takeByteString) $ CMD SYNTAX -- | Serialize SMP command. serializeCommand :: Cmd -> ByteString serializeCommand = \case - Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializePubKey rKey - Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializePubKey sKey - Cmd SRecipient (NKEY nKey) -> "NKEY " <> C.serializePubKey nKey + Cmd SRecipient (NEW rKey) -> "NEW " <> C.serializeKey rKey + Cmd SRecipient (KEY sKey) -> "KEY " <> C.serializeKey sKey + Cmd SRecipient (NKEY nKey) -> "NKEY " <> C.serializeKey nKey Cmd SRecipient SUB -> "SUB" Cmd SRecipient ACK -> "ACK" Cmd SRecipient OFF -> "OFF" @@ -328,9 +333,9 @@ serializeErrorType :: ErrorType -> ByteString serializeErrorType = bshow -- | Send signed SMP transmission to TCP transport. -tPut :: Transport c => THandle c -> SignedRawTransmission -> IO (Either TransportError ()) -tPut th (C.Signature sig, t) = - tPutEncrypted th $ encode sig <> " " <> t <> " " +tPut :: Transport c => THandle c -> SentRawTransmission -> IO (Either TransportError ()) +tPut th (sig, t) = + tPutEncrypted th $ C.serializeSignature sig <> " " <> t <> " " -- | Serialize SMP transmission. serializeTransmission :: Transmission -> ByteString @@ -362,26 +367,21 @@ tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate where decodeParseValidate :: Either TransportError RawTransmission -> m SignedTransmissionOrError decodeParseValidate = \case - Right (signature, corrId, queueId, command) -> - let decodedTransmission = liftM2 (,corrId,,command) (validSig =<< decode signature) (decode queueId) + Right (sig, corrId, queueId, command) -> + let decodedTransmission = liftM2 (,corrId,,command) (C.decodeSignature =<< decode sig) (decode queueId) in either (const $ tError corrId) tParseValidate decodedTransmission Left _ -> tError "" - validSig :: ByteString -> Either String ByteString - validSig sig - | B.null sig || C.validKeySize (B.length sig) = Right sig - | otherwise = Left "invalid signature size" - tError :: ByteString -> m SignedTransmissionOrError - tError corrId = return (C.Signature "", (CorrId corrId, "", Left BLOCK)) + tError corrId = return (Nothing, (CorrId corrId, "", Left BLOCK)) - tParseValidate :: RawTransmission -> m SignedTransmissionOrError + tParseValidate :: SignedRawTransmission -> m SignedTransmissionOrError tParseValidate t@(sig, corrId, queueId, command) = do let cmd = parseCommand command >>= fromParty >>= tCredentials t - return (C.Signature sig, (CorrId corrId, queueId, cmd)) + return (sig, (CorrId corrId, queueId, cmd)) - tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd - tCredentials (signature, _, queueId, _) cmd = case cmd of + tCredentials :: SignedRawTransmission -> Cmd -> Either ErrorType Cmd + tCredentials (sig, _, queueId, _) cmd = case cmd of -- IDS response must not have queue ID Cmd SBroker IDS {} -> Right cmd -- ERR response does not always have queue ID @@ -396,7 +396,7 @@ tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate | otherwise -> Right cmd -- NEW must have signature but NOT queue ID Cmd SRecipient NEW {} - | B.null signature -> Left $ CMD NO_AUTH + | isNothing sig -> 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 @@ -405,9 +405,9 @@ tGet fromParty th = liftIO (tGetParse th) >>= decodeParseValidate | otherwise -> Right cmd -- PING must not have queue ID or signature Cmd SSender PING - | B.null queueId && B.null signature -> Right cmd + | isNothing sig && B.null queueId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and queue ID Cmd _ _ - | B.null signature || B.null queueId -> Left $ CMD NO_AUTH + | isNothing sig || B.null queueId -> Left $ CMD NO_AUTH | otherwise -> Right cmd diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 3d4cd634c..0f173d111 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -37,6 +37,7 @@ import Data.Functor (($>)) import qualified Data.Map.Strict as M import Data.Maybe (isNothing) import Data.Time.Clock +import Data.Type.Equality import Network.Socket (ServiceName) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol @@ -142,59 +143,78 @@ receive h Client {rcvQ} = forever $ do send :: (Transport c, MonadUnliftIO m) => THandle c -> Client -> m () send h Client {sndQ} = forever $ do t <- atomically $ readTBQueue sndQ - liftIO $ tPut h ("", serializeTransmission t) + liftIO $ tPut h (Nothing, serializeTransmission t) mkResp :: CorrId -> QueueId -> Command 'Broker -> Transmission mkResp corrId queueId command = (corrId, queueId, Cmd SBroker command) verifyTransmission :: forall m. (MonadUnliftIO m, MonadReader Env m) => SignedTransmission -> m Transmission -verifyTransmission (sig, t@(corrId, queueId, cmd)) = do +verifyTransmission (sig_, t@(corrId, queueId, cmd)) = do (corrId,queueId,) <$> case cmd of Cmd SBroker _ -> return $ smpErr INTERNAL -- it can only be client command, because `fromClient` was used Cmd SRecipient (NEW k) -> pure $ verifySignature k Cmd SRecipient _ -> verifyCmd SRecipient $ verifySignature . recipientKey - Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe sig . senderKey + Cmd SSender (SEND _) -> verifyCmd SSender $ verifyMaybe . senderKey Cmd SSender PING -> return cmd - Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe sig . fmap snd . notifier + Cmd SNotifier NSUB -> verifyCmd SNotifier $ verifyMaybe . fmap snd . notifier where verifyCmd :: SParty p -> (QueueRec -> Cmd) -> m Cmd verifyCmd party f = do st <- asks queueStore q <- atomically $ getQueue st party queueId - pure $ either (const $ dummyVerify authErr) f q - verifyMaybe :: C.Signature -> Maybe SenderPublicKey -> Cmd - verifyMaybe "" = maybe cmd (const authErr) - verifyMaybe _ = maybe authErr verifySignature - verifySignature :: C.PublicKey -> Cmd - verifySignature key = if verify key then cmd else authErr - verify key - | C.publicKeySize key == sigLen = cryptoVerify key - | otherwise = dummyVerify False - cryptoVerify key = C.verify key sig (serializeTransmission t) + pure $ either (const $ dummyVerify_ sig_ authErr) f q + verifyMaybe :: Maybe C.APublicVerifyKey -> Cmd + verifyMaybe (Just k) = verifySignature k + verifyMaybe _ = maybe cmd (const authErr) sig_ + verifySignature :: C.APublicVerifyKey -> Cmd + verifySignature key = case sig_ of + Just s -> if verify key s then cmd else authErr + _ -> authErr + 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) -> cryptoVerify k s + _ -> dummyVerify sig False + cryptoVerify :: C.SignatureAlgorithm a => C.PublicKey a -> C.Signature a -> Bool + cryptoVerify k s = C.verify' k s (serializeTransmission t) + dummyVerify_ :: Maybe C.ASignature -> a -> a + dummyVerify_ = \case + Just s -> dummyVerify s + _ -> id + dummyVerify :: C.ASignature -> a -> a + dummyVerify (C.ASignature _ s) = seq $ cryptoVerify (dummyPublicKey s) s smpErr = Cmd SBroker . ERR authErr = smpErr AUTH - dummyVerify :: a -> a - dummyVerify = seq $ - cryptoVerify $ case sigLen of - 128 -> dummyKey128 - 256 -> dummyKey256 - 384 -> dummyKey384 - 512 -> dummyKey512 - _ -> dummyKey256 - sigLen = B.length $ C.unSignature sig -- 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 -dummyKey128 :: C.PublicKey +dummyPublicKey :: C.Signature a -> C.PublicKey a +dummyPublicKey = \case + C.SignatureRSA s' -> case B.length s' of + 128 -> dummyKey128 + 256 -> dummyKey256 + 384 -> dummyKey384 + 512 -> dummyKey512 + _ -> dummyKey256 + C.SignatureEd25519 _ -> dummyKeyEd25519 + C.SignatureEd448 _ -> dummyKeyEd448 + +dummyKeyEd25519 :: C.PublicKey 'C.Ed25519 +dummyKeyEd25519 = "MCowBQYDK2VwAyEA139Oqs4QgpqbAmB0o7rZf6T19ryl7E65k4AYe0kE3Qs=" + +dummyKeyEd448 :: C.PublicKey 'C.Ed448 +dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA" + +dummyKey128 :: C.PublicKey 'C.RSA dummyKey128 = "MIIBIDANBgkqhkiG9w0BAQEFAAOCAQ0AMIIBCAKBgQC2oeA7s4roXN5K2N6022I1/2CTeMKjWH0m00bSZWa4N8LDKeFcShh8YUxZea5giAveViTRNOOVLgcuXbKvR3u24szN04xP0+KnYUuUUIIoT3YSjX0IlomhDhhSyup4BmA0gAZ+D1OaIKZFX6J8yQ1Lr/JGLEfSRsBjw8l+4hs9OwKBgQDKA+YlZvGb3BcpDwKmatiCXN7ZRDWkjXbj8VAW5zV95tSRCCVN48hrFM1H4Ju2QMMUc6kPUVX+eW4ZjdCl5blIqIHMcTmsdcmsDDCg3PjUNrwc6bv/1TcirbAKcmnKt9iurIt6eerxSO7TZUXXMUVsi7eRwb/RUNhpCrpJ/hpIOw==" -dummyKey256 :: C.PublicKey +dummyKey256 :: C.PublicKey 'C.RSA dummyKey256 = "MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAxwmTvaqmdTbkfUGNi8Yu0L/T4cxuOlQlx3zGZ9X9Qx0+oZjknWK+QHrdWTcpS+zH4Hi7fP6kanOQoQ90Hj6Ghl57VU1GEdUPywSw4i1/7t0Wv9uT9Q2ktHp2rqVo3xkC9IVIpL7EZAxdRviIN2OsOB3g4a/F1ZpjxcAaZeOMUugiAX1+GtkLuE0Xn4neYjCaOghLxQTdhybN70VtnkiQLx/X9NjkDIl/spYGm3tQFMyYKkP6IWoEpj0926hJ0fmlmhy8tAOhlZsb/baW5cgkEZ3E9jVVrySCgQzoLQgma610FIISRpRJbSyv26jU7MkMxiyuBiDaFOORkXFttoKbtQKBgEbDS9II2brsz+vfI7uP8atFcawkE52cx4M1UWQhqb1H3tBiRl+qO+dMq1pPQF2bW7dlZAWYzS4W/367bTAuALHBDGB8xi1P4Njhh9vaOgTvuqrHG9NJQ85BLy0qGw8rjIWSIXVmVpfrXFJ8po5l04UE258Ll2yocv3QRQmddQW9" -dummyKey384 :: C.PublicKey +dummyKey384 :: C.PublicKey 'C.RSA dummyKey384 = "MIICITANBgkqhkiG9w0BAQEFAAOCAg4AMIICCQKCAYEAthExp77lSFBMB0RedjgKIU+oNH5lMGdMqDCG0E5Ly7X49rFpfDMMN08GDIgvzg9kcwV3ScbPcjUE19wmAShX9f9k3w38KM3wmIBKSiuCREQl0V3xAYp1SYwiAkMNSSwxuIkDEeSOR56WdEcZvqbB4lY9MQlUv70KriPDxZaqKCTKslUezXHQuYPQX6eMnGFK7hxz5Kl5MajV52d+5iXsa8CA+m/e1KVnbelCO+xhN89xG8ALt0CJ9k5Wwo3myLgXi4dmNankCmg8jkh+7y2ywkzxMwH1JydDtV/FLzkbZsbPR2w93TNrTq1RJOuqMyh0VtdBSpxNW/Ft988TkkX2BAWzx82INw7W6/QbHGNtHNB995R4sgeYy8QbEpNGBhQnfQh7yRWygLTVXWKApQzzfCeIoDDWUS7dMv/zXoasAnpDBj+6UhHv3BHrps7kBvRyZQ2d/nUuAqiGd43ljJ++n6vNyFLgZoiV7HLia/FOGMkdt7j92CNmFHxiT6Xl7kRHAoGBAPNoWny2O7LBxzAKMLmQVHBAiKp6RMx+7URvtQDHDHPaZ7F3MvtvmYWwGzund3cQFAaV1EkJoYeI3YRuj6xdXgMyMaP54On++btArb6jUtZuvlC98qE8dEEHQNh+7TsCiMU+ivbeKFxS9A/B7OVedoMnPoJWhatbA9zB/6L1GNPh" -dummyKey512 :: C.PublicKey +dummyKey512 :: C.PublicKey 'C.RSA dummyKey512 = "MIICoDANBgkqhkiG9w0BAQEFAAOCAo0AMIICiAKCAgEArkCY9DuverJ4mmzDektv9aZMFyeRV46WZK9NsOBKEc+1ncqMs+LhLti9asKNgUBRbNzmbOe0NYYftrUpwnATaenggkTFxxbJ4JGJuGYbsEdFWkXSvrbWGtM8YUmn5RkAGme12xQ89bSM4VoJAGnrYPHwmcQd+KYCPZvTUsxaxgrJTX65ejHN9BsAn8XtGViOtHTDJO9yUMD2WrJvd7wnNa+0ugEteDLzMU++xS98VC+uA1vfauUqi3yXVchdfrLdVUuM+JE0gUEXCgzjuHkaoHiaGNiGhdPYoAJJdOKQOIHAKdk7Th6OPhirPhc9XYNB4O8JDthKhNtfokvFIFlC4QBRzJhpLIENaEBDt08WmgpOnecZB/CuxkqqOrNa8j5K5jNrtXAI67W46VEC2jeQy/gZwb64Zit2A4D00xXzGbQTPGj4ehcEMhLx5LSCygViEf0w0tN3c3TEyUcgPzvECd2ZVpQLr9Z4a07Ebr+YSuxcHhjg4Rg1VyJyOTTvaCBGm5X2B3+tI4NUttmikIHOYpBnsLmHY2BgfH2KcrIsDyAhInXmTFr/L2+erFarUnlfATd2L8Ti43TNHDedO6k6jI5Gyi62yPwjqPLEIIK8l+pIeNfHJ3pPmjhHBfzFcQLMMMXffHWNK8kWklrQXK+4j4HiPcTBvlO1FEtG9nEIZhUCgYA4a6WtI2k5YNli1C89GY5rGUY7RP71T6RWri/D3Lz9T7GvU+FemAyYmsvCQwqijUOur0uLvwSP8VdxpSUcrjJJSWur2hrPWzWlu0XbNaeizxpFeKbQP+zSrWJ1z8RwfAeUjShxt8q1TuqGqY10wQyp3nyiTGvS+KwZVj5h5qx8NQ==" client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m () @@ -266,10 +286,10 @@ client clnt@Client {subscriptions, ntfSubscriptions, rcvQ, sndQ = sndQ'} Server withLog $ \s -> logAddNotifier s queueId nId nKey pure $ NID nId - checkKeySize :: Monad m' => C.PublicKey -> m' (Command 'Broker) -> m' Transmission + checkKeySize :: Monad m' => C.APublicVerifyKey -> m' (Command 'Broker) -> m' Transmission checkKeySize key action = mkResp corrId queueId - <$> if C.validKeySize $ C.publicKeySize key + <$> if C.validKeySize key then action else pure . ERR $ CMD KEY_SIZE diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 83f2f2633..f414c71e3 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -30,7 +30,7 @@ data ServerConfig = ServerConfig msgIdBytes :: Int, storeLog :: Maybe (StoreLog 'ReadMode), blockSize :: Int, - serverPrivateKey :: C.PrivateKey + serverPrivateKey :: C.PrivateKey 'C.RSA -- serverId :: ByteString } @@ -40,7 +40,7 @@ data Env = Env queueStore :: QueueStore, msgStore :: STMMsgStore, idsDrg :: TVar ChaChaDRG, - serverKeyPair :: C.KeyPair, + serverKeyPair :: C.KeyPair 'C.RSA, storeLog :: Maybe (StoreLog 'WriteMode) } @@ -94,7 +94,7 @@ newEnv config = do idsDrg <- drgNew >>= newTVarIO s' <- restoreQueues queueStore `mapM` storeLog (config :: ServerConfig) let pk = serverPrivateKey config - serverKeyPair = (C.publicKey' pk, pk) + serverKeyPair = (C.publicKey pk, pk) return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair, storeLog = s'} where restoreQueues :: QueueStore -> StoreLog 'ReadMode -> m (StoreLog 'WriteMode) diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 9f7fb5552..2a0d23929 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -62,33 +62,33 @@ storeLogRecordP = <|> "DELETE " *> (DeleteQueue <$> base64P) where createQueueP = CreateQueue <$> queueRecP - secureQueueP = SecureQueue <$> base64P <* A.space <*> C.pubKeyP + secureQueueP = SecureQueue <$> base64P <* A.space <*> C.strKeyP addNotifierP = - AddNotifier <$> base64P <* A.space <*> base64P <* A.space <*> C.pubKeyP + AddNotifier <$> base64P <* A.space <*> base64P <* A.space <*> C.strKeyP queueRecP = do recipientId <- "rid=" *> base64P <* A.space senderId <- "sid=" *> base64P <* A.space - recipientKey <- "rk=" *> C.pubKeyP <* A.space - senderKey <- "sk=" *> optional C.pubKeyP - notifier <- optional $ (,) <$> (" nid=" *> base64P) <*> (" nk=" *> C.pubKeyP) + recipientKey <- "rk=" *> C.strKeyP <* A.space + senderKey <- "sk=" *> optional C.strKeyP + notifier <- optional $ (,) <$> (" nid=" *> base64P) <*> (" nk=" *> C.strKeyP) pure QueueRec {recipientId, senderId, recipientKey, senderKey, notifier, status = QueueActive} serializeStoreLogRecord :: StoreLogRecord -> ByteString serializeStoreLogRecord = \case CreateQueue q -> "CREATE " <> serializeQueue q - SecureQueue rId sKey -> "SECURE " <> encode rId <> " " <> C.serializePubKey sKey - AddNotifier rId nId nKey -> B.unwords ["NOTIFIER", encode rId, encode nId, C.serializePubKey nKey] + SecureQueue rId sKey -> "SECURE " <> encode rId <> " " <> C.serializeKey sKey + AddNotifier rId nId nKey -> B.unwords ["NOTIFIER", encode rId, encode nId, C.serializeKey nKey] DeleteQueue rId -> "DELETE " <> encode rId where serializeQueue QueueRec {recipientId, senderId, recipientKey, senderKey, notifier} = B.unwords [ "rid=" <> encode recipientId, "sid=" <> encode senderId, - "rk=" <> C.serializePubKey recipientKey, - "sk=" <> maybe "" C.serializePubKey senderKey + "rk=" <> C.serializeKey recipientKey, + "sk=" <> maybe "" C.serializeKey senderKey ] <> maybe "" serializeNotifier notifier - serializeNotifier (nId, nKey) = " nid=" <> encode nId <> " nk=" <> C.serializePubKey nKey + serializeNotifier (nId, nKey) = " nid=" <> encode nId <> " nk=" <> C.serializeKey nKey openWriteStoreLog :: FilePath -> IO (StoreLog 'WriteMode) openWriteStoreLog f = WriteStoreLog f <$> openFile f WriteMode diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 6c15576b6..603045fbf 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -345,7 +346,7 @@ makeNextIV SessionKey {baseIV, counter} = atomically $ do -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a -- -- The numbers in function names refer to the steps in the document. -serverHandshake :: forall c. Transport c => c -> Int -> C.KeyPair -> ExceptT TransportError IO (THandle c) +serverHandshake :: forall c. Transport c => c -> Int -> C.KeyPair 'C.RSA -> ExceptT TransportError IO (THandle c) serverHandshake c srvBlockSize (k, pk) = do checkValidBlockSize srvBlockSize liftIO sendHeaderAndPublicKey_1 @@ -358,13 +359,13 @@ serverHandshake c srvBlockSize (k, pk) = do where sendHeaderAndPublicKey_1 :: IO () sendHeaderAndPublicKey_1 = do - let sKey = C.encodePubKey k + let sKey = C.encodeKey k header = ServerHeader {blockSize = srvBlockSize, keySize = B.length sKey} cPut c $ binaryServerHeader header cPut c sKey receiveEncryptedKeys_4 :: ExceptT TransportError IO ByteString receiveEncryptedKeys_4 = - liftIO (cGet c $ C.publicKeySize k) >>= \case + liftIO (cGet c $ C.keySize k) >>= \case "" -> throwE $ TEHandshake TERMINATED ks -> pure ks decryptParseKeys_5 :: ByteString -> ExceptT TransportError IO ClientHandshake @@ -390,7 +391,7 @@ clientHandshake c blkSize_ keyHash = do getWelcome_6 th >>= checkVersion pure th where - getHeaderAndPublicKey_1_2 :: ExceptT TransportError IO (C.PublicKey, Int) + getHeaderAndPublicKey_1_2 :: ExceptT TransportError IO (C.PublicKey 'C.RSA, Int) getHeaderAndPublicKey_1_2 = do header <- liftIO (cGet c serverHeaderSize) ServerHeader {blockSize, keySize} <- liftEither $ parse serverHeaderP (TEHandshake HEADER) header @@ -399,8 +400,8 @@ clientHandshake c blkSize_ keyHash = do maybe (pure ()) (validateKeyHash_2 s) keyHash key <- liftEither $ parseKey s pure (key, blockSize) - parseKey :: ByteString -> Either TransportError C.PublicKey - parseKey = first (const $ TEHandshake RSA_KEY) . parseAll C.binaryPubKeyP + parseKey :: ByteString -> Either TransportError (C.PublicKey 'C.RSA) + parseKey = first (const $ TEHandshake RSA_KEY) . parseAll C.binaryKeyP validateKeyHash_2 :: ByteString -> C.KeyHash -> ExceptT TransportError IO () validateKeyHash_2 k (C.KeyHash kHash) | C.sha256Hash k == kHash = pure () @@ -412,7 +413,7 @@ clientHandshake c blkSize_ keyHash = do aesKey <- C.randomAesKey baseIV <- C.randomIV pure SessionKey {aesKey, baseIV, counter = undefined} - sendEncryptedKeys_4 :: C.PublicKey -> ClientHandshake -> ExceptT TransportError IO () + sendEncryptedKeys_4 :: C.PublicKey 'C.RSA -> ClientHandshake -> ExceptT TransportError IO () sendEncryptedKeys_4 k chs = liftError (const $ TEHandshake ENCRYPT) (C.encryptOAEP k $ serializeClientHandshake chs) >>= liftIO . cPut c diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 83333fea5..d265b5d80 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -149,9 +150,18 @@ testForeignKeysEnabled = cData1 :: ConnData cData1 = ConnData {connId = "conn1"} -testPrivateKey :: C.PrivateKey +testPrivateSignKey :: C.APrivateSignKey +testPrivateSignKey = C.APrivateSignKey C.SRSA testPrivateKey + +testPrivateDecryptKey :: C.APrivateDecryptKey +testPrivateDecryptKey = C.APrivateDecryptKey C.SRSA testPrivateKey + +testPublicEncryptKey :: C.APublicEncryptKey +testPublicEncryptKey = C.APublicEncryptKey C.SRSA $ C.PublicKeyRSA $ R.PublicKey 1 2 3 + +testPrivateKey :: C.PrivateKey 'C.RSA testPrivateKey = - C.PrivateKey + C.PrivateKeyRSA R.PrivateKey { private_pub = R.PublicKey @@ -172,9 +182,9 @@ rcvQueue1 = RcvQueue { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, rcvId = "1234", - rcvPrivateKey = testPrivateKey, + rcvPrivateKey = testPrivateSignKey, sndId = Just "2345", - decryptKey = testPrivateKey, + decryptKey = testPrivateDecryptKey, verifyKey = Nothing, status = New } @@ -184,9 +194,9 @@ sndQueue1 = SndQueue { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, sndId = "3456", - sndPrivateKey = testPrivateKey, - encryptKey = C.PublicKey $ R.PublicKey 1 2 3, - signKey = testPrivateKey, + sndPrivateKey = testPrivateSignKey, + encryptKey = testPublicEncryptKey, + signKey = testPrivateSignKey, status = New } @@ -324,9 +334,9 @@ testUpgradeRcvConnToDuplex = SndQueue { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, sndId = "2345", - sndPrivateKey = testPrivateKey, - encryptKey = C.PublicKey $ R.PublicKey 1 2 3, - signKey = testPrivateKey, + sndPrivateKey = testPrivateSignKey, + encryptKey = testPublicEncryptKey, + signKey = testPrivateSignKey, status = New } upgradeRcvConnToDuplex store "conn1" anotherSndQueue @@ -344,9 +354,9 @@ testUpgradeSndConnToDuplex = RcvQueue { server = SMPServer "smp.simplex.im" (Just "5223") testKeyHash, rcvId = "3456", - rcvPrivateKey = testPrivateKey, + rcvPrivateKey = testPrivateSignKey, sndId = Just "4567", - decryptKey = testPrivateKey, + decryptKey = testPrivateDecryptKey, verifyKey = Nothing, status = New } diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 6892baaea..fdd88725b 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -13,6 +13,7 @@ import Control.Monad.Except (runExceptT) import Control.Monad.IO.Unlift import Crypto.Random import Data.ByteString.Base64 (encode) +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Network.Socket import qualified Simplex.Messaging.Crypto as C @@ -36,7 +37,7 @@ testPort = "5000" testPort2 :: ServiceName testPort2 = "5001" -testKeyHashStr :: B.ByteString +testKeyHashStr :: ByteString testKeyHashStr = "KXNE1m2E1m0lm92WGKet9CL6+lO742Vy5G6nsrkvgs8=" testBlockSize :: Maybe Int @@ -140,8 +141,8 @@ runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients [] run 0 hs = test hs run n hs = testSMPClient $ \h -> run (n - 1) (h : hs) -smpServerTest :: forall c. Transport c => TProxy c -> RawTransmission -> IO RawTransmission -smpServerTest _ cmd = runSmpTest $ \(h :: THandle c) -> tPutRaw h cmd >> tGetRaw h +smpServerTest :: forall c. Transport c => TProxy c -> SignedRawTransmission -> IO SignedRawTransmission +smpServerTest _ t = runSmpTest $ \(h :: THandle c) -> tPutRaw h t >> tGetRaw h smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation smpTest _ test' = runSmpTest test' `shouldReturn` () @@ -167,12 +168,12 @@ smpTest4 _ test' = smpTestN 4 _test _test [h1, h2, h3, h4] = test' h1 h2 h3 h4 _test _ = error "expected 4 handles" -tPutRaw :: Transport c => THandle c -> RawTransmission -> IO () +tPutRaw :: Transport c => THandle c -> SignedRawTransmission -> IO () tPutRaw h (sig, corrId, queueId, command) = do let t = B.intercalate " " [corrId, queueId, command] - void $ tPut h (C.Signature sig, t) + void $ tPut h (sig, t) -tGetRaw :: Transport c => THandle c -> IO RawTransmission +tGetRaw :: Transport c => THandle c -> IO SignedRawTransmission tGetRaw h = do - ("", (CorrId corrId, qId, Right cmd)) <- tGet fromServer h - pure ("", corrId, encode qId, serializeCommand cmd) + (Nothing, (CorrId corrId, qId, Right cmd)) <- tGet fromServer h + pure (Nothing, corrId, encode qId, serializeCommand cmd) diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 7c12b9e18..922636b36 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -44,14 +44,14 @@ serverTests t = do pattern Resp :: CorrId -> QueueId -> Command 'Broker -> SignedTransmissionOrError pattern Resp corrId queueId command <- ("", (corrId, queueId, Right (Cmd SBroker command))) -sendRecv :: Transport c => THandle c -> (ByteString, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError +sendRecv :: Transport c => THandle c -> (Maybe C.ASignature, ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError sendRecv h (sgn, corrId, qId, cmd) = tPutRaw h (sgn, corrId, encode qId, cmd) >> tGet fromServer h -signSendRecv :: Transport c => THandle c -> C.PrivateKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError +signSendRecv :: Transport c => THandle c -> C.APrivateSignKey -> (ByteString, ByteString, ByteString) -> IO SignedTransmissionOrError signSendRecv h pk (corrId, qId, cmd) = do let t = B.intercalate " " [corrId, encode qId, cmd] Right sig <- runExceptT $ C.sign pk t - _ <- tPut h (sig, t) + _ <- tPut h (Just sig, t) tGet fromServer h cmdSEND :: ByteString -> ByteString @@ -64,8 +64,8 @@ testCreateSecure :: ATransport -> Spec testCreateSecure (ATransport t) = it "should create (NEW) and secure (KEY) queue" $ smpTest t $ \h -> do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" rId1 (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + (rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" rId1 (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializeKey rPub) (rId1, "") #== "creates queue" Resp "bcda" sId1 ok1 <- sendRecv h ("", "bcda", sId, "SEND 5 hello ") @@ -81,12 +81,12 @@ testCreateSecure (ATransport t) = Resp "dabc" _ err6 <- signSendRecv h rKey ("dabc", rId, "ACK") (err6, ERR NO_MSG) #== "replies ERR when message acknowledged without messages" - (sPub, sKey) <- C.generateKeyPair rsaKeySize + (sPub, sKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA Resp "abcd" sId2 err1 <- signSendRecv h sKey ("abcd", sId, "SEND 5 hello ") (err1, ERR AUTH) #== "rejects signed SEND" (sId2, sId) #== "same queue ID in response 2" - let keyCmd = "KEY " <> C.serializePubKey sPub + let keyCmd = "KEY " <> C.serializeKey sPub Resp "bcda" _ err2 <- sendRecv h (sampleSig, "bcda", rId, keyCmd) (err2, ERR AUTH) #== "rejects KEY with wrong signature" @@ -116,12 +116,12 @@ testCreateDelete :: ATransport -> Spec testCreateDelete (ATransport t) = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ smpTest2 t $ \rh sh -> do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" rId1 (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + (rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" rId1 (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializeKey rPub) (rId1, "") #== "creates queue" - (sPub, sKey) <- C.generateKeyPair rsaKeySize - Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializePubKey sPub) + (sPub, sKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "bcda" _ ok1 <- signSendRecv rh rKey ("bcda", rId, "KEY " <> C.serializeKey sPub) (ok1, OK) #== "secures queue" Resp "cdab" _ ok2 <- signSendRecv sh sKey ("cdab", sId, "SEND 5 hello ") @@ -184,22 +184,22 @@ testDuplex :: ATransport -> Spec testDuplex (ATransport t) = it "should create 2 simplex connections and exchange messages" $ smpTest2 t $ \alice bob -> do - (arPub, arKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" _ (IDS aRcv aSnd) <- signSendRecv alice arKey ("abcd", "", "NEW " <> C.serializePubKey arPub) + (arPub, arKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" _ (IDS aRcv aSnd) <- signSendRecv alice arKey ("abcd", "", "NEW " <> C.serializeKey arPub) -- aSnd ID is passed to Bob out-of-band - (bsPub, bsKey) <- C.generateKeyPair rsaKeySize - Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, cmdSEND $ "key " <> C.serializePubKey bsPub) + (bsPub, bsKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "bcda" _ OK <- sendRecv bob ("", "bcda", aSnd, cmdSEND $ "key " <> C.serializeKey bsPub) -- "key ..." is ad-hoc, different from SMP protocol Resp "" _ (MSG _ _ msg1) <- tGet fromServer alice Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, "ACK") ["key", bobKey] <- return $ B.words msg1 - (bobKey, C.serializePubKey bsPub) #== "key received from Bob" + (bobKey, C.serializeKey bsPub) #== "key received from Bob" Resp "dabc" _ OK <- signSendRecv alice arKey ("dabc", aRcv, "KEY " <> bobKey) - (brPub, brKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" _ (IDS bRcv bSnd) <- signSendRecv bob brKey ("abcd", "", "NEW " <> C.serializePubKey brPub) + (brPub, brKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" _ (IDS bRcv bSnd) <- signSendRecv bob brKey ("abcd", "", "NEW " <> C.serializeKey brPub) Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, cmdSEND $ "reply_id " <> encode bSnd) -- "reply_id ..." is ad-hoc, it is not a part of SMP protocol @@ -208,14 +208,14 @@ testDuplex (ATransport t) = ["reply_id", bId] <- return $ B.words msg2 (bId, encode bSnd) #== "reply queue ID received from Bob" - (asPub, asKey) <- C.generateKeyPair rsaKeySize - Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, cmdSEND $ "key " <> C.serializePubKey asPub) + (asPub, asKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, cmdSEND $ "key " <> C.serializeKey asPub) -- "key ..." is ad-hoc, different from SMP protocol Resp "" _ (MSG _ _ msg3) <- tGet fromServer bob Resp "abcd" _ OK <- signSendRecv bob brKey ("abcd", bRcv, "ACK") ["key", aliceKey] <- return $ B.words msg3 - (aliceKey, C.serializePubKey asPub) #== "key received from Alice" + (aliceKey, C.serializeKey asPub) #== "key received from Alice" Resp "bcda" _ OK <- signSendRecv bob brKey ("bcda", bRcv, "KEY " <> aliceKey) Resp "cdab" _ OK <- signSendRecv bob bsKey ("cdab", aSnd, "SEND 8 hi alice ") @@ -234,8 +234,8 @@ testSwitchSub :: ATransport -> Spec testSwitchSub (ATransport t) = it "should create simplex connections and switch subscription to another TCP connection" $ smpTest3 t $ \rh1 rh2 sh -> do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" _ (IDS rId sId) <- signSendRecv rh1 rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + (rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" _ (IDS rId sId) <- signSendRecv rh1 rKey ("abcd", "", "NEW " <> C.serializeKey rPub) Resp "bcda" _ ok1 <- sendRecv sh ("", "bcda", sId, "SEND 5 test1 ") (ok1, OK) #== "sent test message 1" Resp "cdab" _ ok2 <- sendRecv sh ("", "cdab", sId, cmdSEND "test2, no ACK") @@ -271,9 +271,9 @@ testSwitchSub (ATransport t) = testWithStoreLog :: ATransport -> Spec testWithStoreLog at@(ATransport t) = it "should store simplex queues to log and restore them after server restart" $ do - (sPub1, sKey1) <- C.generateKeyPair rsaKeySize - (sPub2, sKey2) <- C.generateKeyPair rsaKeySize - (nPub, nKey) <- C.generateKeyPair rsaKeySize + (sPub1, sKey1) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + (sPub2, sKey2) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + (nPub, nKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA senderId1 <- newTVarIO "" senderId2 <- newTVarIO "" notifierId <- newTVarIO "" @@ -281,7 +281,7 @@ testWithStoreLog at@(ATransport t) = withSmpServerStoreLogOn at testPort . runTest t $ \h -> runClient t $ \h1 -> do (sId1, rId, rKey) <- createAndSecureQueue h sPub1 atomically $ writeTVar senderId1 sId1 - Resp "abcd" _ (NID nId) <- signSendRecv h rKey ("abcd", rId, "NKEY " <> C.serializePubKey nPub) + Resp "abcd" _ (NID nId) <- signSendRecv h rKey ("abcd", rId, "NKEY " <> C.serializeKey nPub) atomically $ writeTVar notifierId nId Resp "dabc" _ OK <- signSendRecv h1 nKey ("dabc", nId, "NSUB") Resp "bcda" _ OK <- signSendRecv h sKey1 ("bcda", sId1, "SEND 5 hello ") @@ -332,11 +332,11 @@ testWithStoreLog at@(ATransport t) = Right l -> pure l Left (_ :: SomeException) -> logSize -createAndSecureQueue :: Transport c => THandle c -> SenderPublicKey -> IO (SenderId, RecipientId, C.PrivateKey) +createAndSecureQueue :: Transport c => THandle c -> SenderPublicKey -> IO (SenderId, RecipientId, C.APrivateSignKey) createAndSecureQueue h sPub = do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" "" (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) - let keyCmd = "KEY " <> C.serializePubKey sPub + (rPub, rKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + Resp "abcd" "" (IDS rId sId) <- signSendRecv h rKey ("abcd", "", "NEW " <> C.serializeKey rPub) + let keyCmd = "KEY " <> C.serializeKey sPub Resp "dabc" rId' OK <- signSendRecv h rKey ("dabc", rId, keyCmd) (rId', rId) #== "same queue ID" pure (sId, rId, rKey) @@ -347,54 +347,81 @@ testTiming (ATransport t) = smpTest2 t $ \rh sh -> mapM_ (testSameTiming rh sh) - [ (128, 128, 100), - (128, 256, 25), - (128, 384, 15), - -- (128, 512, 15), - (256, 128, 100), - (256, 256, 25), - (256, 384, 15), - -- (256, 512, 15), - (384, 128, 100), - (384, 256, 25), - (384, 384, 15) - -- (384, 512, 15), - -- (512, 128, 100), - -- (512, 256, 25), + [ (32, 32, 200), + (32, 57, 100), + (32, 128, 40), + (32, 256, 20), + (57, 32, 200), + (57, 57, 100), + (57, 128, 40), + (57, 256, 20), + (128, 32, 200), + (128, 57, 100), + (128, 128, 40), + (128, 256, 20), + (256, 32, 200), + (256, 57, 100), + (256, 128, 40), + (256, 256, 20) + -- (256, 384, 15), + -- (256, 512, 10), + -- (384, 128, 40), + -- (384, 256, 20), + -- (384, 384, 15), + -- (384, 512, 10), + -- (512, 128, 40), + -- (512, 256, 20), -- (512, 384, 15), - -- (512, 512, 15) + -- (512, 512, 10) ] where timeRepeat n = fmap fst . timeItT . forM_ (replicate n ()) . const - similarTime t1 t2 = abs (t1 - t2) / t1 < 0.2 `shouldBe` True + similarTime t1 t2 = abs (t2 / t1 - 1) < 0.25 `shouldBe` True testSameTiming :: Transport c => THandle c -> THandle c -> (Int, Int, Int) -> Expectation - testSameTiming rh sh (senderKeySize, badKeySize, n) = do - (rPub, rKey) <- C.generateKeyPair rsaKeySize - Resp "abcd" "" (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializePubKey rPub) + testSameTiming rh sh (goodKeySize, badKeySize, n) = do + (rPub, rKey) <- generateKeys goodKeySize + Resp "abcd" "" (IDS rId sId) <- signSendRecv rh rKey ("abcd", "", "NEW " <> C.serializeKey rPub) + Resp "cdab" _ OK <- signSendRecv rh rKey ("cdab", rId, "SUB") - (sPub, sKey) <- C.generateKeyPair senderKeySize - let keyCmd = "KEY " <> C.serializePubKey sPub + (_, badKey) <- generateKeys badKeySize + -- runTimingTest rh badKey rId "SUB" + + (sPub, sKey) <- generateKeys goodKeySize + let keyCmd = "KEY " <> C.serializeKey sPub Resp "dabc" _ OK <- signSendRecv rh rKey ("dabc", rId, keyCmd) - (_, badKey) <- C.generateKeyPair badKeySize Resp "bcda" _ OK <- signSendRecv sh sKey ("bcda", sId, "SEND 5 hello ") - timeWrongKey <- timeRepeat n $ do - Resp "cdab" _ (ERR AUTH) <- signSendRecv sh badKey ("cdab", sId, "SEND 5 hello ") - return () - timeNoQueue <- timeRepeat n $ do - Resp "dabc" _ (ERR AUTH) <- signSendRecv sh badKey ("dabc", "1234", "SEND 5 hello ") - return () Resp "" _ (MSG _ _ "hello") <- tGet fromServer rh - similarTime timeNoQueue timeWrongKey + runTimingTest sh badKey sId "SEND 5 hello " + where + generateKeys = \case + 32 -> C.generateSignatureKeyPair 0 C.SEd25519 + 57 -> C.generateSignatureKeyPair 0 C.SEd448 + size -> C.generateSignatureKeyPair size C.SRSA + runTimingTest h badKey qId cmd = do + timeWrongKey <- timeRepeat n $ do + Resp "cdab" _ (ERR AUTH) <- signSendRecv h badKey ("cdab", qId, cmd) + return () + timeNoQueue <- timeRepeat n $ do + Resp "dabc" _ (ERR AUTH) <- signSendRecv h badKey ("dabc", "1234", cmd) + return () + -- (putStrLn . unwords . map show) + -- [ fromIntegral goodKeySize, + -- fromIntegral badKeySize, + -- timeWrongKey, + -- timeNoQueue, + -- timeWrongKey / timeNoQueue - 1 + -- ] + similarTime timeNoQueue timeWrongKey testMessageNotifications :: ATransport -> Spec testMessageNotifications (ATransport t) = it "should create simplex connection, subscribe notifier and deliver notifications" $ do - (sPub, sKey) <- C.generateKeyPair rsaKeySize - (nPub, nKey) <- C.generateKeyPair rsaKeySize + (sPub, sKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA + (nPub, nKey) <- C.generateSignatureKeyPair rsaKeySize C.SRSA smpTest4 t $ \rh sh nh1 nh2 -> do (sId, rId, rKey) <- createAndSecureQueue rh sPub - Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, "NKEY " <> C.serializePubKey nPub) + Resp "1" _ (NID nId) <- signSendRecv rh rKey ("1", rId, "NKEY " <> C.serializeKey nPub) Resp "2" _ OK <- signSendRecv nh1 nKey ("2", nId, "NSUB") Resp "3" _ OK <- signSendRecv sh sKey ("3", sId, "SEND 5 hello ") Resp "" _ (MSG _ _ "hello") <- tGet fromServer rh @@ -412,8 +439,8 @@ testMessageNotifications (ATransport t) = samplePubKey :: ByteString samplePubKey = "rsa:MIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEAtn1NI2tPoOGSGfad0aUg0tJ0kG2nzrIPGLiz8wb3dQSJC9xkRHyzHhEE8Kmy2cM4q7rNZIlLcm4M7oXOTe7SC4x59bLQG9bteZPKqXu9wk41hNamV25PWQ4zIcIRmZKETVGbwN7jFMpH7wxLdI1zzMArAPKXCDCJ5ctWh4OWDI6OR6AcCtEj+toCI6N6pjxxn5VigJtwiKhxYpoUJSdNM60wVEDCSUrZYBAuDH8pOxPfP+Tm4sokaFDTIG3QJFzOjC+/9nW4MUjAOFll9PCp9kaEFHJ/YmOYKMWNOCCPvLS6lxA83i0UaardkNLNoFS5paWfTlroxRwOC2T6PwO2ywKBgDjtXcSED61zK1seocQMyGRINnlWdhceD669kIHju/f6kAayvYKW3/lbJNXCmyinAccBosO08/0sUxvtuniIo18kfYJE0UmP1ReCjhMP+O+yOmwZJini/QelJk/Pez8IIDDWnY1qYQsN/q7ocjakOYrpGG7mig6JMFpDJtD6istR" -sampleSig :: ByteString -sampleSig = "\128\207*\159eq\220i!\"\157\161\130\184\226\246\232_\\\170`\180\160\230sI\154\197\211\252\SUB\246\206ELL\t9K\ESC\196?\128\215%\222\148\NAK;9\155f\164\217e\242\156\CAN9\253\r\170\174'w\211\228?\205)\215\150\255\247z\DC115\DC1{\bn\145\rKD,K\230\202d8\233\167|7y\t_S\EM\248\EOT\216\172\167d\181\224)\137\ACKo\197j#c\217\243\228.\167\228\205\144\vr\134" +sampleSig :: Maybe C.ASignature +sampleSig = "gM8qn2Vx3GkhIp2hgrji9uhfXKpgtKDmc0maxdP8GvbORUxMCTlLG8Q/gNcl3pQVOzmbZqTZZfKcGDn9DaquJ3fT5D/NKdeW//d6ETE1EXsIbpENS0QsS+bKZDjpp3w3eQlfUxn4BNisp2S14CmJBm/FaiNj2fPkLqfkzZALcoY=" syntaxTests :: ATransport -> Spec syntaxTests (ATransport t) = do @@ -452,5 +479,5 @@ syntaxTests (ATransport t) = do it "wrong terminator" $ (sampleSig, "bcda", "12345678", cmd <> "=") >#> ("", "bcda", "12345678", "ERR CMD SYNTAX") it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", "ERR CMD NO_AUTH") it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", "ERR CMD NO_AUTH") - (>#>) :: RawTransmission -> RawTransmission -> Expectation + (>#>) :: SignedRawTransmission -> SignedRawTransmission -> Expectation command >#> response = smpServerTest t command `shouldReturn` response