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:
Martin Grabmueller
parent
4c84e3ffc7
commit
c772ee22d5
5 changed files with 50 additions and 45 deletions
|
|
@ -68,6 +68,7 @@ module Network.TLS.Context
|
|||
) where
|
||||
|
||||
import Network.TLS.Struct
|
||||
import qualified Network.TLS.Struct as Struct
|
||||
import Network.TLS.Session
|
||||
import Network.TLS.Cipher
|
||||
import Network.TLS.Compression
|
||||
|
|
@ -150,6 +151,7 @@ data Params = forall s . SessionManager s => Params
|
|||
, pAllowedVersions :: [Version] -- ^ allowed versions that we can use.
|
||||
, pCiphers :: [Cipher] -- ^ all ciphers 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
|
||||
, pUseSession :: Bool -- ^ generate new session if specified
|
||||
, 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]
|
||||
, pCiphers = []
|
||||
, pCompressions = [nullCompression]
|
||||
, pHashSignatures = [ (Struct.HashSHA512, SignatureRSA)
|
||||
, (Struct.HashSHA384, SignatureRSA)
|
||||
, (Struct.HashSHA256, SignatureRSA)
|
||||
, (Struct.HashSHA224, SignatureRSA)
|
||||
]
|
||||
, pUseSecureRenegotiation = True
|
||||
, pUseSession = True
|
||||
, pCertificates = []
|
||||
|
|
|
|||
|
|
@ -109,18 +109,20 @@ kxDecrypt (PrivRSA pk) b = generalizeRSAError $ RSA.decrypt pk b
|
|||
-- Verify that the signature matches the given message, using the
|
||||
-- public key.
|
||||
--
|
||||
kxVerify :: PublicKey -> ByteString -> ByteString -> Either KxError Bool
|
||||
kxVerify (PubRSA pk) msg sign =
|
||||
let hashF = id
|
||||
hashASN1 = B.empty -- for TLS MD5-SHA1 signatures, no
|
||||
-- algorithm identifier is defined.
|
||||
kxVerify :: PublicKey -> Maybe (ByteString -> ByteString, ByteString) -> ByteString -> ByteString -> Either KxError Bool
|
||||
kxVerify (PubRSA pk) hsh msg sign =
|
||||
let hashF = maybe id fst hsh
|
||||
hashASN1 = maybe B.empty snd hsh -- For TLS MD5-SHA1 signatures,
|
||||
-- no algorithm identifier is
|
||||
-- defined.
|
||||
in generalizeRSAError $ RSA.verify hashF hashASN1 pk msg sign
|
||||
|
||||
-- Sign the given message using the private key.
|
||||
--
|
||||
kxSign :: PrivateKey -> ByteString -> Either KxError ByteString
|
||||
kxSign (PrivRSA pk) msg =
|
||||
let hashF = id
|
||||
hashASN1 = B.empty -- for TLS MD5-SHA1 signatures, no
|
||||
-- algorithm identifier is defined.
|
||||
kxSign :: PrivateKey -> Maybe (ByteString -> ByteString, ByteString) -> ByteString -> Either KxError ByteString
|
||||
kxSign (PrivRSA pk) hsh msg =
|
||||
let hashF = maybe id fst hsh
|
||||
hashASN1 = maybe B.empty snd hsh -- For TLS MD5-SHA1 signatures,
|
||||
-- no algorithm identifier is
|
||||
-- defined.
|
||||
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 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.Monad.State
|
||||
|
|
@ -195,35 +195,21 @@ handshakeClient cparams ctx = do
|
|||
return ()
|
||||
|
||||
Just req -> do
|
||||
-- FIXME: What shall we do when the
|
||||
-- callback throws an exception?
|
||||
--
|
||||
certChain <- liftIO $ onCertificateRequest cparams 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) : _ ->
|
||||
(_, 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
|
||||
_ ->
|
||||
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]
|
||||
|
||||
|
|
@ -246,15 +232,22 @@ handshakeClient cparams ctx = do
|
|||
-- Fetch the current handshake hash.
|
||||
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.
|
||||
|
||||
-- Sign the hash.
|
||||
--
|
||||
-- FIXME: Dows not work yet. RSA
|
||||
-- signing is not used correctly yet.
|
||||
--
|
||||
sigDig <- usingState_ ctx $ signRSA dig
|
||||
sigDig <- usingState_ ctx $ signRSA Nothing dig
|
||||
|
||||
-- Send the digest
|
||||
sendPacket ctx $ Handshake [CertVerify sigDig]
|
||||
|
|
@ -448,7 +441,7 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
|||
dig <- usingState_ ctx $ getCertVerifyDigest
|
||||
|
||||
-- Verify the signature.
|
||||
verif <- usingState_ ctx $ verifyRSA dig bs
|
||||
verif <- usingState_ ctx $ verifyRSA Nothing dig bs
|
||||
|
||||
case verif of
|
||||
Right True -> do
|
||||
|
|
@ -558,7 +551,10 @@ handshakeServerWith sparams ctx clientHello@(ClientHello ver _ clientSession cip
|
|||
--
|
||||
when (serverWantClientCert sparams) $ do
|
||||
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)
|
||||
usingState_ ctx $ setCertReqSent True
|
||||
sendPacket ctx (Handshake [creq])
|
||||
|
|
|
|||
|
|
@ -94,10 +94,10 @@ decryptRSA econtent = do
|
|||
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
|
||||
verifyRSA :: Maybe (ByteString -> ByteString, ByteString) -> ByteString -> ByteString -> TLSSt (Either KxError Bool)
|
||||
verifyRSA hsh econtent sign = do
|
||||
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 (ServerHello sver ran _ _ _ ex) = do
|
||||
|
|
|
|||
|
|
@ -97,11 +97,11 @@ encryptRSA content = do
|
|||
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
|
||||
signRSA :: Maybe (ByteString -> ByteString, ByteString) -> ByteString -> TLSSt ByteString
|
||||
signRSA hsh content = do
|
||||
st <- get
|
||||
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)
|
||||
Right econtent -> return econtent
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue