Certificate fallback with TLS13

core/Network/TLS/Handshake/Server.hs

@@ -224,7 +224,7 @@ handshakeServerWithTLS12 sparams ctx chosenVersion allCreds exts ciphers serverN
                                --
                                -- We try to keep certificates supported by the client, but
                                -- fallback to all credentials if this produces no suitable result
-                               -- (see RFC 5246 section 7.4.2 and TLS 1.3 section 4.4.2.2).
+                               -- (see RFC 5246 section 7.4.2 and RFC 8446 section 4.4.2.2).
                                -- The condition is based on resulting (EC)DHE ciphers so that
                                -- filtering credentials does not give advantage to a less secure
                                -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon.
@@ -650,11 +650,18 @@ handshakeServerWithTLS13 sparams ctx chosenVersion allCreds exts clientCiphers _
     case findKeyShare keyShares serverGroups of
       Nothing -> helloRetryRequest sparams ctx chosenVersion usedCipher exts serverGroups clientSession
       Just keyShare -> do
-        -- Deciding signature algorithm
+        -- When deciding signature algorithm and certificate, we try to keep
+        -- certificates supported by the client, but fallback to all credentials
+        -- if this produces no suitable result (see RFC 5246 section 7.4.2 and
+        -- RFC 8446 section 4.4.2.2).
         let hashSigs = hashAndSignaturesInCommon ctx exts
-        (cred, sigAlgo) <- case credentialsFindForSigning13 hashSigs allCreds of
-            Nothing -> throwCore $ Error_Protocol ("credential not found", True, IllegalParameter)
+            cltCreds = filterCredentialsWithHashSignatures exts allCreds
+        (cred, sigAlgo) <- case credentialsFindForSigning13 hashSigs cltCreds of
             Just cs -> return cs
+            Nothing ->
+                case credentialsFindForSigning13 hashSigs allCreds of
+                    Just cs -> return cs
+                    Nothing -> throwCore $ Error_Protocol ("credential not found", True, IllegalParameter)
         let usedHash = cipherHash usedCipher
         doHandshake13 sparams cred ctx chosenVersion usedCipher exts usedHash keyShare sigAlgo clientSession
   where
@@ -1000,7 +1007,6 @@ applicationProtocol ctx exts sparams
   where
     clientALPNSuggest = isJust $ extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts
 
--- fixme: should we use filterCredentialsWithHashSignatures here?
 credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
 credentialsFindForSigning13 hss0 creds = loop hss0
   where

core/Tests/Connection.hs

@@ -13,7 +13,7 @@ module Connection
     , arbitraryClientCredential
     , arbitraryRSACredentialWithUsage
     , isCustomDHParams
-    , leafPublicKey
+    , isLeafRSA
     , readClientSessionRef
     , twoSessionRefs
     , twoSessionManagers
@@ -119,6 +119,11 @@ leafPublicKey :: CertificateChain -> Maybe PubKey
 leafPublicKey (CertificateChain [])       = Nothing
 leafPublicKey (CertificateChain (leaf:_)) = Just (certPubKey $ signedObject $ getSigned leaf)
 
+isLeafRSA :: Maybe CertificateChain -> Bool
+isLeafRSA chain = case chain >>= leafPublicKey of
+                        Just (PubKeyRSA _) -> True
+                        _                  -> False
+
 arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher])
 arbitraryCipherPair connectVersion = do
     serverCiphers      <- arbitraryCiphers `suchThat`

core/Tests/Tests.hs

@@ -348,10 +348,47 @@ prop_handshake_cert_fallback = do
     runTLSPipeSimple (clientParam',serverParam)
     serverChain <- run $ readIORef chainRef
     dssDisallowed `assertEq` isLeafRSA serverChain
-  where
-    isLeafRSA chain = case chain >>= leafPublicKey of
-                          Just (PubKeyRSA _) -> True
-                          _                  -> False
+
+-- Same as above but testing with supportedHashSignatures directly instead of
+-- ciphers, and thus allowing TLS13.  Peers accept RSA with SHA-256 but the
+-- server RSA certificate has a SHA-1 signature.  When DSS is allowed by both
+-- client and server, the DSA certificate is selected.  Otherwise the server
+-- fallbacks to RSA.
+--
+-- Note: DSA and SHA-1 are supposed to be disallowed with TLS13.  Currently this
+-- is not enforced by the library, which is useful to test this scenario until
+-- ECDSA or EdDSA support is added.  SHA-1 could be replaced by another
+-- algorithm.
+prop_handshake_cert_fallback_hs :: PropertyM IO ()
+prop_handshake_cert_fallback_hs = do
+    tls13 <- pick arbitrary
+    let versions = if tls13 then [TLS13] else [TLS12]
+        ciphers  = [ cipher_ECDHE_RSA_AES128GCM_SHA256
+                   , cipher_DHE_DSS_AES128_SHA1
+                   , cipher_TLS13_AES128GCM_SHA256
+                   ]
+        commonHS = [ (HashSHA256, SignatureRSA) ]
+        otherHS  = [ (HashSHA1, SignatureDSS) ]
+    chainRef <- run $ newIORef Nothing
+    clientHS <- pick $ sublistOf otherHS
+    serverHS <- pick $ sublistOf otherHS
+    (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers
+                                            (versions, versions)
+                                            (ciphers, ciphers)
+    let clientParam' = clientParam { clientSupported = (clientSupported clientParam)
+                                       { supportedHashSignatures = commonHS ++ clientHS }
+                                   , clientHooks = (clientHooks clientParam)
+                                       { onServerCertificate = \_ _ _ chain ->
+                                             writeIORef chainRef (Just chain) >> return [] }
+                                   }
+        serverParam' = serverParam { serverSupported = (serverSupported serverParam)
+                                       { supportedHashSignatures = commonHS ++ serverHS }
+                                   }
+        dssDisallowed = (HashSHA1, SignatureDSS) `notElem` clientHS
+                            || (HashSHA1, SignatureDSS) `notElem` serverHS
+    runTLSPipeSimple (clientParam',serverParam')
+    serverChain <- run $ readIORef chainRef
+    dssDisallowed `assertEq` isLeafRSA serverChain
 
 prop_handshake_groups :: PropertyM IO ()
 prop_handshake_groups = do
@@ -576,7 +613,8 @@ main = defaultMain $ testGroup "tls"
             , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures)
             , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites)
             , testProperty "Groups" (monadicIO prop_handshake_groups)
-            , testProperty "Certificate fallback" (monadicIO prop_handshake_cert_fallback)
+            , testProperty "Certificate fallback (ciphers)" (monadicIO prop_handshake_cert_fallback)
+            , testProperty "Certificate fallback (hash and signatures)" (monadicIO prop_handshake_cert_fallback_hs)
             , testProperty "Server key usage" (monadicIO prop_handshake_srv_key_usage)
             , testProperty "Client authentication" (monadicIO prop_handshake_client_auth)
             , testProperty "Client key usage" (monadicIO prop_handshake_clt_key_usage)