Merge pull request #189 from ocheron/tls11-client-cert

RSA signature in CertificateVerify with TLS < 1.2
haskell-tls · Feb 25, 2017 · bd987ca · bd987ca
2 parents 78714fa + 0d32cc2
commit bd987ca
Show file tree

Hide file tree

Showing 3 changed files with 48 additions and 4 deletions.
diff --git a/core/Network/TLS/Handshake/Signature.hs b/core/Network/TLS/Handshake/Signature.hs
@@ -46,7 +46,7 @@ certificateVerifyCreate :: Context
                         -> IO DigitallySigned
 certificateVerifyCreate ctx usedVersion malg msgs =
     prepareCertificateVerifySignatureData ctx usedVersion malg msgs >>=
-    signatureCreate ctx malg
+    signatureCreateWithHashDescr ctx malg
 
 getHashAndASN1 :: MonadIO m => (HashAlgorithm, SignatureAlgorithm) -> m Hash
 getHashAndASN1 hashSig = case hashSig of
@@ -101,13 +101,22 @@ signatureHashData sig _ = error ("unimplemented signature type: " ++ show sig)
 
 --signatureCreate :: Context -> Maybe HashAndSignatureAlgorithm -> HashDescr -> Bytes -> IO DigitallySigned
 signatureCreate :: Context -> Maybe HashAndSignatureAlgorithm -> CertVerifyData -> IO DigitallySigned
-signatureCreate ctx malg (hashAlg, toSign) = do
-    cc <- usingState_ ctx $ isClientContext
+signatureCreate ctx malg (hashAlg, toSign) =
+    -- in the case of TLS < 1.2, RSA signing, then the data need to be hashed first, as
+    -- the SHA_MD5 algorithm expect an already digested data
     let signData =
             case (malg, hashAlg) of
                 (Nothing, SHA1_MD5) -> hashFinal $ hashUpdate (hashInit SHA1_MD5) toSign
                 _                   -> toSign
-    DigitallySigned malg <$> signPrivate ctx cc hashAlg signData
+    in signatureCreateWithHashDescr ctx malg (hashAlg, signData)
+
+signatureCreateWithHashDescr :: Context
+                             -> Maybe HashAndSignatureAlgorithm
+                             -> CertVerifyData
+                             -> IO DigitallySigned
+signatureCreateWithHashDescr ctx malg (hashDescr, toSign) = do
+    cc <- usingState_ ctx $ isClientContext
+    DigitallySigned malg <$> signPrivate ctx cc hashDescr toSign
 
 signatureVerify :: Context -> DigitallySigned -> SignatureAlgorithm -> Bytes -> IO Bool
 signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) sigAlgExpected toVerifyData = do

diff --git a/core/Tests/Connection.hs b/core/Tests/Connection.hs
@@ -1,6 +1,7 @@
 module Connection
     ( newPairContext
     , arbitraryPairParams
+    , arbitraryClientCredential
     , setPairParamsSessionManager
     , setPairParamsSessionResuming
     , establishDataPipe
@@ -147,6 +148,11 @@ arbitraryPairParams = do
   where
         arbitraryCiphers  = resize (length knownCiphers + 1) $ listOf1 (elements knownCiphers)
 
+arbitraryClientCredential = do
+    let (pubKey, privKey) = getGlobalRSAPair
+    cert <- arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey)
+    return (CertificateChain [cert], PrivKeyRSA privKey)
+
 setPairParamsSessionManager :: SessionManager -> (ClientParams, ServerParams) -> (ClientParams, ServerParams)
 setPairParamsSessionManager manager (clientState, serverState) = (nc,ns)
   where nc = clientState { clientShared = updateSessionManager $ clientShared clientState }

diff --git a/core/Tests/Tests.hs b/core/Tests/Tests.hs
@@ -71,6 +71,34 @@ prop_handshake_initiate = do
             bye ctx
             return ()
 
+prop_handshake_client_auth_initiate :: PropertyM IO ()
+prop_handshake_client_auth_initiate = do
+    (clientParam,serverParam) <- pick arbitraryPairParams
+    cred <- pick arbitraryClientCredential
+    let clientParam' = clientParam { clientHooks = (clientHooks clientParam)
+                                       { onCertificateRequest = \_ -> return $ Just cred }
+                                   }
+        serverParam' = serverParam { serverWantClientCert = True
+                                   , serverHooks = (serverHooks serverParam)
+                                        { onClientCertificate = validateChain cred }
+                                   }
+        params' = (clientParam',serverParam')
+    runTLSPipe params' tlsServer tlsClient
+  where tlsServer ctx queue = do
+            handshake ctx
+            d <- recvDataNonNull ctx
+            writeChan queue d
+            return ()
+        tlsClient queue ctx = do
+            handshake ctx
+            d <- readChan queue
+            sendData ctx (L.fromChunks [d])
+            bye ctx
+            return ()
+        validateChain cred chain
+            | chain == fst cred = return CertificateUsageAccept
+            | otherwise         = return (CertificateUsageReject CertificateRejectUnknownCA)
+
 prop_handshake_npn_initiate :: PropertyM IO ()
 prop_handshake_npn_initiate = do
     (clientParam,serverParam) <- pick arbitraryPairParams
@@ -182,6 +210,7 @@ main = defaultMain $ testGroup "tls"
         tests_handshake = testGroup "Handshakes"
             [ testProperty "setup" (monadicIO prop_pipe_work)
             , testProperty "initiate" (monadicIO prop_handshake_initiate)
+            , testProperty "clientAuthInitiate" (monadicIO prop_handshake_client_auth_initiate)
             , testProperty "npnInitiate" (monadicIO prop_handshake_npn_initiate)
             , testProperty "renegociation" (monadicIO prop_handshake_renegociation)
             , testProperty "resumption" (monadicIO prop_handshake_session_resumption)