yogsototh/hs-tls
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

check that a certificate has the ability to actually sign another certificate.

Browse source 
this is done basically by verifying that the CA is set in basic constraints,
and then that the key usage allow certificate signing.
This commit is contained in:
Vincent Hanquez 2013-01-19 11:41:49 +00:00
parent 0b51f14b80
commit 15885c0649
1 changed files with 24 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
extra/Network/TLS/Extra/Certificate.hs
View file

@ -28,7 +28,7 @@ import qualified Crypto.PubKey.RSA.PKCS15 as RSA
import qualified Crypto.PubKey.DSA as DSA
import Data.CertificateStore
import Data.Certificate.X509.Cert (oidCommonName, extensionGet, certExtensions)
import Data.Certificate.X509.Cert (oidCommonName)
import Network.TLS (CertificateUsage(..), CertificateRejectReason(..))
import Data.Time.Calendar
@ -73,15 +73,31 @@ certificateVerifyChain_ store (x:xs) =
validChain <- certificateVerifyAgainst x sysx509
if validChain
then return CertificateUsageAccept
else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other")
else return certificateChainDoesntMatch
Nothing ->
case xs of
[] -> return $ CertificateUsageReject CertificateRejectUnknownCA
_ -> do
validChain <- certificateVerifyAgainst x (head xs)
if validChain
then certificateVerifyChain_ store xs
else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other")
[] -> return $ CertificateUsageReject CertificateRejectUnknownCA
cert:_ -> do
let exts = certExtensions (x509Cert cert)
case checkCA exts of
Just r -> return r
Nothing -> do
validChain <- certificateVerifyAgainst x cert
if validChain
then certificateVerifyChain_ store xs
else return certificateChainDoesntMatch
where checkCA Nothing = return $ certificateNotAllowedToSign
checkCA (Just es) = do
let kuCanCertSign = case extensionGet es of
Just (ExtKeyUsage l) -> elem KeyUsage_keyCertSign l
Nothing -> False
case extensionGet es of
Just (ExtBasicConstraints True _)
| kuCanCertSign -> Nothing
| otherwise -> Just certificateNotAllowedToSign
_ -> Just certificateNotAllowedToSign
certificateNotAllowedToSign = CertificateUsageReject $ CertificateRejectOther "certificate is not allowed to sign another certificate"
certificateChainDoesntMatch = CertificateUsageReject $ CertificateRejectOther "chain doesn't match each other"
#endif
-- | verify a certificates chain using the system certificates available.