module Network.TLS.Extra.Certificate
( certificateChecks
, certificateVerifyChain
, certificateVerifyAgainst
, certificateSelfSigned
, certificateVerifyDomain
, certificateVerifyValidity
, certificateFingerprint
) where
import Control.Applicative ((<$>))
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Certificate.X509
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.PubKey.HashDescr as HD
import qualified Crypto.PubKey.RSA.PKCS15 as RSA
import qualified Crypto.PubKey.DSA as DSA
import Data.CertificateStore
import Data.Certificate.X509.Cert (oidCommonName)
import Network.TLS (CertificateUsage(..), CertificateRejectReason(..))
import Data.Time.Calendar
import Data.List (find)
import Data.Maybe (fromMaybe)
#if defined(NOCERTVERIFY)
import System.IO (hPutStrLn, stderr, hIsTerminalDevice)
import Control.Monad (when)
#endif
certificateChecks :: [ [X509] -> IO CertificateUsage ] -> [X509] -> IO CertificateUsage
certificateChecks checks x509s =
fromMaybe CertificateUsageAccept . find (CertificateUsageAccept /=) <$> mapM ($ x509s) checks
#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_ :: CertificateStore -> [X509] -> IO CertificateUsage
certificateVerifyChain_ _ _ = do
wvisible <- hIsTerminalDevice stderr
when wvisible $ do
hPutStrLn stderr "tls-extra:Network.TLS.Extra.Certificate"
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_ :: CertificateStore -> [X509] -> IO CertificateUsage
certificateVerifyChain_ _ [] = return $ CertificateUsageReject (CertificateRejectOther "empty chain / no certificates")
certificateVerifyChain_ store (x:xs) =
case findCertificate (certIssuerDN $ x509Cert x) store 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_ store xs
else return $ CertificateUsageReject (CertificateRejectOther "chain doesn't match each other")
#endif
certificateVerifyChain :: CertificateStore -> [X509] -> IO CertificateUsage
certificateVerifyChain store = certificateVerifyChain_ store . 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 _ _ _ _) =
return $ (verifyF sigalg pk) udata esig
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 -> Bool
verifyF (SignatureALG HashMD2 PubKeyALG_RSA) (PubKeyRSA rsak) = RSA.verify HD.hashDescrMD2 rsak
verifyF (SignatureALG HashMD5 PubKeyALG_RSA) (PubKeyRSA rsak) = RSA.verify HD.hashDescrMD5 rsak
verifyF (SignatureALG HashSHA1 PubKeyALG_RSA) (PubKeyRSA rsak) = RSA.verify HD.hashDescrSHA1 rsak
verifyF (SignatureALG HashSHA1 PubKeyALG_DSA) (PubKeyDSA dsak) = dsaSHA1Verify dsak
verifyF _ _ = \_ _ -> False
dsaSHA1Verify pk _ b = DSA.verify SHA1.hash pk asig b
where asig = (0,0)
certificateVerifyDomain :: String -> [X509] -> CertificateUsage
certificateVerifyDomain _ [] = CertificateUsageReject (CertificateRejectOther "empty list")
certificateVerifyDomain fqhn (X509 cert _ _ _ _:_) =
let names = maybe [] ((:[]) . snd) (lookup oidCommonName $ getDistinguishedElements $ 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] -> CertificateUsage
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