Test handshake with client authentication

haskell-tls · Feb 19, 2017 · 0d32cc2 · 0d32cc2
1 parent cffc8c1
commit 0d32cc2
Show file tree

Hide file tree

Showing 2 changed files with 35 additions and 0 deletions.
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)