From 15885c0649ceabd2f4d2913df8ac6dc63d6b3b37 Mon Sep 17 00:00:00 2001
From: Vincent Hanquez <vincent@snarc.org>
Date: Sat, 19 Jan 2013 11:41:49 +0000
Subject: [PATCH] check that a certificate has the ability to actually sign
 another certificate.

this is done basically by verifying that the CA is set in basic constraints,
and then that the key usage allow certificate signing.
---
 extra/Network/TLS/Extra/Certificate.hs | 32 +++++++++++++++++++-------
 1 file changed, 24 insertions(+), 8 deletions(-)

diff --git a/extra/Network/TLS/Extra/Certificate.hs b/extra/Network/TLS/Extra/Certificate.hs
index 6286ee4..18301e8 100644
--- a/extra/Network/TLS/Extra/Certificate.hs
+++ b/extra/Network/TLS/Extra/Certificate.hs
@@ -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.