Add comments and FIXMEs.
This commit is contained in:
parent
9e710b5e88
commit
f08eb43055
3 changed files with 87 additions and 18 deletions
|
@ -180,7 +180,10 @@ handshakeClient cparams ctx = do
|
||||||
|
|
||||||
-- When the server requests a client certificate, we
|
-- When the server requests a client certificate, we
|
||||||
-- fetch a certificate chain from the callback in the
|
-- fetch a certificate chain from the callback in the
|
||||||
-- client parameters.
|
-- client parameters and send it to the server.
|
||||||
|
-- Additionally, we store the private key associated
|
||||||
|
-- with the first certificate in the chain for later
|
||||||
|
-- use.
|
||||||
--
|
--
|
||||||
sendCertificate = do
|
sendCertificate = do
|
||||||
certRequested <- usingState_ ctx getClientCertRequest
|
certRequested <- usingState_ ctx getClientCertRequest
|
||||||
|
@ -200,20 +203,39 @@ handshakeClient cparams ctx = do
|
||||||
-- When the user has not configured
|
-- When the user has not configured
|
||||||
-- client certificates, we do exactly
|
-- client certificates, we do exactly
|
||||||
-- that.
|
-- that.
|
||||||
|
--
|
||||||
sendPacket ctx $ Handshake [Certificates []]
|
sendPacket ctx $ Handshake [Certificates []]
|
||||||
|
|
||||||
Just ccp -> do
|
Just ccp -> do
|
||||||
-- FIXME: What shall we do when the
|
-- FIXME: What shall we do when the
|
||||||
-- callback throws an exception?
|
-- callback throws an exception?
|
||||||
|
--
|
||||||
certChain <- liftIO $ onCertificateRequest ccp req `catch`
|
certChain <- liftIO $ onCertificateRequest ccp req `catch`
|
||||||
throwMiscErrorOnException "certificate request callback failed"
|
throwMiscErrorOnException "certificate request callback failed"
|
||||||
|
|
||||||
|
-- FIXME: Currently, when the first
|
||||||
|
-- client certificate has no
|
||||||
|
-- associated private key (or when the
|
||||||
|
-- application offered no
|
||||||
|
-- certificates), we simply do not
|
||||||
|
-- install the key for later use.
|
||||||
|
-- This will lead to an error later
|
||||||
|
-- on, but it would propbably better
|
||||||
|
-- to fail explicitly.
|
||||||
|
--
|
||||||
case certChain of
|
case certChain of
|
||||||
(_, Just pk) : _ ->
|
(_, Just pk) : _ ->
|
||||||
usingState_ ctx $ setClientPrivateKey pk
|
usingState_ ctx $ setClientPrivateKey pk
|
||||||
_ ->
|
_ ->
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
|
-- FIXME: Check that we can sign with
|
||||||
|
-- the provided certificate.
|
||||||
|
|
||||||
|
-- FIXME: Check that the certificate
|
||||||
|
-- matches the types requeted by the
|
||||||
|
-- server.
|
||||||
|
|
||||||
usingState_ ctx $ setClientCertSent (not $ null certChain)
|
usingState_ ctx $ setClientCertSent (not $ null certChain)
|
||||||
sendPacket ctx $ Handshake [Certificates $ map fst certChain]
|
sendPacket ctx $ Handshake [Certificates $ map fst certChain]
|
||||||
|
|
||||||
|
@ -227,7 +249,10 @@ handshakeClient cparams ctx = do
|
||||||
-- 4. Send it to the server.
|
-- 4. Send it to the server.
|
||||||
--
|
--
|
||||||
sendCertificateVerify = do
|
sendCertificateVerify = do
|
||||||
-- Determine cert. request parameters.
|
-- Determine certificate request parameters.
|
||||||
|
-- When no certicicate was requested, do
|
||||||
|
-- nothing.
|
||||||
|
--
|
||||||
certRequested <- usingState_ ctx getClientCertRequest
|
certRequested <- usingState_ ctx getClientCertRequest
|
||||||
case certRequested of
|
case certRequested of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
|
@ -238,7 +263,14 @@ handshakeClient cparams ctx = do
|
||||||
-- Fetch the current handshake hash.
|
-- Fetch the current handshake hash.
|
||||||
dig <- usingState_ ctx $ getCertVerifyDigest
|
dig <- usingState_ ctx $ getCertVerifyDigest
|
||||||
|
|
||||||
|
-- FIXME: Need to chek whether the
|
||||||
|
-- server supports RSA signing.
|
||||||
|
|
||||||
-- Sign the hash.
|
-- Sign the hash.
|
||||||
|
--
|
||||||
|
-- FIXME: Dows not work yet. RSA
|
||||||
|
-- signing is not used correctly yet.
|
||||||
|
--
|
||||||
sigDig <- usingState_ ctx $ signRSA dig
|
sigDig <- usingState_ ctx $ signRSA dig
|
||||||
|
|
||||||
-- Send the digest
|
-- Send the digest
|
||||||
|
@ -291,6 +323,10 @@ handshakeClient cparams ctx = do
|
||||||
|
|
||||||
processCertificateRequest :: MonadIO m => Handshake -> m (RecvState m)
|
processCertificateRequest :: MonadIO m => Handshake -> m (RecvState m)
|
||||||
processCertificateRequest (CertRequest cTypes sigAlgs dNames) = do
|
processCertificateRequest (CertRequest cTypes sigAlgs dNames) = do
|
||||||
|
-- When the server requests a client
|
||||||
|
-- certificate, we simply store the
|
||||||
|
-- information for later.
|
||||||
|
--
|
||||||
usingState_ ctx $ setClientCertRequest (cTypes, sigAlgs, dNames)
|
usingState_ ctx $ setClientCertRequest (cTypes, sigAlgs, dNames)
|
||||||
return $ RecvStateHandshake processServerHelloDone
|
return $ RecvStateHandshake processServerHelloDone
|
||||||
processCertificateRequest p = processServerHelloDone p
|
processCertificateRequest p = processServerHelloDone p
|
||||||
|
@ -383,12 +419,27 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
||||||
---
|
---
|
||||||
recvClientData = runRecvState ctx (RecvStateHandshake processClientCertificate)
|
recvClientData = runRecvState ctx (RecvStateHandshake processClientCertificate)
|
||||||
|
|
||||||
|
-- When the client sends a certificate, check whether
|
||||||
|
-- it is acceptable for the application.
|
||||||
|
--
|
||||||
processClientCertificate (Certificates certs) =
|
processClientCertificate (Certificates certs) =
|
||||||
|
-- Note that the following call will throw an
|
||||||
|
-- exception when we did not request a certificate.
|
||||||
|
--
|
||||||
withClientCertServer ctx $ \ ccp -> do
|
withClientCertServer ctx $ \ ccp -> do
|
||||||
|
-- Call application callback to see whether the
|
||||||
|
-- certificate chain is acceptable.
|
||||||
|
--
|
||||||
usage <- liftIO $ catch (onClientCertificate ccp certs) rejectOnException
|
usage <- liftIO $ catch (onClientCertificate ccp certs) rejectOnException
|
||||||
case usage of
|
case usage of
|
||||||
CertificateUsageAccept -> return ()
|
CertificateUsageAccept -> return ()
|
||||||
CertificateUsageReject reason -> certificateRejected reason
|
CertificateUsageReject reason -> certificateRejected reason
|
||||||
|
|
||||||
|
|
||||||
|
-- FIXME: We should check whether the certificate
|
||||||
|
-- matches our request and that we support
|
||||||
|
-- verifying with that certificate.
|
||||||
|
|
||||||
return $ RecvStateHandshake processClientKeyExchange
|
return $ RecvStateHandshake processClientKeyExchange
|
||||||
|
|
||||||
|
|
||||||
|
@ -397,10 +448,14 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
||||||
processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
|
processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
|
||||||
processClientKeyExchange p = unexpected (show p) (Just "client key exchange")
|
processClientKeyExchange p = unexpected (show p) (Just "client key exchange")
|
||||||
|
|
||||||
|
-- Check whether the client correctly signed the handshake.
|
||||||
|
-- If not, ask the application on how to proceed.
|
||||||
|
--
|
||||||
processCertificateVerify (Handshake [CertVerify bs]) =
|
processCertificateVerify (Handshake [CertVerify bs]) =
|
||||||
withClientCertServer ctx $ \ ccp -> do
|
withClientCertServer ctx $ \ ccp -> do
|
||||||
dig <- usingState_ ctx $ getCertVerifyDigest
|
dig <- usingState_ ctx $ getCertVerifyDigest
|
||||||
|
|
||||||
|
-- Verify the signature.
|
||||||
verif <- usingState_ ctx $ verifyRSA dig bs
|
verif <- usingState_ ctx $ verifyRSA dig bs
|
||||||
|
|
||||||
case verif of
|
case verif of
|
||||||
|
@ -408,6 +463,12 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
_ -> do
|
_ -> do
|
||||||
|
-- Either verification failed because of an
|
||||||
|
-- invalid format (with an error message), or
|
||||||
|
-- the signature is wrong. In either case,
|
||||||
|
-- ask the application -- if it wants to
|
||||||
|
-- proceed, we will do that.
|
||||||
|
--
|
||||||
let arg = case verif of Left err -> Just err; _ -> Nothing
|
let arg = case verif of Left err -> Just err; _ -> Nothing
|
||||||
res <- liftIO $ onUnverifiedClientCert ccp arg
|
res <- liftIO $ onUnverifiedClientCert ccp arg
|
||||||
when (not res) $ do
|
when (not res) $ do
|
||||||
|
@ -474,7 +535,13 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
||||||
when needKeyXchg $ do
|
when needKeyXchg $ do
|
||||||
let skg = SKX_RSA Nothing
|
let skg = SKX_RSA Nothing
|
||||||
sendPacket ctx (Handshake [ServerKeyXchg skg])
|
sendPacket ctx (Handshake [ServerKeyXchg skg])
|
||||||
|
|
||||||
-- FIXME we don't do this on a Anonymous server
|
-- FIXME we don't do this on a Anonymous server
|
||||||
|
|
||||||
|
-- When configured, send a certificate request
|
||||||
|
-- with the DNs of all confgure CA
|
||||||
|
-- certificates.
|
||||||
|
--
|
||||||
case pClientCertParamsServer $ ctxParams ctx of
|
case pClientCertParamsServer $ ctxParams ctx of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
return ()
|
return ()
|
||||||
|
|
|
@ -91,6 +91,7 @@ decryptRSA econtent = do
|
||||||
rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get
|
rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get
|
||||||
return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent)
|
return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent)
|
||||||
|
|
||||||
|
-- FIXME: Add support for different hash functions for TLS1.2
|
||||||
verifyRSA :: ByteString -> ByteString -> TLSSt (Either KxError Bool)
|
verifyRSA :: ByteString -> ByteString -> TLSSt (Either KxError Bool)
|
||||||
verifyRSA econtent sign = do
|
verifyRSA econtent sign = do
|
||||||
rsapriv <- fromJust "rsa client public key" . hstRSAClientPublicKey . fromJust "handshake" . stHandshake <$> get
|
rsapriv <- fromJust "rsa client public key" . hstRSAClientPublicKey . fromJust "handshake" . stHandshake <$> get
|
||||||
|
|
|
@ -94,6 +94,7 @@ encryptRSA content = do
|
||||||
Left err -> fail ("rsa encrypt failed: " ++ show err)
|
Left err -> fail ("rsa encrypt failed: " ++ show err)
|
||||||
Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent
|
Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent
|
||||||
|
|
||||||
|
-- FIXME: Add support for different hash functions for TLS1.2
|
||||||
signRSA :: ByteString -> TLSSt ByteString
|
signRSA :: ByteString -> TLSSt ByteString
|
||||||
signRSA content = do
|
signRSA content = do
|
||||||
st <- get
|
st <- get
|
||||||
|
|
Loading…
Reference in a new issue