Add comments and FIXMEs.
This commit is contained in:
Martin Grabmueller
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
|
||||
-- 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
|
||||
certRequested <- usingState_ ctx getClientCertRequest
|
||||
|
|
@ -200,20 +203,39 @@ handshakeClient cparams ctx = do
|
|||
-- When the user has not configured
|
||||
-- client certificates, we do exactly
|
||||
-- that.
|
||||
--
|
||||
sendPacket ctx $ Handshake [Certificates []]
|
||||
|
||||
Just ccp -> do
|
||||
-- FIXME: What shall we do when the
|
||||
-- callback throws an exception?
|
||||
--
|
||||
certChain <- liftIO $ onCertificateRequest ccp req `catch`
|
||||
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
|
||||
(_, Just pk) : _ ->
|
||||
usingState_ ctx $ setClientPrivateKey pk
|
||||
_ ->
|
||||
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)
|
||||
sendPacket ctx $ Handshake [Certificates $ map fst certChain]
|
||||
|
||||
|
|
@ -227,7 +249,10 @@ handshakeClient cparams ctx = do
|
|||
-- 4. Send it to the server.
|
||||
--
|
||||
sendCertificateVerify = do
|
||||
-- Determine cert. request parameters.
|
||||
-- Determine certificate request parameters.
|
||||
-- When no certicicate was requested, do
|
||||
-- nothing.
|
||||
--
|
||||
certRequested <- usingState_ ctx getClientCertRequest
|
||||
case certRequested of
|
||||
Nothing ->
|
||||
|
|
@ -238,7 +263,14 @@ handshakeClient cparams ctx = do
|
|||
-- Fetch the current handshake hash.
|
||||
dig <- usingState_ ctx $ getCertVerifyDigest
|
||||
|
||||
-- FIXME: Need to chek whether the
|
||||
-- server supports RSA signing.
|
||||
|
||||
-- Sign the hash.
|
||||
--
|
||||
-- FIXME: Dows not work yet. RSA
|
||||
-- signing is not used correctly yet.
|
||||
--
|
||||
sigDig <- usingState_ ctx $ signRSA dig
|
||||
|
||||
-- Send the digest
|
||||
|
|
@ -291,6 +323,10 @@ handshakeClient cparams ctx = do
|
|||
|
||||
processCertificateRequest :: MonadIO m => Handshake -> m (RecvState m)
|
||||
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)
|
||||
return $ RecvStateHandshake processServerHelloDone
|
||||
processCertificateRequest p = processServerHelloDone p
|
||||
|
|
@ -383,12 +419,27 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
|||
---
|
||||
recvClientData = runRecvState ctx (RecvStateHandshake processClientCertificate)
|
||||
|
||||
-- When the client sends a certificate, check whether
|
||||
-- it is acceptable for the application.
|
||||
--
|
||||
processClientCertificate (Certificates certs) =
|
||||
-- Note that the following call will throw an
|
||||
-- exception when we did not request a certificate.
|
||||
--
|
||||
withClientCertServer ctx $ \ ccp -> do
|
||||
-- Call application callback to see whether the
|
||||
-- certificate chain is acceptable.
|
||||
--
|
||||
usage <- liftIO $ catch (onClientCertificate ccp certs) rejectOnException
|
||||
case usage of
|
||||
CertificateUsageAccept -> return ()
|
||||
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
|
||||
|
||||
|
||||
|
|
@ -397,10 +448,14 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
|||
processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify
|
||||
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]) =
|
||||
withClientCertServer ctx $ \ ccp -> do
|
||||
dig <- usingState_ ctx $ getCertVerifyDigest
|
||||
|
||||
-- Verify the signature.
|
||||
verif <- usingState_ ctx $ verifyRSA dig bs
|
||||
|
||||
case verif of
|
||||
|
|
@ -408,6 +463,12 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
|||
return ()
|
||||
|
||||
_ -> 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
|
||||
res <- liftIO $ onUnverifiedClientCert ccp arg
|
||||
when (not res) $ do
|
||||
|
|
@ -474,7 +535,13 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
|||
when needKeyXchg $ do
|
||||
let skg = SKX_RSA Nothing
|
||||
sendPacket ctx (Handshake [ServerKeyXchg skg])
|
||||
|
||||
-- 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
|
||||
Nothing ->
|
||||
return ()
|
||||
|
|
|
|||
|
|
@ -91,6 +91,7 @@ decryptRSA econtent = do
|
|||
rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get
|
||||
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 econtent sign = do
|
||||
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)
|
||||
Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent
|
||||
|
||||
-- FIXME: Add support for different hash functions for TLS1.2
|
||||
signRSA :: ByteString -> TLSSt ByteString
|
||||
signRSA content = do
|
||||
st <- get
|
||||
|
|
|
|||
Loading…
Reference in a new issue