module Network.TLS.Extra.Certificate
( certificateChecks
, certificateVerifyChain
, certificateVerifyAgainst
, certificateSelfSigned
, certificateVerifyDomain
, certificateVerifyValidity
, certificateFingerprint
) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Certificate.X509
import System.Certificate.X509 as SysCert
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.Hash.MD2 as MD2
import qualified Crypto.Hash.MD5 as MD5
import qualified Crypto.Cipher.RSA as RSA
import qualified Crypto.Cipher.DSA as DSA
import Data.Certificate.X509Cert (oidCommonName)
import Network.TLS (TLSCertificateUsage(..), TLSCertificateRejectReason(..))
import Data.Time.Calendar
import Data.List (find)
certificateChecks :: [ [X509] -> IO TLSCertificateUsage ] -> [X509] -> IO TLSCertificateUsage
certificateChecks checks x509s = do
r <- sequence $ map (\c -> c x509s) checks
return $ maybe CertificateUsageAccept id $ find ((/=) CertificateUsageAccept) r
#if defined(NOCERTVERIFY)
# warning "********certificate verify chain doesn't yet work on your platform *************"
# warning "********please consider contributing to the certificate to fix this issue *************"
# warning "********getting trusted system certificate is platform dependant *************"
certificateVerifyChain :: [X509] -> IO TLSCertificateUsage
certificateVerifyChain _ = do
putStrLn "****************** certificate verify chain doesn't yet work on your platform **********************"
putStrLn "please consider contributing to the certificate package to fix this issue"
return CertificateUsageAccept
#else
certificateVerifyChain :: [X509] -> IO TLSCertificateUsage
certificateVerifyChain [] = return $ CertificateUsageReject (CertificateRejectOther "empty chain / no certificates")
certificateVerifyChain (x:xs) = do
foundCert <- SysCert.findCertificate (certMatchDN x)
case foundCert of
Just sysx509 -> do
validChain <- certificateVerifyAgainst x sysx509
if validChain
then return CertificateUsageAccept
else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other")
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")
#endif
certificateVerifyAgainst :: X509 -> X509 -> IO 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
where
udata = B.concat $ L.toChunks $ getSigningData ux509
esig = B.pack sig
pk = certPubKey scert
certificateSelfSigned :: X509 -> Bool
certificateSelfSigned x509 = certMatchDN x509 x509
certMatchDN :: X509 -> X509 -> Bool
certMatchDN (X509 testedCert _ _ _ _) (X509 issuerCert _ _ _ _) =
certSubjectDN issuerCert == certIssuerDN testedCert
verifyF :: SignatureALG -> PubKey -> B.ByteString -> B.ByteString -> Either String Bool
verifyF SignatureALG_md2WithRSAEncryption (PubKeyRSA rsak) = rsaVerify MD2.hash asn1 (mkRSA rsak)
where asn1 = "\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x02\x10"
verifyF SignatureALG_md5WithRSAEncryption (PubKeyRSA rsak) = rsaVerify MD5.hash asn1 (mkRSA rsak)
where asn1 = "\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x04\x10"
verifyF SignatureALG_sha1WithRSAEncryption (PubKeyRSA rsak) = rsaVerify SHA1.hash asn1 (mkRSA rsak)
where asn1 = "\x30\x21\x30\x09\x06\x05\x2b\x0e\x03\x02\x1a\x05\x00\x04\x14"
verifyF SignatureALG_dsaWithSHA1 (PubKeyDSA (pub,p,q,g)) = dsaSHA1Verify pk
where
pk = DSA.PublicKey { DSA.public_params = (p,g,q), DSA.public_y = pub }
verifyF _ _ = (\_ _ -> Left "unexpected/wrong signature")
dsaSHA1Verify pk _ b = either (Left . show) (Right) $ DSA.verify asig SHA1.hash pk b
where asig = (0,0)
rsaVerify h hdesc pk a b = either (Left . show) (Right) $ RSA.verify h hdesc pk a b
mkRSA (lenmodulus, modulus, e) =
RSA.PublicKey { RSA.public_sz = lenmodulus, RSA.public_n = modulus, RSA.public_e = e }
certificateVerifyDomain :: String -> [X509] -> TLSCertificateUsage
certificateVerifyDomain _ [] = CertificateUsageReject (CertificateRejectOther "empty list")
certificateVerifyDomain fqhn (X509 cert _ _ _ _:_) =
case lookup oidCommonName $ certSubjectDN cert of
Nothing -> rejectMisc "no commonname OID in certificate cannot match to FQDN"
Just (_, val) -> matchDomain (splitDot val)
where
matchDomain l
| length (filter (== "") l) > 0 = rejectMisc "commonname OID got empty subdomain"
| head l == "*" = wildcardMatch (reverse $ drop 1 l)
| otherwise = if l == splitDot fqhn
then CertificateUsageAccept
else rejectMisc "FQDN and common name OID do not match"
wildcardMatch l
| length l < 2 = rejectMisc "commonname OID wildcard match too widely"
| length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = rejectMisc "commonname OID wildcard match too widely"
| otherwise =
if l == take (length l) (reverse $ splitDot fqhn)
then CertificateUsageAccept
else rejectMisc "FQDN and common name OID do not match"
splitDot :: String -> [String]
splitDot [] = [""]
splitDot x =
let (y, z) = break (== '.') x in
y : (if z == "" then [] else splitDot $ drop 1 z)
rejectMisc s = CertificateUsageReject (CertificateRejectOther s)
certificateVerifyValidity :: Day -> [X509] -> TLSCertificateUsage
certificateVerifyValidity _ [] = CertificateUsageReject $ CertificateRejectOther "empty list"
certificateVerifyValidity ctime (X509 cert _ _ _ _ :_) =
let ((beforeDay,_,_) , (afterDay,_,_)) = certValidity cert in
if beforeDay < ctime && ctime <= afterDay
then CertificateUsageAccept
else CertificateUsageReject CertificateRejectExpired
certificateFingerprint :: (L.ByteString -> B.ByteString) -> X509 -> B.ByteString
certificateFingerprint hash x509 = hash $ getSigningData x509