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.X509.Cert (oidCommonName)
import Network.TLS (TLSCertificateUsage(..), TLSCertificateRejectReason(..))
import Data.Time.Calendar
import Data.List (find)
import Data.Maybe (fromMaybe)
#if defined(NOCERTVERIFY)
import System.IO (hPutStrLn, stderr)
#endif
certificateChecks :: [ [X509] -> IO TLSCertificateUsage ] -> [X509] -> IO TLSCertificateUsage
certificateChecks checks x509s = do
r <- mapM (\c -> c x509s) checks
return $ fromMaybe CertificateUsageAccept $ 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
hPutStrLn stderr "****************** certificate verify chain doesn't yet work on your platform **********************"
hPutStrLn stderr "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
certificateVerifyChain :: [X509] -> IO TLSCertificateUsage
certificateVerifyChain = certificateVerifyChain_ . reorderList
where
reorderList [] = []
reorderList (x:xs) =
case find (certMatchDN x) xs of
Nothing -> x : reorderList xs
Just found -> x : found : reorderList (filter (/= found) xs)
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 HashMD2 PubKeyALG_RSA) (PubKeyRSA rsak) = rsaVerify MD2.hash asn1 rsak
where asn1 = "\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x02\x10"
verifyF (SignatureALG HashMD5 PubKeyALG_RSA) (PubKeyRSA rsak) = rsaVerify MD5.hash asn1 rsak
where asn1 = "\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x04\x10"
verifyF (SignatureALG HashSHA1 PubKeyALG_RSA) (PubKeyRSA rsak) = rsaVerify SHA1.hash asn1 rsak
where asn1 = "\x30\x21\x30\x09\x06\x05\x2b\x0e\x03\x02\x1a\x05\x00\x04\x14"
verifyF (SignatureALG HashSHA1 PubKeyALG_DSA) (PubKeyDSA dsak) = dsaSHA1Verify dsak
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
certificateVerifyDomain :: String -> [X509] -> TLSCertificateUsage
certificateVerifyDomain _ [] = CertificateUsageReject (CertificateRejectOther "empty list")
certificateVerifyDomain fqhn (X509 cert _ _ _ _:_) =
let names = maybe [] ((:[]) . snd) (lookup oidCommonName $ certSubjectDN cert)
++ maybe [] (maybe [] toAltName . extensionGet) (certExtensions cert) in
orUsage $ map (matchDomain . splitDot) names
where
orUsage [] = rejectMisc "FQDN do not match this certificate"
orUsage (x:xs)
| x == CertificateUsageAccept = CertificateUsageAccept
| otherwise = orUsage xs
toAltName (ExtSubjectAltName l) = l
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