Start client certificate support for TLS1.2.
Add some checks for matching cert types, sig/hash algorithms, etc. Remove some obsolete FIXMEs and comments.
This commit is contained in:
parent
4c84e3ffc7
commit
c772ee22d5
5 changed files with 50 additions and 45 deletions
|
@ -68,6 +68,7 @@ module Network.TLS.Context
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Network.TLS.Struct
|
import Network.TLS.Struct
|
||||||
|
import qualified Network.TLS.Struct as Struct
|
||||||
import Network.TLS.Session
|
import Network.TLS.Session
|
||||||
import Network.TLS.Cipher
|
import Network.TLS.Cipher
|
||||||
import Network.TLS.Compression
|
import Network.TLS.Compression
|
||||||
|
@ -150,6 +151,7 @@ data Params = forall s . SessionManager s => Params
|
||||||
, pAllowedVersions :: [Version] -- ^ allowed versions that we can use.
|
, pAllowedVersions :: [Version] -- ^ allowed versions that we can use.
|
||||||
, pCiphers :: [Cipher] -- ^ all ciphers supported ordered by priority.
|
, pCiphers :: [Cipher] -- ^ all ciphers supported ordered by priority.
|
||||||
, pCompressions :: [Compression] -- ^ all compression supported ordered by priority.
|
, pCompressions :: [Compression] -- ^ all compression supported ordered by priority.
|
||||||
|
, pHashSignatures :: [(HashAlgorithm, SignatureAlgorithm)] -- ^ All supported hash/signature algorithms for client certificate verification, ordered by decreasing priority.
|
||||||
, pUseSecureRenegotiation :: Bool -- ^ notify that we want to use secure renegotation
|
, pUseSecureRenegotiation :: Bool -- ^ notify that we want to use secure renegotation
|
||||||
, pUseSession :: Bool -- ^ generate new session if specified
|
, pUseSession :: Bool -- ^ generate new session if specified
|
||||||
, pCertificates :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any.
|
, pCertificates :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any.
|
||||||
|
@ -183,6 +185,11 @@ defaultParamsClient = Params
|
||||||
, pAllowedVersions = [TLS10,TLS11,TLS12]
|
, pAllowedVersions = [TLS10,TLS11,TLS12]
|
||||||
, pCiphers = []
|
, pCiphers = []
|
||||||
, pCompressions = [nullCompression]
|
, pCompressions = [nullCompression]
|
||||||
|
, pHashSignatures = [ (Struct.HashSHA512, SignatureRSA)
|
||||||
|
, (Struct.HashSHA384, SignatureRSA)
|
||||||
|
, (Struct.HashSHA256, SignatureRSA)
|
||||||
|
, (Struct.HashSHA224, SignatureRSA)
|
||||||
|
]
|
||||||
, pUseSecureRenegotiation = True
|
, pUseSecureRenegotiation = True
|
||||||
, pUseSession = True
|
, pUseSession = True
|
||||||
, pCertificates = []
|
, pCertificates = []
|
||||||
|
|
|
@ -109,18 +109,20 @@ kxDecrypt (PrivRSA pk) b = generalizeRSAError $ RSA.decrypt pk b
|
||||||
-- Verify that the signature matches the given message, using the
|
-- Verify that the signature matches the given message, using the
|
||||||
-- public key.
|
-- public key.
|
||||||
--
|
--
|
||||||
kxVerify :: PublicKey -> ByteString -> ByteString -> Either KxError Bool
|
kxVerify :: PublicKey -> Maybe (ByteString -> ByteString, ByteString) -> ByteString -> ByteString -> Either KxError Bool
|
||||||
kxVerify (PubRSA pk) msg sign =
|
kxVerify (PubRSA pk) hsh msg sign =
|
||||||
let hashF = id
|
let hashF = maybe id fst hsh
|
||||||
hashASN1 = B.empty -- for TLS MD5-SHA1 signatures, no
|
hashASN1 = maybe B.empty snd hsh -- For TLS MD5-SHA1 signatures,
|
||||||
-- algorithm identifier is defined.
|
-- no algorithm identifier is
|
||||||
|
-- defined.
|
||||||
in generalizeRSAError $ RSA.verify hashF hashASN1 pk msg sign
|
in generalizeRSAError $ RSA.verify hashF hashASN1 pk msg sign
|
||||||
|
|
||||||
-- Sign the given message using the private key.
|
-- Sign the given message using the private key.
|
||||||
--
|
--
|
||||||
kxSign :: PrivateKey -> ByteString -> Either KxError ByteString
|
kxSign :: PrivateKey -> Maybe (ByteString -> ByteString, ByteString) -> ByteString -> Either KxError ByteString
|
||||||
kxSign (PrivRSA pk) msg =
|
kxSign (PrivRSA pk) hsh msg =
|
||||||
let hashF = id
|
let hashF = maybe id fst hsh
|
||||||
hashASN1 = B.empty -- for TLS MD5-SHA1 signatures, no
|
hashASN1 = maybe B.empty snd hsh -- For TLS MD5-SHA1 signatures,
|
||||||
-- algorithm identifier is defined.
|
-- no algorithm identifier is
|
||||||
|
-- defined.
|
||||||
in generalizeRSAError $ RSA.sign hashF hashASN1 pk msg
|
in generalizeRSAError $ RSA.sign hashF hashASN1 pk msg
|
||||||
|
|
|
@ -33,7 +33,7 @@ import Data.List (intersect, find, intercalate)
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import Data.ByteString.Char8 ()
|
import Data.ByteString.Char8 ()
|
||||||
|
|
||||||
import Data.Certificate.X509(X509, certSubjectDN, x509Cert)
|
import Data.Certificate.X509(X509, certSubjectDN, x509Cert, certPubKey, PubKey(PubKeyRSA))
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
|
@ -195,35 +195,21 @@ handshakeClient cparams ctx = do
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
Just req -> do
|
Just req -> do
|
||||||
-- FIXME: What shall we do when the
|
|
||||||
-- callback throws an exception?
|
|
||||||
--
|
|
||||||
certChain <- liftIO $ onCertificateRequest cparams req `catch`
|
certChain <- liftIO $ onCertificateRequest cparams 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) : _ ->
|
(_, Nothing) : _ ->
|
||||||
|
throwCore $ Error_Misc "no private key available"
|
||||||
|
(cert, Just pk) : _ -> do
|
||||||
|
case certPubKey $ x509Cert cert of
|
||||||
|
PubKeyRSA _ -> return ()
|
||||||
|
_ ->
|
||||||
|
throwCore $ Error_Protocol ("no supported certificate type", True, HandshakeFailure)
|
||||||
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]
|
||||||
|
|
||||||
|
@ -246,15 +232,22 @@ 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
|
when (ver >= TLS12) $ do
|
||||||
|
Just (_, Just hashSigs, _) <- usingState_ ctx $ getClientCertRequest
|
||||||
|
|
||||||
|
let suppHashSigs = pHashSignatures $ ctxParams ctx
|
||||||
|
let hashSigs' = filter (\ a -> a `elem` hashSigs) suppHashSigs
|
||||||
|
liftIO $ putStrLn $ " supported hash sig algorithms: " ++ show hashSigs'
|
||||||
|
|
||||||
|
when (null hashSigs') $ do
|
||||||
|
throwCore $ Error_Protocol ("no hash/signature algorithms in common with the server", True, HandshakeFailure)
|
||||||
|
|
||||||
|
-- FIXME: Need to check whether the
|
||||||
-- server supports RSA signing.
|
-- server supports RSA signing.
|
||||||
|
|
||||||
-- Sign the hash.
|
-- Sign the hash.
|
||||||
--
|
--
|
||||||
-- FIXME: Dows not work yet. RSA
|
sigDig <- usingState_ ctx $ signRSA Nothing dig
|
||||||
-- signing is not used correctly yet.
|
|
||||||
--
|
|
||||||
sigDig <- usingState_ ctx $ signRSA dig
|
|
||||||
|
|
||||||
-- Send the digest
|
-- Send the digest
|
||||||
sendPacket ctx $ Handshake [CertVerify sigDig]
|
sendPacket ctx $ Handshake [CertVerify sigDig]
|
||||||
|
@ -448,7 +441,7 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
||||||
dig <- usingState_ ctx $ getCertVerifyDigest
|
dig <- usingState_ ctx $ getCertVerifyDigest
|
||||||
|
|
||||||
-- Verify the signature.
|
-- Verify the signature.
|
||||||
verif <- usingState_ ctx $ verifyRSA dig bs
|
verif <- usingState_ ctx $ verifyRSA Nothing dig bs
|
||||||
|
|
||||||
case verif of
|
case verif of
|
||||||
Right True -> do
|
Right True -> do
|
||||||
|
@ -558,7 +551,10 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
||||||
--
|
--
|
||||||
when (serverWantClientCert sparams) $ do
|
when (serverWantClientCert sparams) $ do
|
||||||
let certTypes = [ CertificateType_RSA_Sign ]
|
let certTypes = [ CertificateType_RSA_Sign ]
|
||||||
creq = CertRequest certTypes Nothing
|
hashSigs = if ver < TLS12
|
||||||
|
then Nothing
|
||||||
|
else Just (pHashSignatures $ ctxParams ctx)
|
||||||
|
creq = CertRequest certTypes hashSigs
|
||||||
(map extractCAname $ serverCACertificates sparams)
|
(map extractCAname $ serverCACertificates sparams)
|
||||||
usingState_ ctx $ setCertReqSent True
|
usingState_ ctx $ setCertReqSent True
|
||||||
sendPacket ctx (Handshake [creq])
|
sendPacket ctx (Handshake [creq])
|
||||||
|
|
|
@ -94,10 +94,10 @@ decryptRSA econtent = do
|
||||||
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
|
-- FIXME: Add support for different hash functions for TLS1.2
|
||||||
verifyRSA :: ByteString -> ByteString -> TLSSt (Either KxError Bool)
|
verifyRSA :: Maybe (ByteString -> ByteString, ByteString) -> ByteString -> ByteString -> TLSSt (Either KxError Bool)
|
||||||
verifyRSA econtent sign = do
|
verifyRSA hsh 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
|
||||||
return $ kxVerify rsapriv econtent sign
|
return $ kxVerify rsapriv hsh econtent sign
|
||||||
|
|
||||||
processServerHello :: Handshake -> TLSSt ()
|
processServerHello :: Handshake -> TLSSt ()
|
||||||
processServerHello (ServerHello sver ran _ _ _ ex) = do
|
processServerHello (ServerHello sver ran _ _ _ ex) = do
|
||||||
|
|
|
@ -97,11 +97,11 @@ encryptRSA content = do
|
||||||
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
|
-- FIXME: Add support for different hash functions for TLS1.2
|
||||||
signRSA :: ByteString -> TLSSt ByteString
|
signRSA :: Maybe (ByteString -> ByteString, ByteString) -> ByteString -> TLSSt ByteString
|
||||||
signRSA content = do
|
signRSA hsh content = do
|
||||||
st <- get
|
st <- get
|
||||||
let rsakey = fromJust "rsa client private key" $ hstRSAClientPrivateKey $ fromJust "handshake" $ stHandshake st
|
let rsakey = fromJust "rsa client private key" $ hstRSAClientPrivateKey $ fromJust "handshake" $ stHandshake st
|
||||||
case kxSign rsakey content of
|
case kxSign rsakey hsh content of
|
||||||
Left err -> fail ("rsa sign failed: " ++ show err)
|
Left err -> fail ("rsa sign failed: " ++ show err)
|
||||||
Right econtent -> return econtent
|
Right econtent -> return econtent
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue