{-# LANGUAGE OverloadedStrings, CPP #-}-- |-- Module : Network.TLS.Extra.Certificate-- License : BSD-style-- Maintainer : Vincent Hanquez <vincent@snarc.org>-- Stability : experimental-- Portability : unknown--moduleNetwork.TLS.Extra.Certificate(certificateChecks,certificateVerifyChain,certificateVerifyChainAgainst,certificateVerifyAgainst,certificateSelfSigned,certificateVerifyDomain,certificateVerifyValidity,certificateFingerprint)whereimportControl.Applicative((<$>))importqualifiedData.ByteStringasBimportqualifiedData.ByteString.LazyasLimportData.Certificate.X509importSystem.Certificate.X509asSysCert-- for signing/verifying certificateimportqualifiedCrypto.Hash.SHA1asSHA1importqualifiedCrypto.Hash.MD2asMD2importqualifiedCrypto.Hash.MD5asMD5importqualifiedCrypto.Cipher.RSAasRSAimportqualifiedCrypto.Cipher.DSAasDSAimportData.Certificate.X509.Cert(oidCommonName)importNetwork.TLS(TLSCertificateUsage(..),TLSCertificateRejectReason(..))importData.Time.CalendarimportData.List(find)importData.Maybe(fromMaybe)#if defined(NOCERTVERIFY)importSystem.IO(hPutStrLn,stderr,hIsTerminalDevice)importControl.Monad(when)#endif-- | Returns 'CertificateUsageAccept' if all the checks pass, or the first -- failure.certificateChecks::[[X509]->IOTLSCertificateUsage]->[X509]->IOTLSCertificateUsagecertificateCheckschecksx509s=fromMaybeCertificateUsageAccept.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 *************"{- on windows and OSX, the trusted certificates are not yet accessible,
- for now, print a big fat warning (better than nothing) and returns true -}certificateVerifyChain_::[X509]->IOTLSCertificateUsagecertificateVerifyChain__=dowvisible<-hIsTerminalDevicestderrwhenwvisible$dohPutStrLnstderr"tls-extra:Network.TLS.Extra.Certificate"hPutStrLnstderr"****************** certificate verify chain doesn't yet work on your platform **********************"hPutStrLnstderr"please consider contributing to the certificate package to fix this issue"returnCertificateUsageAccept#elsecertificateVerifyChain_::[X509]->IOTLSCertificateUsagecertificateVerifyChain_[]=return$CertificateUsageReject(CertificateRejectOther"empty chain / no certificates")certificateVerifyChain_(x:xs)=do-- find a matching certificate that we trust (== installed on the system)foundCert<-SysCert.findCertificate(certMatchDNx)casefoundCertofJustsysx509->ifcertificateVerifyAgainstxsysx509thenreturnCertificateUsageAcceptelsereturn$CertificateUsageReject(CertificateRejectOther"chain doesn't match each other")Nothing->casexsof[]->return$CertificateUsageRejectCertificateRejectUnknownCA_->ifcertificateVerifyAgainstx(headxs)thencertificateVerifyChain_xselsereturn$CertificateUsageReject(CertificateRejectOther"chain doesn't match each other")#endifcertificateVerifyChainAgainst_::[X509]->[X509]->TLSCertificateUsagecertificateVerifyChainAgainst__[]=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)casefind(certMatchDNx)allCertsofJustsysx509->ifcertificateVerifyAgainstxsysx509thenCertificateUsageAcceptelseCertificateUsageReject(CertificateRejectOther"chain doesn't match each other")Nothing->casexsof[]->CertificateUsageRejectCertificateRejectUnknownCA_->ifcertificateVerifyAgainstx(headxs)thencertificateVerifyChainAgainst_allCertsxselseCertificateUsageReject(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-- it can be verified against a system certificate (system certificates are assumed as trusted)---- This helper only check that the chain of certificate is valid, which means that each items-- received are signed by the next one, or by a system certificate. Some extra checks need to-- be done at the user level so that the certificate chain received make sense in the context.---- for example for HTTP, the user should typically verify the certificate subject match the URL-- of connection.---- TODO: verify validity, check revocation list if any, add optional user output to know-- the rejection reason.certificateVerifyChain::[X509]->IOTLSCertificateUsagecertificateVerifyChain=certificateVerifyChain_.reorderListwherereorderList[]=[]reorderList(x:xs)=casefind(certMatchDNx)xsofNothing->x:reorderListxsJustfound->x:found:reorderList(filter(/=found)xs)certificateVerifyChainAgainst::[X509]->[X509]->TLSCertificateUsagecertificateVerifyChainAgainstallCerts=certificateVerifyChainAgainst_allCerts.reorderListwherereorderList[]=[]reorderList(x:xs)=casefind(certMatchDNx)xsofNothing->x:reorderListxsJustfound->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->BoolcertificateVerifyAgainstux509@(X509___sigalgsig)(X509scert____)=docaseverifyFsigalgpkudataesigofRightTrue->True_->Falsewhereudata=B.concat$L.toChunks$getSigningDataux509esig=B.packsigpk=certPubKeyscert-- | Is this certificate self signed?certificateSelfSigned::X509->BoolcertificateSelfSignedx509=certMatchDNx509x509certMatchDN::X509->X509->BoolcertMatchDN(X509testedCert____)(X509issuerCert____)=certSubjectDNissuerCert==certIssuerDNtestedCertverifyF::SignatureALG->PubKey->B.ByteString->B.ByteString->EitherStringBool-- md[245]WithRSAEncryption:---- pkcs-1 OBJECT IDENTIFIER ::= { iso(1) member-body(2) US(840) rsadsi(113549) pkcs(1) 1 }-- rsaEncryption OBJECT IDENTIFIER ::= { pkcs-1 1 }-- md2WithRSAEncryption OBJECT IDENTIFIER ::= { pkcs-1 2 }-- md4WithRSAEncryption OBJECT IDENTIFIER ::= { pkcs-1 3 }-- md5WithRSAEncryption OBJECT IDENTIFIER ::= { pkcs-1 4 }verifyF(SignatureALGHashMD2PubKeyALG_RSA)(PubKeyRSArsak)=rsaVerifyMD2.hashasn1rsakwhereasn1="\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x02\x10"verifyF(SignatureALGHashMD5PubKeyALG_RSA)(PubKeyRSArsak)=rsaVerifyMD5.hashasn1rsakwhereasn1="\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x04\x10"verifyF(SignatureALGHashSHA1PubKeyALG_RSA)(PubKeyRSArsak)=rsaVerifySHA1.hashasn1rsakwhereasn1="\x30\x21\x30\x09\x06\x05\x2b\x0e\x03\x02\x1a\x05\x00\x04\x14"verifyF(SignatureALGHashSHA1PubKeyALG_DSA)(PubKeyDSAdsak)=dsaSHA1VerifydsakverifyF__=(\__->Left"unexpected/wrong signature")dsaSHA1Verifypk_b=either(Left.show)(Right)$DSA.verifyasigSHA1.hashpkbwhereasig=(0,0){- FIXME : need to work out how to get R/S from the bytestring a -}rsaVerifyhhdescpkab=either(Left.show)(Right)$RSA.verifyhhdescpkab-- | Verify that the given certificate chain is application to the given fully qualified host name.certificateVerifyDomain::String->[X509]->TLSCertificateUsagecertificateVerifyDomain_[]=CertificateUsageReject(CertificateRejectOther"empty list")certificateVerifyDomainfqhn(X509cert____:_)=letnames=maybe[]((:[]).snd)(lookupoidCommonName$certSubjectDNcert)++maybe[](maybe[]toAltName.extensionGet)(certExtensionscert)inorUsage$map(matchDomain.splitDot)nameswhereorUsage[]=rejectMisc"FQDN do not match this certificate"orUsage(x:xs)|x==CertificateUsageAccept=CertificateUsageAccept|otherwise=orUsagexstoAltName(ExtSubjectAltNamel)=lmatchDomainl|length(filter(=="")l)>0=rejectMisc"commonname OID got empty subdomain"|headl=="*"=wildcardMatch(reverse$drop1l)|otherwise=ifl==splitDotfqhnthenCertificateUsageAcceptelserejectMisc"FQDN and common name OID do not match"-- only 1 wildcard is valid, and if multiples are present-- they won't have a wildcard meaning but will be match as normal star-- character to the fqhn and inevitably will fail.wildcardMatchl-- <star>.com or <star> is always invalid|lengthl<2=rejectMisc"commonname OID wildcard match too widely"-- <star>.com.<country> is always invalid|length(headl)<=2&&length(head$drop1l)<=3&&lengthl<3=rejectMisc"commonname OID wildcard match too widely"|otherwise=ifl==take(lengthl)(reverse$splitDotfqhn)thenCertificateUsageAcceptelserejectMisc"FQDN and common name OID do not match"splitDot::String->[String]splitDot[]=[""]splitDotx=let(y,z)=break(=='.')xiny:(ifz==""then[]elsesplitDot$drop1z)rejectMiscs=CertificateUsageReject(CertificateRejectOthers)-- | Verify certificate validity period that need to between the bounds of the certificate.-- TODO: maybe should verify whole chain.certificateVerifyValidity::Day->[X509]->TLSCertificateUsagecertificateVerifyValidity_[]=CertificateUsageReject$CertificateRejectOther"empty list"certificateVerifyValidityctime(X509cert____:_)=let((beforeDay,_,_),(afterDay,_,_))=certValiditycertinifbeforeDay<ctime&&ctime<=afterDaythenCertificateUsageAcceptelseCertificateUsageRejectCertificateRejectExpired-- | hash the certificate signing data using the supplied hash function.certificateFingerprint::(L.ByteString->B.ByteString)->X509->B.ByteStringcertificateFingerprinthashx509=hash$getSigningDatax509