transport, crypto: certificate chain, keys and DH secret (#1964)

src/Simplex/Messaging/Client.hs

@@ -1139,9 +1139,9 @@ connectSMPProxiedRelay c@ProtocolClient {client_ = PClient {tcpConnectTimeout, t
     hostName = B.unpack $ strEncode $ transportHost' c
     validateRelay :: X.CertificateChain -> X.SignedExact X.PubKey -> ExceptT String IO C.PublicKeyX25519
     validateRelay chain exact = case chainIdCaCerts chain of
-      CCValid {leafCert, idCert, caCert}
+      CCValid {leafCert, idCert}
         | XV.Fingerprint kh == XV.getFingerprint idCert X.HashSHA256 -> do
-            errs <- liftIO $ x509validate caCert (hostName, B.pack relayPort) chain
+            errs <- liftIO $ x509validate (hostName, B.pack relayPort) chain
             unless (null errs) $ throwError "bad certificate"
             serverKey <- liftEither $ C.x509ToPublic' $ X.certPubKey $ X.signedObject $ X.getSigned leafCert
             liftEither $ C.x509ToPublic' =<< C.verifyX509 serverKey exact

src/Simplex/Messaging/Crypto.hs

@@ -1343,7 +1343,9 @@ cryptoBox secret nonce s = BA.convert tag <> c
 
 -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce.
 cbDecrypt :: CbNonceI n => DhSecret X25519 -> n -> ByteString -> Either CryptoError ByteString
-cbDecrypt (DhSecretX25519 secret) = sbDecrypt_ secret . toCbNonce
+cbDecrypt (DhSecretX25519 secret) nonce msg
+  | BA.constEq secret (B.replicate x25519_size '\0') = Left CBDecryptError
+  | otherwise = sbDecrypt_ secret (toCbNonce nonce) msg
 {-# INLINE cbDecrypt #-}
 
 -- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).

src/Simplex/Messaging/Transport/Client.hs

@@ -312,9 +312,9 @@ validateCertificateChain :: C.KeyHash -> HostName -> ByteString -> X.Certificate
 validateCertificateChain (C.KeyHash kh) host port cc = case chainIdCaCerts cc of
   CCEmpty -> pure [XV.EmptyChain]
   CCSelf _ -> pure [XV.EmptyChain]
-  CCValid {idCert, caCert} -> validate idCert caCert
+  CCValid {idCert} -> validate idCert
   CCLong -> pure [XV.AuthorityTooDeep]
   where
-    validate idCert caCert
-      | Fingerprint kh == XV.getFingerprint idCert X.HashSHA256 = x509validate caCert (host, port) cc
+    validate idCert
+      | Fingerprint kh == XV.getFingerprint idCert X.HashSHA256 = x509validate (host, port) cc
       | otherwise = pure [XV.UnknownCA]

src/Simplex/Messaging/Transport/Server.hs

@@ -289,11 +289,11 @@ paramsAskClientCert clientCert params =
 validateClientCertificate :: X.CertificateChain -> IO (Maybe T.CertificateRejectReason)
 validateClientCertificate cc = case chainIdCaCerts cc of
   CCEmpty -> pure Nothing -- client certificates are only used for services
-  CCSelf cert -> validate cert
-  CCValid {caCert} -> validate caCert
+  CCSelf _ -> validate
+  CCValid {} -> validate
   CCLong -> pure $ Just $ T.CertificateRejectOther "chain too long"
   where
-    validate caCert = usage <$> x509validate caCert ("", B.empty) cc
+    validate = usage <$> x509validate ("", B.empty) cc
     usage [] = Nothing
     usage r =
       Just $

src/Simplex/Messaging/Transport/Shared.hs

@@ -12,33 +12,48 @@ module Simplex.Messaging.Transport.Shared
 import Control.Concurrent.STM
 import qualified Control.Exception as E
 import Control.Logger.Simple (logError)
+import qualified Crypto.PubKey.RSA as RSA
 import Data.ByteString (ByteString)
 import qualified Data.X509 as X
 import qualified Data.X509.CertificateStore as XS
 import qualified Data.X509.Validation as XV
 import Network.Socket (HostName)
+import Time.System (dateCurrent)
 
 data ChainCertificates
   = CCEmpty
   | CCSelf X.SignedCertificate
-  | CCValid {leafCert :: X.SignedCertificate, idCert :: X.SignedCertificate, caCert :: X.SignedCertificate}
+  | CCValid {leafCert :: X.SignedCertificate, idCert :: X.SignedCertificate}
   | CCLong
 
 chainIdCaCerts :: X.CertificateChain -> ChainCertificates
 chainIdCaCerts (X.CertificateChain chain) = case chain of
   [] -> CCEmpty
   [cert] -> CCSelf cert
-  [leafCert, cert] -> CCValid {leafCert, idCert = cert, caCert = cert} -- current long-term online/offline certificates chain
-  [leafCert, idCert, caCert] -> CCValid {leafCert, idCert, caCert} -- with additional operator certificate (preset in the client)
-  [leafCert, idCert, _, caCert] -> CCValid {leafCert, idCert, caCert} -- with network certificate
+  [leafCert, idCert] -> CCValid {leafCert, idCert} -- current long-term online/offline certificates chain
+  [leafCert, idCert, _] -> CCValid {leafCert, idCert} -- with additional operator certificate (preset in the client)
+  [leafCert, idCert, _, _] -> CCValid {leafCert, idCert} -- with network certificate
   _ -> CCLong
 
-x509validate :: X.SignedCertificate -> (HostName, ByteString) -> X.CertificateChain -> IO [XV.FailedReason]
-x509validate caCert serviceID = XV.validate X.HashSHA256 XV.defaultHooks checks certStore noCache serviceID
+x509validate :: (HostName, ByteString) -> X.CertificateChain -> IO [XV.FailedReason]
+x509validate _ (X.CertificateChain []) = pure [XV.EmptyChain]
+x509validate serviceID (X.CertificateChain certs)
+  | all (supportedKey . X.certPubKey . X.getCertificate) certs = concat <$> sequence (zipWith signedBy certs (drop 1 certs) <> [validateTop])
+  | otherwise = pure [XV.InvalidSignature XV.SignatureUnimplemented]
   where
+    top = last certs
+    validateTop
+      | length certs <= 2 = signedBy top top
+      | otherwise = (\now -> XV.hookValidateTime XV.defaultHooks now $ X.getCertificate top) <$> dateCurrent
+    signedBy cert issuer = XV.validate X.HashSHA256 XV.defaultHooks checks (XS.makeCertificateStore [issuer]) noCache serviceID (X.CertificateChain [cert])
     checks = XV.defaultChecks {XV.checkFQHN = False}
-    certStore = XS.makeCertificateStore [caCert]
     noCache = XV.ValidationCache (\_ _ _ -> pure XV.ValidationCacheUnknown) (\_ _ _ -> pure ())
+    supportedKey = \case
+      X.PubKeyEd25519 _ -> True
+      X.PubKeyEd448 _ -> True
+      X.PubKeyEC X.PubKeyEC_Named {} -> True
+      X.PubKeyRSA k -> RSA.public_size k <= 512 && RSA.public_e k > 0 && RSA.public_e k < 2 ^ (32 :: Int)
+      _ -> False
 
 takePeerCertChain :: TMVar (Maybe X.CertificateChain) -> IO (X.CertificateChain)
 takePeerCertChain peerCert =

tests/AgentTests/FunctionalAPITests.hs

@@ -65,6 +65,8 @@ import Control.Concurrent (forkIO, killThread, threadDelay)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
+import Crypto.Error (throwCryptoError)
+import qualified Crypto.PubKey.Curve25519 as X25519
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
@@ -98,7 +100,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction)
 import Simplex.Messaging.Agent.Store.Interface
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError (..))
-import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig)
+import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig, defaultSMPClientConfig, getProtocolClient, sendSMPMessage)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
@@ -346,8 +348,9 @@ functionalAPITests ps = do
     testPQMatrix2 ps $ runAgentClientTestPQ True
   describe "Establishing duplex connection v2, different Ratchet versions" $
     testRatchetMatrix2 ps runAgentClientTest
-  describe "Establish duplex connection via contact address" $
+  describe "Establish duplex connection via contact address" $ do
     testMatrix2 ps runAgentClientContactTest
+    it "should not decrypt contact request with zero DH secret" $ testContactRequestZeroSecret ps
   describe "Establish duplex connection via contact address, different PQ settings" $ do
     testPQMatrix2NoInv ps $ runAgentClientContactTestPQ True True
   describe "Establish duplex connection via contact address v2, different Ratchet versions" $
@@ -1054,6 +1057,25 @@ runAgentClientContactTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
   where
     msgId = subtract baseId . fst
 
+testContactRequestZeroSecret :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO ()
+testContactRequestZeroSecret ps = withSmpServer ps $ withAgentClients2 $ \alice bob -> do
+  (contactId, qInfo@(CRContactUri ConnReqUriData {crSmpQueues = SMPQueueUri _ SMPQueueAddress {senderId} :| _} _)) <- runRight $ createConnection alice 1 True SCMContact Nothing SMSubscribe
+  (_, cReq) <- runRight $ createConnection bob 1 True SCMInvitation Nothing SMSubscribe
+  g <- C.newRandom
+  (_, pk) <- atomically $ C.generateKeyPair g
+  nonce <- atomically $ C.randomCbNonce g
+  let k = C.PublicKeyX25519 . throwCryptoError . X25519.publicKey $ B.replicate 32 '\0'
+      inv = AgentInvitation {agentVersion = currentSMPAgentVersion, connReq = cReq, connInfo = "bob's connInfo"}
+  Right encBody <- pure $ C.cbEncrypt (C.dh' k pk) nonce (smpEncode $ SMP.ClientMessage SMP.PHEmpty $ smpEncode inv) SMP.e2eEncConfirmationLength
+  let msg = smpEncode $ SMP.ClientMsgEnvelope (SMP.PubHeader SMP.currentSMPClientVersion (Just k)) nonce encBody
+  ts <- getCurrentTime
+  smp <- either (fail . show) pure =<< getProtocolClient g NRMInteractive (1, testSMPServer, Nothing) defaultSMPClientConfig [] Nothing ts (\_ -> pure ())
+  runRight_ $ sendSMPMessage smp NRMInteractive Nothing senderId SMP.noMsgFlags msg
+  get alice ##> ("", contactId, ERR $ AGENT $ A_CRYPTO DECRYPT_CB)
+  runRight_ $ do
+    void $ joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
+    get alice =##> \case ("", c, REQ _ _ "bob's connInfo") -> c == contactId; _ -> False
+
 allowConfirmGreet :: HasCallStack => AgentClient -> ConnId -> AgentClient -> ConnId -> ConfirmationId -> InitialKeys -> PQEncryption -> ExceptT AgentErrorType IO ()
 allowConfirmGreet alice bobId bob aliceId confId addrIK pqEnc = do
   allowConnection bob aliceId confId "bob's connInfo"

tests/CoreTests/CryptoTests.hs

@@ -10,6 +10,10 @@ import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
 import Control.Concurrent.STM
 import Control.Exception (bracket, evaluate)
 import Control.Monad.Except
+import Crypto.Error (throwCryptoError)
+import Crypto.Number.Serialize.LE (i2ospOf_)
+import qualified Crypto.PubKey.Curve25519 as X25519
+import qualified Crypto.PubKey.RSA as RSA
 import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -41,6 +45,7 @@ import Simplex.Messaging.Crypto.SNTRUP761.Bindings.RNG (RNGFunc)
 import Simplex.Messaging.Encoding (Large (..), smpDecode, smpEncode)
 import Simplex.Messaging.Encoding.String (strDecode, strEncode)
 import Simplex.Messaging.Transport.Client
+import Simplex.Messaging.Transport.Credentials (genCredentials)
 import System.Timeout (timeout)
 import Test.Hspec hiding (fit, it)
 import Test.Hspec.QuickCheck (modifyMaxSuccess)
@@ -101,7 +106,9 @@ cryptoTests = do
   describe "Ed signatures" $ do
     describe "Ed25519" $ testSignature C.SEd25519
     describe "Ed448" $ testSignature C.SEd448
-  describe "DH X25519 + cryptobox" testDHCryptoBox
+  describe "DH X25519 + cryptobox" $ do
+    testDHCryptoBox
+    it "should not decrypt with zero DH secret" testDHCryptoBoxZeroSecret
   describe "secretbox" testSecretBox
   describe "lazy secretbox" $ do
     testLazySecretBox
@@ -176,6 +183,21 @@ testDHCryptoBox = it "should encrypt / decrypt string with asymmetric DH keys" .
         plain = C.cbDecrypt (C.dh' sk rpk) nonce =<< cipher
      in isRight cipher && cipher /= plain && Right b == plain
 
+testDHCryptoBoxZeroSecret :: IO ()
+testDHCryptoBoxZeroSecret = do
+  g <- C.newRandom
+  (_, pk) <- atomically $ C.generateKeyPair g
+  nonce <- atomically $ C.randomCbNonce g
+  mapM_ (decryptWithKey pk nonce) [u + b | u <- us, b <- [0, 2 ^ (255 :: Int)]]
+  where
+    p = 2 ^ (255 :: Int) - 19
+    us = [0, 1, 325606250916557431795983626356110631294008115727848805560023387167927233504, 39382357235489614581723060781553021112529911719440698176882885853963445705823, p - 1, p, p + 1]
+    decryptWithKey pk nonce u = do
+      let k = C.PublicKeyX25519 . throwCryptoError . X25519.publicKey $ (i2ospOf_ 32 u :: B.ByteString)
+          secret = C.dh' k pk
+      Right cipher <- pure $ C.cbEncrypt secret nonce "hello" 64
+      C.cbDecrypt secret nonce cipher `shouldBe` Left C.CBDecryptError
+
 testSecretBox :: Spec
 testSecretBox = it "should encrypt / decrypt string with a random symmetric key" . ioProperty $ do
   g <- C.newRandom
@@ -292,12 +314,39 @@ testValidateX509 = do
   -- messed up key rotation or other configuration problems
   checkChain [server2, ca] `shouldReturn` [XV.InvalidSignature XV.SignatureInvalid]
 
+  checkChain [server, ca, ca, ca] `shouldReturn` []
+  checkChain [server, ca, ca2] `shouldReturn` [XV.InvalidSignature XV.SignatureInvalid]
+  checkChain [server, ca, ca, ca2] `shouldReturn` [XV.InvalidSignature XV.SignatureInvalid]
+  checkChain [server2, ca, ca2] `shouldReturn` [XV.InvalidSignature XV.SignatureInvalid, XV.InvalidSignature XV.SignatureInvalid]
+
   -- self-signed, unrelated to CA
   ssCreds <- XS.readCertificates "tests/fixtures/ss.crt"
   ssCreds `shouldNotBe` []
   let ss = head ssCreds
   checkChain [ss, ca] `shouldReturn` [XV.SelfSigned]
 
+  let rsaKey = X.PubKeyRSA $ RSA.PublicKey 1024 (2 ^ (8192 :: Int) - 1) 65537
+      rsaCert = fst $ X.objectToSignedExact (\_ -> ("", X.SignatureALG_IntrinsicHash X.PubKeyALG_Ed448, ())) (X.getCertificate server) {X.certPubKey = rsaKey}
+  checkChain [rsaCert, ca] `shouldReturn` [XV.InvalidSignature XV.SignatureUnimplemented]
+
+  g <- C.newRandom
+  root <- genCredentials g Nothing (1, 24) "root"
+  op <- genCredentials g (Just root) (1, 24) "operator"
+  ident <- genCredentials g (Just op) (1, 24) "identity"
+  leaf <- genCredentials g (Just ident) (1, 24) "leaf"
+  expiredOp <- genCredentials g (Just root) (48, -24) "operator"
+  expiredOpIdent <- genCredentials g (Just expiredOp) (1, 24) "identity"
+  expiredOpLeaf <- genCredentials g (Just expiredOpIdent) (1, 24) "leaf"
+  let checkPinned creds = validateCertificateChain (C.KeyHash fp) "localhost" "5223" $ X.CertificateChain $ map snd creds
+        where
+          XV.Fingerprint fp = XV.getFingerprint (snd $ creds !! 1) X.HashSHA256
+  checkPinned [leaf, ident, op] `shouldReturn` []
+  checkPinned [expiredOpLeaf, expiredOpIdent, expiredOp] `shouldReturn` [XV.Expired]
+  checkPinned [leaf, ident] `shouldReturn` [XV.UnknownCA]
+  otherCA <- genCredentials g Nothing (1, 24) "other"
+  otherLeaf <- genCredentials g (Just otherCA) (1, 24) "leaf"
+  checkPinned [otherLeaf, ident, otherCA] `shouldReturn` [XV.UnknownCA, XV.UnknownCA]
+
 testSNTRUP761 :: IO ()
 testSNTRUP761 = do
   drg <- C.newRandom