tls-extra 0.4.6 → 0.4.6.1

raw patch · 2 files changed

+24/−7 lines, 2 files

Files

• Network/TLS/Extra/Certificate.hs +23/−6
• tls-extra.cabal +1/−1

@@ -73,14 +73,31 @@ 			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_ xs-					else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other")+			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_ 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.

@@ -1,5 +1,5 @@ Name:                tls-extra-Version:             0.4.6+Version:             0.4.6.1 Description:    a set of extra definitions, default values and helpers for tls. License:             BSD3