x509-validation (empty) → 1.4.0
raw patch · 5 files changed
+377/−0 lines, 5 filesdep +asn1-typesdep +basedep +bytestringsetup-changed
Dependencies added: asn1-types, base, bytestring, containers, crypto-pubkey, cryptohash, directory, filepath, mtl, pem, process, time, x509, x509-store
Files
- Data/X509/Validation.hs +233/−0
- Data/X509/Validation/Signature.hs +78/−0
- LICENSE +27/−0
- Setup.hs +2/−0
- x509-validation.cabal +37/−0
+ Data/X509/Validation.hs view
@@ -0,0 +1,233 @@+-- |+-- Module : Data.X509.Validation+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- X.509 Certificate checks and validations routines+--+-- Follows RFC5280 / RFC6818+--+module Data.X509.Validation+ ( FailedReason(..)+ , Parameters(..)+ , Checks(..)+ , defaultChecks+ , validate+ , validateWith+ ) where++import Control.Applicative+import Data.ASN1.Types+import Data.X509+import Data.X509.CertificateStore+import Data.X509.Validation.Signature+import Data.Time.Clock+import Data.Maybe+import Data.List++-- | Possible reason of certificate and chain failure+data FailedReason =+ UnknownCriticalExtension -- ^ certificate contains an unknown critical extension+ | Expired -- ^ validity ends before checking time+ | InFuture -- ^ validity starts after checking time+ | SelfSigned -- ^ certificate is self signed+ | UnknownCA -- ^ unknown Certificate Authority (CA)+ | NotAllowedToSign -- ^ certificate is not allowed to sign+ | NotAnAuthority -- ^ not a CA+ | InvalidSignature -- ^ signature failed+ | NoCommonName -- ^ Certificate doesn't have any common name (CN)+ | InvalidName String -- ^ Invalid name in certificate+ | NameMismatch String -- ^ connection name and certificate do not match+ | InvalidWildcard -- ^ invalid wildcard in certificate+ | EmptyChain -- ^ empty chain of certificate+ deriving (Show,Eq)++data Checks = Checks+ {+ -- | check time validity of every certificate in the chain.+ -- the make sure that current time is between each validity bounds+ -- in the certificate+ checkTimeValidity :: Bool+ -- | Check that no certificate is included that doesn't+ -- unfortunately despite the specification violation, a lots of+ -- real world server serves useless and usually old certificates+ -- that are not relevant to the certificate sent, in their chain.+ , checkStrictOrdering :: Bool+ -- | Check that signing certificate got the CA basic constraint.+ -- this is absolutely not recommended to turn it off.+ , checkCAConstraints :: Bool+ -- | Check the whole certificate chain without stopping at the first failure.+ -- Allow gathering a exhaustive list of failure reasons. if this is+ -- turn off, it's absolutely not safe to ignore a failed reason even it doesn't look serious+ -- (e.g. Expired) as other more serious checks would not have been performed.+ , checkExhaustive :: Bool+ -- | Check the top certificate names matching the fully qualified hostname (FQHN).+ -- it's not recommended to turn this check off, if no other name checks are performed.+ , checkFQHN :: Maybe String+ } deriving (Show,Eq)++-- | Validation parameters+data Parameters = Parameters+ { parameterTime :: UTCTime+ } deriving (Show,Eq)++-- | Default checks to perform+defaultChecks :: String -- ^ fully qualified host name that we need to match in the certificate+ -> Checks+defaultChecks fqhn = Checks+ { checkTimeValidity = True+ , checkStrictOrdering = False+ , checkCAConstraints = True+ , checkExhaustive = False+ , checkFQHN = Just fqhn+ }++-- | validate a certificate chain.+validate :: Checks -> CertificateStore -> CertificateChain -> IO [FailedReason]+validate _ _ (CertificateChain []) = return [EmptyChain]+validate checks store cc@(CertificateChain (_:_)) = do+ params <- Parameters <$> getCurrentTime+ validateWith params store checks cc++-- | Validate a certificate chain with explicit parameters+validateWith :: Parameters -> CertificateStore -> Checks -> CertificateChain -> IO [FailedReason]+validateWith _ _ _ (CertificateChain []) = return [EmptyChain]+validateWith params store checks (CertificateChain (top:rchain)) =+ doNameCheck (checkFQHN checks) top |> doCheckChain 0 top rchain+ where isExhaustive = checkExhaustive checks+ a |> b = exhaustive isExhaustive a b++ doCheckChain :: Int -> SignedCertificate -> [SignedCertificate] -> IO [FailedReason]+ doCheckChain level current chain = do+ r <- doCheckCertificate (getCertificate current)+ -- check if we have a trusted certificate in the store belonging to this issuer.+ return r |> (case findCertificate (certIssuerDN cert) store of+ Just trustedSignedCert -> return $ checkSignature current trustedSignedCert+ Nothing | isSelfSigned cert -> return [SelfSigned]+ | null chain -> return [UnknownCA]+ | otherwise ->+ case findIssuer (certIssuerDN cert) chain of+ Nothing -> return [UnknownCA]+ Just (issuer, remaining) ->+ return (checkCA $ getCertificate issuer)+ |> return (checkSignature current issuer)+ |> doCheckChain (level+1) issuer remaining)+ where cert = getCertificate current+ -- in a strict ordering check the next certificate has to be the issuer.+ -- otherwise we dynamically reorder the chain to have the necessary certificate+ findIssuer issuerDN chain+ | checkStrictOrdering checks =+ case chain of+ [] -> error "not possible"+ (c:cs) | matchSI issuerDN c -> Just (c, cs)+ | otherwise -> Nothing+ | otherwise =+ (\x -> (x, filter (/= x) chain)) `fmap` find (matchSI issuerDN) chain++ checkCA :: Certificate -> [FailedReason]+ checkCA cert+ | allowedSign && allowedCA = []+ | otherwise = if allowedSign then [] else [NotAllowedToSign]+ ++ if allowedCA then [] else [NotAnAuthority]+ where extensions = (certExtensions cert)+ allowedSign = case extensionGet extensions of+ Just (ExtKeyUsage flags) -> KeyUsage_keyCertSign `elem` flags+ Nothing -> False+ allowedCA = case extensionGet extensions of+ Just (ExtBasicConstraints True _) -> True+ _ -> False++ doNameCheck Nothing _ = return []+ doNameCheck (Just fqhn) cert =+ return (validateCertificateName fqhn (getCertificate cert))++ doCheckCertificate cert =+ exhaustiveList (checkExhaustive checks)+ [ (checkTimeValidity checks, return (validateTime (parameterTime params) cert))+ ]+ isSelfSigned :: Certificate -> Bool+ isSelfSigned cert = certSubjectDN cert == certIssuerDN cert++ -- check signature of 'signedCert' against the 'signingCert'+ checkSignature signedCert signingCert =+ case verifySignedSignature signedCert (certPubKey $ getCertificate signingCert) of+ SignaturePass -> []+ _ -> [InvalidSignature]++-- | Validate that the current time is between validity bounds+validateTime :: UTCTime -> Certificate -> [FailedReason]+validateTime currentTime cert+ | currentTime < before = [InFuture]+ | currentTime > after = [Expired]+ | otherwise = []+ where (before, after) = certValidity cert++getNames :: Certificate -> (Maybe String, [String])+getNames cert = (commonName >>= asn1CharacterToString, altNames)+ where commonName = getDnElement DnCommonName $ certSubjectDN cert+ altNames = maybe [] toAltName $ extensionGet $ certExtensions cert+ toAltName (ExtSubjectAltName names) = catMaybes $ map unAltName names+ where unAltName (AltNameDNS s) = Just s+ unAltName _ = Nothing++-- | Validate that the fqhn is matched by at least one name in the certificate.+-- The name can be either the common name or one of the alternative names if+-- the SubjectAltName extension is present.+validateCertificateName :: String -> Certificate -> [FailedReason]+validateCertificateName fqhn cert =+ case commonName of+ Nothing -> [NoCommonName]+ Just cn -> findMatch [] $ map (matchDomain . splitDot) (cn : altNames)+ where (commonName, altNames) = getNames cert++ findMatch :: [FailedReason] -> [[FailedReason]] -> [FailedReason]+ findMatch _ [] = [NameMismatch fqhn]+ findMatch _ ([]:_) = []+ findMatch acc (_ :xs) = findMatch acc xs++ matchDomain :: [String] -> [FailedReason]+ matchDomain l+ | length (filter (== "") l) > 0 = [InvalidName (intercalate "." l)]+ | head l == "*" = wildcardMatch (reverse $ drop 1 l)+ | l == splitDot fqhn = [] -- success: we got a match+ | otherwise = [NameMismatch fqhn]++ -- 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.+ --+ -- e.g. *.*.server.com will try to litteraly match the '*' subdomain of server.com+ wildcardMatch l+ -- <star>.com or <star> is always invalid+ | length l < 2 = [InvalidWildcard]+ -- some TLD like .uk got small subTLS like (.co.uk), and we don't want to accept *.co.uk+ | length (head l) <= 2 && length (head $ drop 1 l) <= 3 && length l < 3 = [InvalidWildcard]+ | l == take (length l) (reverse $ splitDot fqhn) = [] -- success: we got a match+ | otherwise = [NameMismatch fqhn]++ splitDot :: String -> [String]+ splitDot [] = [""]+ splitDot x =+ let (y, z) = break (== '.') x in+ y : (if z == "" then [] else splitDot $ drop 1 z)+++-- | return true if the 'subject' certificate's issuer match+-- the 'issuer' certificate's subject+matchSI :: DistinguishedName -> SignedCertificate -> Bool+matchSI issuerDN issuer = certSubjectDN (getCertificate issuer) == issuerDN++exhaustive :: Monad m => Bool -> m [FailedReason] -> m [FailedReason] -> m [FailedReason]+exhaustive isExhaustive f1 f2 = f1 >>= cont+ where cont l1+ | null l1 = f2+ | isExhaustive = f2 >>= \l2 -> return (l1 ++ l2)+ | otherwise = return l1++exhaustiveList :: Monad m => Bool -> [(Bool, m [FailedReason])] -> m [FailedReason]+exhaustiveList _ [] = return []+exhaustiveList isExhaustive ((performCheck,c):cs)+ | performCheck = exhaustive isExhaustive c (exhaustiveList isExhaustive cs)+ | otherwise = exhaustiveList isExhaustive cs
+ Data/X509/Validation/Signature.hs view
@@ -0,0 +1,78 @@+-- |+-- Module : Data.X509.Validation.Signature+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- X.509 Certificate and CRL signature verification+--+module Data.X509.Validation.Signature+ ( verifySignedSignature+ , verifySignature+ , SignatureVerification(..)+ ) where++import qualified Crypto.PubKey.RSA.PKCS15 as RSA+import qualified Crypto.PubKey.DSA as DSA+import qualified Crypto.Hash.SHA1 as SHA1+import Crypto.PubKey.HashDescr++import Data.ByteString (ByteString)+import Data.X509+import Data.ASN1.Types++-- | A set of possible return from signature verification.+--+-- Only SignaturePass should be accepted as success.+--+-- Other values are only useful to differentiate the failure+-- reason, but are all equivalent to failure.+--+data SignatureVerification =+ SignaturePass -- ^ verification succeeded+ | SignatureFailed -- ^ verification failed+ | SignaturePubkeyMismatch -- ^ algorithm and public key mismatch, cannot proceed+ | SignatureUnimplemented -- ^ unimplemented signature algorithm+ deriving (Show,Eq)++-- | Verify a Signed object against a specified public key+verifySignedSignature :: (Eq a, ASN1Object a) => SignedExact a -> PubKey -> SignatureVerification+verifySignedSignature signedObj pubKey =+ verifySignature (signedAlg signed)+ pubKey+ (getSignedData signedObj)+ (signedSignature signed)+ where signed = getSigned signedObj++-- | verify signature using parameter+verifySignature :: SignatureALG -- ^ Signature algorithm used+ -> PubKey -- ^ Public key to use for verify+ -> ByteString -- ^ Certificate data that need to be verified+ -> ByteString -- ^ Signature to verify+ -> SignatureVerification+verifySignature (SignatureALG_Unknown _) _ _ _ = SignatureUnimplemented+verifySignature (SignatureALG hashALG pubkeyALG) pubkey cdata signature+ | pubkeyToAlg pubkey == pubkeyALG = case verifyF pubkey of+ Nothing -> SignatureUnimplemented+ Just f -> if f cdata signature+ then SignaturePass+ else SignatureFailed+ | otherwise = SignaturePubkeyMismatch+ where+ toDescr HashMD2 = hashDescrMD2+ toDescr HashMD5 = hashDescrMD5+ toDescr HashSHA1 = hashDescrSHA1+ toDescr HashSHA224 = hashDescrSHA224+ toDescr HashSHA256 = hashDescrSHA256+ toDescr HashSHA384 = hashDescrSHA384+ toDescr HashSHA512 = hashDescrSHA512++ verifyF (PubKeyRSA key) = Just $ RSA.verify (toDescr hashALG) key+ verifyF (PubKeyDSA key)+ | hashALG == HashSHA1 && False = Just $ \a -> DSA.verify SHA1.hash key (dsaToSignature a)+ | otherwise = Nothing+ verifyF _ = Nothing++ -- TODO : need to work out how to get R/S from the bytestring+ dsaToSignature _ = (0,0)
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2010-2013 Vincent Hanquez <vincent@snarc.org>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ x509-validation.cabal view
@@ -0,0 +1,37 @@+Name: x509-validation+Version: 1.4.0+Description: X.509 Certificate and CRL validation+License: BSD3+License-file: LICENSE+Copyright: Vincent Hanquez <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: Vincent Hanquez <vincent@snarc.org>+Synopsis: X.509 Certificate and CRL validation+Build-Type: Simple+Category: Data+stability: experimental+Homepage: http://github.com/vincenthz/hs-certificate+Cabal-Version: >=1.6++Library+ Build-Depends: base >= 3 && < 5+ , bytestring+ , mtl+ , pem >= 0.1 && < 0.2+ , asn1-types+ , x509+ , x509-store+ , crypto-pubkey+ , cryptohash+ , containers+ , directory+ , filepath+ , process+ , time+ Exposed-modules: Data.X509.Validation+ Other-modules: Data.X509.Validation.Signature+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/vincenthz/hs-certificate