diff --git a/core/Network/TLS/Context.hs b/core/Network/TLS/Context.hs index 6d8835a95..2cdd0ad61 100644 --- a/core/Network/TLS/Context.hs +++ b/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. diff --git a/core/Network/TLS/Context/Internal.hs b/core/Network/TLS/Context/Internal.hs index 172057623..91396fbaf 100644 --- a/core/Network/TLS/Context/Internal.hs +++ b/core/Network/TLS/Context/Internal.hs @@ -86,6 +86,7 @@ import Control.Exception (throwIO, Exception()) import Data.IORef import Data.Tuple +import Data.X509 -- | Information related to a running context, e.g. current cipher data Information = Information @@ -128,6 +129,7 @@ data Context = Context , ctxPendingActions :: IORef [PendingAction] , ctxCertRequests :: IORef [Handshake13] -- ^ pending PHA requests , ctxKeyLogger :: String -> IO () + , ctxClientCerts :: IORef (Maybe CertificateChain) } data Established = NotEstablished diff --git a/core/Network/TLS/Handshake/Server.hs b/core/Network/TLS/Handshake/Server.hs index 48d69a150..7914654ec 100644 --- a/core/Network/TLS/Handshake/Server.hs +++ b/core/Network/TLS/Handshake/Server.hs @@ -1077,7 +1077,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 diff --git a/core/Network/TLS/Parameters.hs b/core/Network/TLS/Parameters.hs index 0df24e3f3..a4062644e 100644 --- a/core/Network/TLS/Parameters.hs +++ b/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 @@ -442,7 +444,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 @@ -482,7 +484,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