Save client certificate into Context

core/Network/TLS.hs

@@ -97,6 +97,8 @@ module Network.TLS
     -- * Advanced APIs
     -- ** Backend
     , ctxConnection
+    , ctxClientCerts
+    , CertificateChain
     , contextFlush
     , contextClose
     -- ** Information gathering
@@ -179,7 +181,7 @@ import Network.TLS.Types
 import Network.TLS.X509
 
 import Data.ByteString as B
-import Data.X509 (PubKey(..), PrivKey(..))
+import Data.X509 (PubKey(..), PrivKey(..), CertificateChain)
 import Data.X509.Validation hiding (HostName)
 
 {-# DEPRECATED Bytes "Use Data.ByteString.Bytestring instead of Bytes." #-}

core/Network/TLS/Context.hs

@@ -157,6 +157,7 @@ contextNew backend params = liftIO $ do
     lockWrite <- newMVar ()
     lockRead  <- newMVar ()
     lockState <- newMVar ()
+    certChain <- newIORef Nothing
 
     return Context
             { ctxConnection   = getBackend backend
@@ -182,6 +183,7 @@ contextNew backend params = liftIO $ do
             , ctxPendingActions   = as
             , ctxCertRequests     = crs
             , ctxKeyLogger        = debugKeyLogger debug
+            , ctxClientCerts      = certChain
             }
 
 -- | create a new context on an handle.

core/Network/TLS/Context/Internal.hs

@@ -79,6 +79,7 @@ import Network.TLS.Measurement
 import Network.TLS.Imports
 import Network.TLS.Types
 import Network.TLS.Util
+import Data.X509 (CertificateChain)
 import qualified Data.ByteString as B
 
 import Control.Concurrent.MVar
@@ -129,6 +130,7 @@ data Context = Context
     , ctxPendingActions   :: IORef [PendingAction]
     , ctxCertRequests     :: IORef [Handshake13]  -- ^ pending PHA requests
     , ctxKeyLogger        :: String -> IO ()
+    , ctxClientCerts      :: IORef (Maybe CertificateChain)
     }
 
 data Established = NotEstablished

core/Network/TLS/Handshake/Common13.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, BangPatterns #-}
+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, BangPatterns, ScopedTypeVariables #-}
 
 -- |
 -- Module      : Network.TLS.Handshake.Common13
@@ -362,7 +362,7 @@ recvHandshake13hash ctx f = do
 
 getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13
 getHandshake13 ctx = RecvHandshake13M $ do
-    currentState <- get
+    currentState :: [Handshake13] <- get
     case currentState of
         (h:hs) -> found h hs
         []     -> recvLoop

core/Network/TLS/Handshake/Server.hs

@@ -1066,7 +1066,8 @@ clientCertificate sparams ctx certs = do
     -- Call application callback to see whether the
     -- certificate chain is acceptable.
     --
-    usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs) rejectOnException
+    let ioref = ctxClientCerts ctx
+    usage <- liftIO $ catchException (onClientCertificate (serverHooks sparams) certs ioref) rejectOnException
     case usage of
         CertificateUsageAccept        -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs
         CertificateUsageReject reason -> certificateRejected reason

core/Network/TLS/Parameters.hs

@@ -26,6 +26,8 @@ module Network.TLS.Parameters
     , CertificateRejectReason(..)
     ) where
 
+import Data.IORef
+
 import Network.TLS.Extension
 import Network.TLS.Struct
 import qualified Network.TLS.Struct as Struct
@@ -440,7 +442,7 @@ data ServerHooks = ServerHooks
       -- The function is not expected to verify the key-usage
       -- extension of the certificate.  This verification is
       -- performed by the library internally.
-      onClientCertificate :: CertificateChain -> IO CertificateUsage
+      onClientCertificate :: CertificateChain -> IORef (Maybe CertificateChain) -> IO CertificateUsage
 
       -- | This action is called when the client certificate
       -- cannot be verified. Return 'True' to accept the certificate
@@ -480,7 +482,7 @@ data ServerHooks = ServerHooks
 defaultServerHooks :: ServerHooks
 defaultServerHooks = ServerHooks
     { onCipherChoosing       = \_ -> head
-    , onClientCertificate    = \_ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected"
+    , onClientCertificate    = \_ _ -> return $ CertificateUsageReject $ CertificateRejectOther "no client certificates expected"
     , onUnverifiedClientCert = return False
     , onServerNameIndication = \_ -> return mempty
     , onNewHandshake         = \_ -> return True