tls-extra 0.4.6.1 → 0.4.7

raw patch · 2 files changed

+37/−32 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Network/TLS/Extra/Certificate.hs +36/−31
• tls-extra.cabal +1/−1

@@ -9,6 +9,7 @@ module Network.TLS.Extra.Certificate 	( certificateChecks 	, certificateVerifyChain+	, certificateVerifyChainAgainst 	, certificateVerifyAgainst 	, certificateSelfSigned 	, certificateVerifyDomain@@ -69,37 +70,33 @@ 	-- find a matching certificate that we trust (== installed on the system) 	foundCert <- SysCert.findCertificate (certMatchDN x) 	case foundCert of-		Just sysx509 -> do-			validChain <- certificateVerifyAgainst x sysx509-			if validChain+		Just sysx509 -> +			if certificateVerifyAgainst x sysx509 				then return CertificateUsageAccept-				else return certificateChainDoesntMatch+				else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") 		Nothing      -> case xs of 			[] -> 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_ 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"+			_  -> if certificateVerifyAgainst x (head xs)+				then certificateVerifyChain_ xs+				else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other") #endif +certificateVerifyChainAgainst_ :: [X509] -> [X509] -> TLSCertificateUsage+certificateVerifyChainAgainst_ _ [] = CertificateUsageReject (CertificateRejectOther "empty chain / no certificates")+certificateVerifyChainAgainst_ allCerts (x:xs) = +	-- find a matching certificate that we trust (== installed on the system)+	-- foundCert <- SysCert.findCertificate (certMatchDN x)+	case find (certMatchDN x) allCerts of+		Just sysx509 -> +			if certificateVerifyAgainst x sysx509+				then CertificateUsageAccept+				else CertificateUsageReject (CertificateRejectOther "chain doesn't match each other")+		Nothing -> case xs of+			[] -> CertificateUsageReject CertificateRejectUnknownCA+			_  -> if certificateVerifyAgainst x (head xs)+				then certificateVerifyChainAgainst_ allCerts xs+				else CertificateUsageReject (CertificateRejectOther "chain doesn't match each other")+ -- | verify a certificates chain using the system certificates available. -- -- each certificate of the list is verified against the next certificate, until@@ -123,14 +120,22 @@ 				Nothing    -> x : reorderList xs 				Just found -> x : found : reorderList (filter (/= found) xs) +certificateVerifyChainAgainst :: [X509] -> [X509] -> TLSCertificateUsage+certificateVerifyChainAgainst allCerts = certificateVerifyChainAgainst_ allCerts . reorderList+	where+		reorderList []     = []+		reorderList (x:xs) =+			case find (certMatchDN x) xs of+				Nothing    -> x : reorderList xs+				Just found -> x : found : reorderList (filter (/= found) xs)+ -- | verify a certificate against another one. -- the first certificate need to be signed by the second one for this function to succeed.-certificateVerifyAgainst :: X509 -> X509 -> IO Bool+certificateVerifyAgainst :: X509 -> X509 -> Bool certificateVerifyAgainst ux509@(X509 _ _ _ sigalg sig) (X509 scert _ _ _ _) = do-	let f = verifyF sigalg pk-	case f udata esig of-		Right True -> return True-		_          -> return False+	case verifyF sigalg pk udata esig of+		Right True -> True+		_          -> False 	where 		udata = B.concat $ L.toChunks $ getSigningData ux509 		esig  = B.pack sig

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