-- | Validation test suite.
module Main (main) where
import Control.Monad (unless)
import Crypto.Hash.Algorithms
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.ECC.Types as ECC
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PSS as PSS
import Data.ASN1.BinaryEncoding (DER (..))
import Data.ASN1.BitArray (toBitArray)
import Data.ASN1.Encoding (encodeASN1')
import Data.ASN1.Types
import Data.Default
import Data.Monoid
import Data.String (fromString)
import Data.X509
import Data.X509.CertificateStore
import Data.X509.Validation
import qualified Data.ByteString as BS
import Data.Hourglass
import Time.System
import Test.Tasty
import Test.Tasty.HUnit
import Certificate
-- Runtime data, dynamically generated and shared by all test cases --
data RData pub priv = RData
{ rootStore :: CertificateStore
, past :: (DateTime, DateTime)
, present :: (DateTime, DateTime)
, future :: (DateTime, DateTime)
, pastDate :: DateTime
, presentDate :: DateTime
, futureDate :: DateTime
, root :: Pair pub priv
, intermediate :: Pair pub priv
, intermediate0 :: Pair pub priv
, intermediatePast :: Pair pub priv
, intermediateFuture :: Pair pub priv
, keys1 :: Keys pub priv
, keys2 :: Keys pub priv
, keys3 :: Keys pub priv
}
mkDateTime :: Date -> DateTime
mkDateTime d = DateTime d (TimeOfDay 0 0 0 0)
mkStore :: [Pair pub priv] -> CertificateStore
mkStore ps = makeCertificateStore (map pairSignedCert ps)
initData :: Alg pub priv -> IO (RData pub priv)
initData alg = do
today <- timeGetDate <$> timeCurrent
let m3 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = -3}
let m2 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = -2}
let m1 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = -1}
let n1 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = 1}
let n2 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = 2}
let n3 = mkDateTime $ today `dateAddPeriod` mempty{periodYears = 3}
-- two-year validity periods in past, present and future
let vPast = (m3, m1) -- Year-3 .. Year-1
let vPresent = (m1, n1) -- Year-1 .. Year+1
let vFuture = (n1, n3) -- Year+1 .. Year+3
-- CA basic constraints and key usage extensions
let bc = Just $ ExtBasicConstraints True Nothing
let bc0 = Just $ ExtBasicConstraints True (Just 0)
let ku = Nothing
-- Root CAs in past, present and future. Need distinct DNs because the
-- certificate store contains all 3 simultaneously.
rootPast <-
generateKeys alg >>= mkCA 1 "RootCA - R1" vPast bc ku Self
rootPresent <-
generateKeys alg >>= mkCA 2 "RootCA - R2" vPresent bc ku Self
rootFuture <-
generateKeys alg >>= mkCA 3 "RootCA - R3" vFuture bc ku Self
-- Intermediate CAs in past, present and future. Also includes a CA with
-- a depth constraint.
pIntermediateP <-
generateKeys alg >>= mkCA 11 "IntermediateCA" vPast bc ku (CA rootPast)
pIntermediate <-
generateKeys alg >>= mkCA 12 "IntermediateCA" vPresent bc ku (CA rootPresent)
pIntermediate0 <-
generateKeys alg >>= mkCA 12 "IntermediateCA" vPresent bc0 ku (CA rootPresent)
pIntermediateF <-
generateKeys alg >>= mkCA 13 "IntermediateCA" vFuture bc ku (CA rootFuture)
-- Additional keys to be reused in test cases. This removes the cost of
-- generating individual keys. A key should be used only once per case.
k1 <- generateKeys alg
k2 <- generateKeys alg
k3 <- generateKeys alg
return
RData
{ rootStore = mkStore [rootPast, rootPresent, rootFuture]
, past = vPast
, present = vPresent
, future = vFuture
, pastDate = m2 -- Year-2
, presentDate = mkDateTime today
, futureDate = n2 -- Year+2
, root = rootPresent
, intermediate = pIntermediate
, intermediate0 = pIntermediate0
, intermediatePast = pIntermediateP
, intermediateFuture = pIntermediateF
, keys1 = k1
, keys2 = k2
, keys3 = k3
}
freeData :: RData pub priv -> IO ()
freeData _ = return ()
-- Test utilities --
-- | Asserts order-insensitive equality for lists. This also ignores
-- duplicate elements.
assertEqualList
:: (Eq a, Show a)
=> String
-- ^ The message prefix
-> [a]
-- ^ The expected value
-> [a]
-- ^ The actual value
-> Assertion
assertEqualList preface expected actual =
unless (actual `same` expected) (assertFailure msg)
where
a `same` b = all (`elem` b) a && all (`elem` a) b
msg =
(if null preface then "" else preface ++ "\n")
++ " expected: "
++ show expected
++ "\n but got: "
++ show actual
-- | Asserts the validation result of a certificate chain.
assertValidationResult
:: RData pub priv
-- ^ Common test resources (CA store)
-> ValidationChecks
-- ^ Checks to do
-> HostName
-- ^ Connection identification
-> [Pair pub priv]
-- ^ Certificate chain to validate
-> [FailedReason]
-- ^ Expected validation result
-> Assertion
assertValidationResult rd checks hostname ps expected = do
actual <- validate HashSHA256 defaultHooks checks store def ident chain
assertEqualList "Unexpected validation result" expected actual
where
store = rootStore rd
ident = (hostname, fromString ":443")
chain = CertificateChain (map pairSignedCert ps)
-- | Simplified access to test resource from 'withResource'.
testWithRes :: IO r -> TestName -> (r -> Assertion) -> TestTree
testWithRes res caseName f = testCase caseName (res >>= f)
-- Test cases --
-- | Tests a leaf certificate signed by an intermediate CA, but using a chain
-- where the intermediate CA may use a different key. This tests the signature
-- of the leaf certificate provided both CAs have the same subject DN.
testSignature
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> (RData pub priv -> Pair pub priv)
-- ^ CA to use for signature
-> (RData pub priv -> Pair pub priv)
-- ^ CA to use for validation
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testSignature res caseName f g expected = testWithRes res caseName $ \rd -> do
pair <- mkLeaf "signature" (present rd) (CA $ f rd) (keys1 rd)
assertValidationResult rd defaultChecks "signature" [pair, g rd] expected
-- | Tests an empty certificate chain.
testEmpty
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testEmpty res caseName expected = testWithRes res caseName $ \rd ->
assertValidationResult rd defaultChecks "empty" [] expected
-- | Tests a certificate chain where the intermediate CA is missing.
testIncompleteChain
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testIncompleteChain res caseName expected = testWithRes res caseName $ \rd -> do
pair <- mkLeaf "incomplete" (present rd) (CA $ intermediate rd) (keys1 rd)
assertValidationResult rd defaultChecks "incomplete" [pair] expected
-- | Tests a self-signed certificate.
testSelfSigned
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testSelfSigned res caseName expected = testWithRes res caseName $ \rd -> do
pair <- mkLeaf "self-signed" (present rd) Self (keys1 rd)
assertValidationResult rd defaultChecks "self-signed" [pair] expected
-- | Tests key usage of intermediate CA, with or without 'checkCAConstraints'.
testCAKeyUsage
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> Bool
-- ^ Value for 'checkCAConstraints'
-> ExtKeyUsageFlag
-- ^ Intermediate CA key usage
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testCAKeyUsage res caseName check flag expected = testWithRes res caseName $ \rd -> do
ca <- mkCA 20 "KeyUsageCA" (present rd) bc ku (CA $ root rd) (keys1 rd)
pair <- mkLeaf "ca-key-usage" (present rd) (CA ca) (keys2 rd)
assertValidationResult rd checks "ca-key-usage" [pair, ca] expected
where
checks = defaultChecks{checkCAConstraints = check}
bc = Just (ExtBasicConstraints True Nothing)
ku = Just (ExtKeyUsage [flag])
-- | Tests CA flag of intermediate CA, with or without 'checkCAConstraints'.
testNotCA
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> Bool
-- ^ Value for 'checkCAConstraints'
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testNotCA res caseName check expected = testWithRes res caseName $ \rd -> do
ca <- mkCA 20 "NotCA" (present rd) bc Nothing (CA $ root rd) (keys1 rd)
pair <- mkLeaf "not-ca" (present rd) (CA ca) (keys2 rd)
assertValidationResult rd checks "not-ca" [pair, ca] expected
where
checks = defaultChecks{checkCAConstraints = check}
bc = Just (ExtBasicConstraints False Nothing)
-- | Tests an intermediate CA without basic constraints, with or without
-- 'checkCAConstraints'.
testNoBasic
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> Bool
-- ^ Value for 'checkCAConstraints'
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testNoBasic res caseName check expected = testWithRes res caseName $ \rd -> do
ca <- mkCA 20 "NoBC" (present rd) bc Nothing (CA $ root rd) (keys1 rd)
pair <- mkLeaf "no-bc" (present rd) (CA ca) (keys2 rd)
assertValidationResult rd checks "no-bc" [pair, ca] expected
where
checks = defaultChecks{checkCAConstraints = check}
bc = Nothing
-- | Tests basic constraints depth, with or without 'checkCAConstraints'.
testBadDepth
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> Bool
-- ^ Value for 'checkCAConstraints'
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testBadDepth res caseName check expected = testWithRes res caseName $ \rd -> do
-- a new CA signed by intermediate0 should fail because of the depth limit
ca <-
mkCA 20 "TooDeep" (present rd) bc Nothing (CA $ intermediate0 rd) (keys1 rd)
pair <- mkLeaf "bad-depth" (present rd) (CA ca) (keys2 rd)
assertValidationResult
rd
checks
"bad-depth"
[pair, ca, intermediate0 rd]
expected
where
checks = defaultChecks{checkCAConstraints = check}
bc = Just (ExtBasicConstraints True Nothing)
-- | Tests a non-V3 leaf certificate, with or without 'checkLeafV3'.
testLeafNotV3
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> Bool
-- ^ Value for 'checkLeafV3'
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testLeafNotV3 res caseName check expected = testWithRes res caseName $ \rd -> do
pair <-
mkCertificate
1
100
dn
(present rd)
leafStdExts
(CA $ intermediate rd)
(keys1 rd)
assertValidationResult rd checks "leaf-not-v3" [pair, intermediate rd] expected
where
checks = defaultChecks{checkLeafV3 = check}
dn = mkDn "leaf-not-v3"
-- | Tests a certificate chain containing a non-related certificate, with or
-- without 'checkStrictOrdering'.
testStrictOrdering
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> Bool
-- ^ Value for 'checkStrictOrdering'
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testStrictOrdering res caseName check expected = testWithRes res caseName $ \rd -> do
ca <-
mkCA 20 "CA" (present rd) bc Nothing (CA $ intermediate rd) (keys1 rd)
extra <-
mkCA 21 "Extra" (present rd) bc Nothing (CA $ intermediate rd) (keys2 rd)
pair <- mkLeaf "strict-ordering" (present rd) (CA ca) (keys3 rd)
assertValidationResult
rd
checks
"strict-ordering"
[pair, ca, extra, intermediate rd]
expected
where
checks = defaultChecks{checkStrictOrdering = check}
bc = Just (ExtBasicConstraints True Nothing)
-- | Tests validity of leaf certificate.
testLeafDates
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> Bool
-- ^ Value for 'checkTimeValidity'
-> (RData pub priv -> (DateTime, DateTime))
-- ^ Validity period to use
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testLeafDates res caseName check f expected = testWithRes res caseName $ \rd -> do
pair <- mkLeaf "leaf-dates" (f rd) (CA $ intermediate rd) (keys1 rd)
assertValidationResult rd checks "leaf-dates" [pair, intermediate rd] expected
where
checks = defaultChecks{checkTimeValidity = check}
-- | Tests validity of intermediate CA.
testIntermediateDates
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> Bool
-- ^ Value for 'checkTimeValidity'
-> (RData pub priv -> Pair pub priv)
-- ^ Intermediate CA to use
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testIntermediateDates res caseName check f expected = testWithRes res caseName $ \rd -> do
pair <- mkLeaf "intermediate-dates" (present rd) (CA $ f rd) (keys1 rd)
assertValidationResult rd checks "intermediate-dates" [pair, f rd] expected
where
checks = defaultChecks{checkTimeValidity = check}
-- | Tests validity of leaf certificate and intermediate CA,
-- using 'checkAtTime'.
testTimeshift
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> (RData pub priv -> (DateTime, DateTime))
-- ^ Leaf validity period
-> (RData pub priv -> Pair pub priv)
-- ^ Intermediate CA to use
-> (RData pub priv -> DateTime)
-- ^ Value for 'checkAtTime'
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testTimeshift res caseName f g h expected = testWithRes res caseName $ \rd -> do
let checks = defaultChecks{checkAtTime = Just $ h rd}
pair <- mkLeaf "timeshift" (f rd) (CA $ g rd) (keys1 rd)
assertValidationResult rd checks "timeshift" [pair, g rd] expected
-- | Tests an empty DistinguishedName.
testNoCommonName
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testNoCommonName res caseName expected = testWithRes res caseName $ \rd -> do
pair <-
mkCertificate
2
100
dn
(present rd)
leafStdExts
(CA $ intermediate rd)
(keys1 rd)
assertValidationResult rd defaultChecks "no-cn" [pair, intermediate rd] expected
where
dn = DistinguishedName []
-- | Tests certificate CommonName against expected hostname, with or without
-- 'checkFQHN'.
testCommonName
:: IO (RData pub priv)
-- ^ Common test resources
-> String
-- ^ Certificate CommonName
-> HostName
-- ^ Connection identification
-> Bool
-- ^ Value for 'checkFQHN'
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testCommonName res cn hostname check expected = testWithRes res caseName $ \rd -> do
pair <- mkLeaf cn (present rd) (CA $ intermediate rd) (keys1 rd)
assertValidationResult rd checks hostname [pair, intermediate rd] expected
where
caseName = if null hostname then "empty" else hostname
checks = defaultChecks{checkFQHN = check}
-- | Tests certificate SubjectAltName against expected hostname, with or
-- without 'checkFQHN'.
testSubjectAltName
:: IO (RData pub priv)
-- ^ Common test resources
-> String
-- ^ Certificate SubjectAltName
-> HostName
-- ^ Connection identification
-> Bool
-- ^ Value for 'checkFQHN'
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testSubjectAltName res san hostname check expected = testWithRes res caseName $ \rd -> do
pair <-
mkCertificate
2
100
dn
(present rd)
(ext : leafStdExts)
(CA $ intermediate rd)
(keys1 rd)
assertValidationResult rd checks hostname [pair, intermediate rd] expected
where
caseName = if null hostname then "empty" else hostname
checks = defaultChecks{checkFQHN = check}
dn = mkDn "cn-not-used" -- this CN value is to be tested too
-- (to make sure CN is *not* considered when a
-- SubjectAltName exists)
ext =
mkExtension False $
-- wraps test value with other values
ExtSubjectAltName
[ AltNameDNS "dummy1"
, AltNameRFC822 "test@example.com"
, AltNameDNS san
, AltNameDNS "dummy2"
]
-- | Tests certificate SubjectAltName against expected IP Address, with or
-- without 'checkFQHN'.
testSubjectAltNameIP
:: IO (RData pub priv)
-- ^ Common test resources
-> BS.ByteString
-- ^ Certificate SubjectAltName
-> HostName
-- ^ Connection identification
-> Bool
-- ^ Value for 'checkFQHN'
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testSubjectAltNameIP res ip hostname check expected = testWithRes res caseName $ \rd -> do
pair <-
mkCertificate
2
100
dn
(present rd)
(ext : leafStdExts)
(CA $ intermediate rd)
(keys1 rd)
assertValidationResult rd checks hostname [pair, intermediate rd] expected
where
caseName = if null hostname then "empty" else hostname
checks = defaultChecks{checkFQHN = check}
dn = mkDn "cn-not-used" -- this CN value is to be tested too
-- (to make sure CN is *not* considered when a
-- SubjectAltName exists)
ext =
mkExtension False $
-- wraps test value with other values
ExtSubjectAltName
[ AltNameDNS "dummy1"
, AltNameRFC822 "test@example.com"
, AltNameIP ip
, AltNameDNS "dummy2"
]
-- | Tests 'checkLeafKeyUsage'.
testLeafKeyUsage
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> [ExtKeyUsageFlag]
-- ^ Certificate flags
-> [ExtKeyUsageFlag]
-- ^ Flags required for validation
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testLeafKeyUsage res caseName cFlags vFlags expected = testWithRes res caseName $ \rd -> do
pair <-
mkCertificate 2 100 dn (present rd) exts (CA $ intermediate rd) (keys1 rd)
assertValidationResult rd checks "key-usage" [pair, intermediate rd] expected
where
checks = defaultChecks{checkLeafKeyUsage = vFlags}
dn = mkDn "key-usage"
exts = if null cFlags then [] else [mkExtension False (ExtKeyUsage cFlags)]
-- | Tests 'checkLeafKeyPurpose'.
testLeafKeyPurpose
:: IO (RData pub priv)
-- ^ Common test resources
-> TestName
-- ^ Case name
-> [ExtKeyUsagePurpose]
-- ^ Certificate flags
-> [ExtKeyUsagePurpose]
-- ^ Flags required for validation
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testLeafKeyPurpose res caseName cFlags vFlags expected = testWithRes res caseName $ \rd -> do
pair <-
mkCertificate 2 100 dn (present rd) exts (CA $ intermediate rd) (keys1 rd)
assertValidationResult rd checks "key-purpose" [pair, intermediate rd] expected
where
checks = defaultChecks{checkLeafKeyPurpose = vFlags}
dn = mkDn "key-purpose"
exts = if null cFlags then [] else [mkExtension False (ExtExtendedKeyUsage cFlags)]
-- | Tests validation with multiple failure reasons in exhaustive mode.
testExhaustive
:: IO (RData pub priv)
-- ^ Common test resources
-> String
-- ^ Certificate CommonName
-> HostName
-- ^ Connection identification
-> [FailedReason]
-- ^ Expected validation result
-> TestTree
testExhaustive res cn hostname expected = testWithRes res caseName $ \rd -> do
-- build an expired self-signed certificate with an invalid signature:
-- the certificate is actually signed by a clone using a different key
p1 <- mkLeaf cn (past rd) Self (keys1 rd)
p2 <- mkLeaf cn (past rd) (CA p1) (keys2 rd)
assertValidationResult rd checks hostname [p2] expected
where
caseName = if null hostname then "empty" else hostname
checks = defaultChecks{checkExhaustive = True}
-- | Validates a chain against a store and checks only success or failure.
assertPassOrFail
:: CertificateStore
-> ValidationChecks
-> HostName
-> [Pair pub priv]
-> Bool
-> Assertion
assertPassOrFail store checks hostname ps pass = do
actual <- validate HashSHA256 defaultHooks checks store def ident chain
unless (null actual == pass) $
assertFailure $
(if pass then "expected success but got: " else "expected failure but got: ")
++ show actual
where
ident = (hostname, fromString ":443")
chain = CertificateChain (map pairSignedCert ps)
nameConstraints :: [AltName] -> [AltName] -> ExtensionRaw
nameConstraints p e = mkExtension True $ ExtNameConstraints (map sub p) (map sub e)
where
sub a = GeneralSubtree a 0 Nothing
caBC :: ExtensionRaw
caBC = mkExtension True $ ExtBasicConstraints True Nothing
sanExt :: [AltName] -> ExtensionRaw
sanExt = mkExtension False . ExtSubjectAltName
-- | Tests name constraints of an intermediate CA and an optional sub-CA
-- against a leaf certificate.
testNameConstraints
:: IO (RData pub priv)
-> TestName
-> [ExtensionRaw]
-- ^ Extensions of the CA in addition to basic constraints
-> Maybe [ExtensionRaw]
-- ^ Extensions of the sub-CA, if any
-> DistinguishedName
-- ^ Leaf subject
-> [ExtensionRaw]
-- ^ Leaf extensions
-> HostName
-> Bool
-- ^ Expected success
-> TestTree
testNameConstraints res caseName caExts msubExts leafDN leafExts hostname pass =
testWithRes res caseName $ \rd -> do
ca <-
mkCertificate
2
30
(mkDn "NC CA")
(present rd)
(caBC : caExts)
(CA $ root rd)
(keys1 rd)
(issuer, chain) <- case msubExts of
Nothing -> return (ca, [ca])
Just subExts -> do
sub <-
mkCertificate
2
31
(mkDn "NC Sub CA")
(present rd)
(caBC : subExts)
(CA ca)
(keys2 rd)
return (sub, [sub, ca])
leaf <- mkCertificate 2 100 leafDN (present rd) leafExts (CA issuer) (keys3 rd)
assertPassOrFail (rootStore rd) defaultChecks hostname (leaf : chain) pass
-- | A leaf whose subject equals the issuer is not exempt from the name
-- constraints of a trust anchor.
testSelfIssuedLeaf :: IO (RData pub priv) -> TestName -> TestTree
testSelfIssuedLeaf res caseName = testWithRes res caseName $ \rd -> do
let exts = [caBC, nameConstraints [AltNameDNS "example.com"] []]
anchor <- mkCertificate 2 40 (mkDn "NC Root") (present rd) exts Self (keys1 rd)
leaf <-
mkCertificate
2
41
(mkDn "NC Root")
(present rd)
[sanExt [AltNameDNS "www.google.com"]]
(CA anchor)
(keys2 rd)
assertPassOrFail (mkStore [anchor]) defaultChecks "www.google.com" [leaf] False
-- | Tests a chain longer than the supported depth.
testLongChain :: IO (RData pub priv) -> TestName -> Int -> Bool -> TestTree
testLongChain res caseName len pass = testWithRes res caseName $ \rd -> do
let mk issuer i =
mkCertificate
2
(fromIntegral i)
(mkDn ("CA" ++ show i))
(present rd)
[caBC]
(CA issuer)
(keys1 rd)
go issuer i acc
| i > len = return (issuer, acc)
| otherwise = mk issuer i >>= \c -> go c (i + 1) (c : acc)
(lastCA, cas) <- go (root rd) (1 :: Int) []
leaf <- mkLeaf "long-chain" (present rd) (CA lastCA) (keys2 rd)
assertPassOrFail (rootStore rd) defaultChecks "long-chain" (leaf : cas) pass
-- | Tests a CA or leaf with an extension that cannot be decoded.
testMalformedExt
:: IO (RData pub priv)
-> TestName
-> Bool
-> ExtensionRaw
-> ValidationChecks
-> [FailedReason]
-> TestTree
testMalformedExt res caseName onCA ext checks expected = testWithRes res caseName $ \rd -> do
ca <-
mkCertificate
2
50
(mkDn "Malformed CA")
(present rd)
([ext | onCA] ++ [caBC | not (isBC ext)])
(CA $ root rd)
(keys1 rd)
leaf <-
mkCertificate
2
100
(mkDn "malformed")
(present rd)
([ext | not onCA])
(CA ca)
(keys2 rd)
assertValidationResult rd checks "malformed" [leaf, ca] expected
where
isBC (ExtensionRaw oid _ _) = oid == [2, 5, 29, 19]
-- | Signature verification with degenerate or oversized keys fails.
testBadKeys :: TestTree
testBadKeys =
testGroup
"bad-keys"
[ testCase "DSA p=0" $
verifySignature
(SignatureALG HashSHA256 PubKeyALG_DSA)
(PubKeyDSA (DSA.PublicKey (DSA.Params 0 2 7) 3))
(BS.pack [1, 2, 3])
(encodeASN1' DER [Start Sequence, IntVal 1, IntVal 1, End Sequence])
@?= SignatureFailed SignatureInvalid
, testCase "huge RSA modulus" $
verifySignature
(SignatureALG HashSHA256 PubKeyALG_RSA)
(PubKeyRSA (RSA.PublicKey 2049 (2 ^ (16392 :: Int) - 1) 3))
(BS.pack [1, 2, 3])
(BS.replicate 2049 1)
@?= SignatureFailed SignatureInvalid
, testCase "huge RSA exponent" $
verifySignature
(SignatureALG HashSHA256 PubKeyALG_RSA)
(PubKeyRSA (RSA.PublicKey 256 (2 ^ (2048 :: Int) - 1) (2 ^ (2047 :: Int) + 1)))
(BS.pack [1, 2, 3])
(BS.replicate 256 1)
@?= SignatureFailed SignatureInvalid
, testCase "tiny RSA-PSS modulus" $
verifySignature
(SignatureALG HashSHA256 PubKeyALG_RSAPSS)
(PubKeyRSA (RSA.PublicKey 1 0x7f 3))
(BS.pack [1, 2, 3])
(BS.pack [1])
@?= SignatureFailed SignatureInvalid
]
-- | Regression tests that do not depend on the signature algorithm.
treeRegression :: TestTree
treeRegression = withResource (initData AlgEd25519) freeData $ \res ->
testGroup
"regression"
[ testGroup
"name-constraints"
[ testNameConstraints
res
"permitted"
[ncEx]
Nothing
leafDN
[sanExt [dns "www.example.com"]]
"www.example.com"
True
, testNameConstraints
res
"not permitted"
[ncEx]
Nothing
leafDN
[sanExt [dns "www.google.com"]]
"www.google.com"
False
, testNameConstraints
res
"sub-CA with excluded only"
[ncEx]
(Just [nameConstraints [] [dns "foo.invalid"]])
leafDN
[sanExt [dns "www.google.com"]]
"www.google.com"
False
, testNameConstraints
res
"sub-CA without constraints"
[ncEx]
(Just [])
leafDN
[sanExt [dns "www.example.com"]]
"www.example.com"
True
, testNameConstraints
res
"sub-CA without constraints (outside)"
[ncEx]
(Just [])
leafDN
[sanExt [dns "www.google.com"]]
"www.google.com"
False
, testNameConstraints
res
"sub-CA permitted outside"
[ncEx]
(Just [nameConstraints [dns "google.com"] []])
leafDN
[sanExt [dns "www.google.com"]]
"www.google.com"
False
, testNameConstraints
res
"CN fallback"
[ncEx]
Nothing
(mkDn "www.google.com")
[]
"www.google.com"
False
, testNameConstraints
res
"CN fallback (permitted)"
[ncEx]
Nothing
(mkDn "www.example.com")
[]
"www.example.com"
True
, testNameConstraints
res
"excluded upper case"
[nameConstraints [] [dns "google.com"]]
Nothing
leafDN
[sanExt [dns "WWW.GOOGLE.COM"]]
"www.google.com"
False
, testNameConstraints
res
"excluded by wildcard"
[nameConstraints [] [dns "www.example.com"]]
Nothing
leafDN
[sanExt [dns "*.example.com"]]
"www.example.com"
False
, testNameConstraints
res
"permitted upper case"
[nameConstraints [dns "EXAMPLE.com"] []]
Nothing
leafDN
[sanExt [dns "www.example.COM"]]
"www.example.com"
True
, testNameConstraints
res
"leading dot"
[nameConstraints [dns ".example.com"] []]
Nothing
leafDN
[sanExt [dns "www.example.com"]]
"www.example.com"
True
, testNameConstraints
res
"leading dot (apex)"
[nameConstraints [dns ".example.com"] []]
Nothing
leafDN
[sanExt [dns "example.com"]]
"example.com"
False
, testNameConstraints
res
"excluded IP"
[nameConstraints [] [ip [8, 8, 8, 8, 255, 255, 255, 255]]]
Nothing
leafDN
[sanExt [dns "www.example.com", ip [8, 8, 8, 8]]]
"www.example.com"
False
, testNameConstraints
res
"permitted IP"
[nameConstraints [ip [10, 0, 0, 0, 255, 0, 0, 0]] []]
Nothing
leafDN
[sanExt [dns "x.example", ip [10, 1, 2, 3]]]
"10.1.2.3"
True
, testNameConstraints
res
"not permitted IP"
[nameConstraints [ip [10, 0, 0, 0, 255, 0, 0, 0]] []]
Nothing
leafDN
[sanExt [dns "x.example", ip [11, 1, 2, 3]]]
"11.1.2.3"
False
, testNameConstraints
res
"IP not constrained by DNS"
[ncEx]
Nothing
leafDN
[sanExt [dns "www.example.com", ip [8, 8, 8, 8]]]
"8.8.8.8"
True
, testNameConstraints
res
"excluded email"
[nameConstraints [] [AltNameRFC822 "example.org"]]
Nothing
leafDN
[sanExt [dns "www.example.com", AltNameRFC822 "a@EXAMPLE.org"]]
"www.example.com"
False
, testNameConstraints
res
"excluded URI"
[nameConstraints [] [AltNameURI ".example.org"]]
Nothing
leafDN
[sanExt [dns "www.example.com", AltNameURI "https://www.example.org/"]]
"www.example.com"
False
, testNameConstraints
res
"permitted DN"
[nameConstraints [AltNameDN (mkDn "leaf")] []]
Nothing
leafDN
[sanExt [dns "www.example.com"]]
"www.example.com"
True
, testNameConstraints
res
"excluded DN"
[nameConstraints [] [AltNameDN (mkDn "LEAF")]]
Nothing
leafDN
[sanExt [dns "www.example.com"]]
"www.example.com"
False
, testNameConstraints
res
"unparsable"
[ncRegisteredID]
Nothing
leafDN
[sanExt [dns "www.google.com"]]
"www.google.com"
False
, testSelfIssuedLeaf res "self-issued leaf"
]
, testGroup
"subject-alt-name"
[ testNameConstraints
res
"unknown names skipped"
[]
Nothing
leafDN
[sanUnknown]
"www.example.com"
True
, testNameConstraints
res
"undecodable SAN"
[]
Nothing
(mkDn "www.example.com")
[sanBroken]
"www.example.com"
False
]
, testGroup
"malformed-extensions"
[ testMalformedExt
res
"CA key usage"
True
(raw [2, 5, 29, 15] [IntVal 1])
defaultChecks
[NotAllowedToSign]
, testMalformedExt
res
"CA basic constraints"
True
(raw [2, 5, 29, 19] [IntVal 1])
defaultChecks
[NotAnAuthority]
, testMalformedExt
res
"leaf key usage bit 9"
False
(raw [2, 5, 29, 15] [BitString (toBitArray (BS.pack [0x80, 0x40]) 6)])
defaultChecks
{ checkLeafKeyUsage = [KeyUsage_digitalSignature]
, checkFQHN = False
}
[]
, testMalformedExt
res
"leaf extended key usage"
False
(raw [2, 5, 29, 37] [Start Sequence, IntVal 1, End Sequence])
defaultChecks
{ checkLeafKeyPurpose = [KeyUsagePurpose_ServerAuth]
, checkFQHN = False
}
[LeafKeyPurposeNotAllowed]
]
, testGroup
"chain-length"
[ testLongChain res "short" 5 True
, testLongChain res "too long" 25 False
]
, testBadKeys
]
where
dns = AltNameDNS
ip = AltNameIP . BS.pack
leafDN = mkDn "leaf"
ncEx = nameConstraints [dns "example.com"] []
raw oid asn1 = ExtensionRaw oid True (encodeASN1' DER asn1)
ncRegisteredID =
raw
[2, 5, 29, 30]
[ Start Sequence
, Start (Container Context 0)
, Start Sequence
, Other Context 2 (fromString "example.com")
, End Sequence
, Start Sequence
, Other Context 8 (BS.pack [0x2a, 0x03])
, End Sequence
, End (Container Context 0)
, End Sequence
]
sanUnknown =
ExtensionRaw [2, 5, 29, 17] False $
encodeASN1'
DER
[ Start Sequence
, Other Context 8 (BS.pack [0x2a, 0x03])
, Other Context 2 (fromString "www.example.com")
, End Sequence
]
sanBroken =
ExtensionRaw [2, 5, 29, 17] False $
encodeASN1' DER [Start Sequence, IntVal 1, End Sequence]
-- | All validation test cases.
treeWithAlg :: TestName -> Alg pub priv -> TestTree
treeWithAlg groupName alg = withResource (initData alg) freeData $ \res ->
testGroup
groupName
[ testGroup
"signature"
[ testSignature res "valid" intermediate intermediate []
, testSignature
res
"invalid"
intermediate
intermediate0
[InvalidSignature SignatureInvalid]
]
, testGroup
"chain"
[ testEmpty res "empty" [EmptyChain]
, testIncompleteChain res "incomplete" [UnknownCA]
, testSelfSigned res "self-signed" [SelfSigned]
, testGroup
"leaf-not-v3"
[ testLeafNotV3 res "v3-disallowed" True [LeafNotV3]
, testLeafNotV3 res "v3-allowed" False []
]
, testGroup
"strict-ordering"
[ testStrictOrdering res "enabled" True [UnknownCA]
, testStrictOrdering res "disabled" False []
]
]
, testGroup
"ca-constraints"
[ testGroup
"enabled"
[ testCAKeyUsage res "cert-sign" True KeyUsage_keyCertSign []
, testCAKeyUsage res "crl-sign" True KeyUsage_cRLSign [NotAllowedToSign]
, testNotCA res "not-ca" True [NotAnAuthority]
, testNoBasic res "no-basic" True [NotAnAuthority]
, testBadDepth res "bad-depth" True [AuthorityTooDeep]
]
, testGroup
"disabled"
[ testCAKeyUsage res "cert-sign" False KeyUsage_keyCertSign []
, testCAKeyUsage res "crl-sign" False KeyUsage_cRLSign []
, testNotCA res "not-ca" False []
, testNoBasic res "no-basic" False []
, testBadDepth res "bad-depth" False []
]
]
, testGroup
"dates"
[ testGroup
"leaf"
[ testGroup
"enabled"
[ testLeafDates res "past" True past [Expired]
, testLeafDates res "present" True present []
, testLeafDates res "future" True future [InFuture]
]
, testGroup
"disabled"
[ testLeafDates res "past" False past []
, testLeafDates res "present" False present []
, testLeafDates res "future" False future []
]
]
, testGroup
"intermediate"
[ testGroup
"enabled"
[ testIntermediateDates res "past" True intermediatePast [Expired]
, testIntermediateDates res "present" True intermediate []
, testIntermediateDates res "future" True intermediateFuture [InFuture]
]
, testGroup
"disabled"
[ testIntermediateDates res "past" False intermediatePast []
, testIntermediateDates res "present" False intermediate []
, testIntermediateDates res "future" False intermediateFuture []
]
]
, testGroup
"timeshift"
[ testGroup
"at-past"
[ testTimeshift res "past" past intermediatePast pastDate []
, testTimeshift res "present" present intermediate pastDate [InFuture]
, testTimeshift res "future" future intermediateFuture pastDate [InFuture]
]
, testGroup
"at-present"
[ testTimeshift res "past" past intermediatePast presentDate [Expired]
, testTimeshift res "present" present intermediate presentDate []
, testTimeshift res "future" future intermediateFuture presentDate [InFuture]
]
, testGroup
"in-future"
[ testTimeshift res "past" past intermediatePast futureDate [Expired]
, testTimeshift res "present" present intermediate futureDate [Expired]
, testTimeshift res "future" future intermediateFuture futureDate []
]
]
]
, testGroup
"CommonName"
[ testNoCommonName res "no-common-name" [NoCommonName]
, testGroup
"simple"
[ testCommonName res "www.example.com" "www.example.com" True []
, testCommonName
res
"www.example.com"
"www2.example.com"
True
[NameMismatch "www2.example.com"]
, testCommonName res "www.example.com" "WWW.EXAMPLE.COM" True []
, testCommonName res "www.example.com" "www.EXAMPLE.COM" True []
, testCommonName res "www.example.com" "WWW.example.com" True []
, testCommonName
res
"www..example.com"
"www..example.com"
True
[NameMismatch "www..example.com"] -- InvalidName "www..example.com"
, testCommonName res "" "" True [NameMismatch ""] -- InvalidName ""
]
, testGroup
"wildcard"
[ testCommonName
res
"*.example.com"
"example.com"
True
[NameMismatch "example.com"]
, testCommonName res "*.example.com" "www.example.com" True []
, testCommonName res "*.example.com" "www.EXAMPLE.com" True []
, testCommonName res "*.example.com" "www2.example.com" True []
, testCommonName
res
"*.example.com"
"www.m.example.com"
True
[NameMismatch "www.m.example.com"]
, testCommonName
res
"*"
"single"
True
[NameMismatch "single"] -- InvalidWildcard
]
, testGroup
"disabled"
[ testCommonName res "www.example.com" "www.example.com" False []
, testCommonName res "www.example.com" "www2.example.com" False []
, testCommonName res "www.example.com" "WWW.EXAMPLE.COM" False []
, testCommonName res "www.example.com" "www.EXAMPLE.COM" False []
, testCommonName res "www.example.com" "WWW.example.com" False []
, testCommonName res "www..example.com" "www..example.com" False []
, testCommonName res "" "" False []
]
]
, testGroup
"SubjectAltName"
[ testGroup
"simple"
[ testSubjectAltName res "www.example.com" "www.example.com" True []
, testSubjectAltName
res
"www.example.com"
"www2.example.com"
True
[NameMismatch "www2.example.com"]
, testSubjectAltName res "www.example.com" "WWW.EXAMPLE.COM" True []
, testSubjectAltName res "www.example.com" "www.EXAMPLE.COM" True []
, testSubjectAltName res "www.example.com" "WWW.example.com" True []
, testSubjectAltName
res
"www..example.com"
"www..example.com"
True
[NameMismatch "www..example.com"] -- InvalidName "www..example.com"
, testSubjectAltName
res
""
""
True
[NameMismatch ""] -- InvalidName ""
]
, testGroup
"wildcard"
[ testSubjectAltName
res
"*.example.com"
"example.com"
True
[NameMismatch "example.com"]
, testSubjectAltName res "*.example.com" "www.example.com" True []
, testSubjectAltName res "*.example.com" "www.EXAMPLE.com" True []
, testSubjectAltName res "*.example.com" "www2.example.com" True []
, testSubjectAltName
res
"*.example.com"
"www.m.example.com"
True
[NameMismatch "www.m.example.com"]
, testSubjectAltName
res
"*"
"single"
True
[NameMismatch "single"] -- InvalidWildcard
]
, testSubjectAltName
res
"www.example.com"
"cn-not-used"
True
[NameMismatch "cn-not-used"]
, testGroup
"IP addresses"
[ testSubjectAltNameIP res (BS.pack [10, 0, 0, 1]) "10.0.0.1" True []
, testSubjectAltNameIP
res
(BS.pack [10, 0, 0, 1])
"10.0.0.2"
True
[NameMismatch "10.0.0.2"]
, testSubjectAltNameIP
res
(BS.pack [10, 0, 0, 1])
"10.0.0.1.example.com"
True
[NameMismatch "10.0.0.1.example.com"]
, testSubjectAltNameIP
res
(BS.pack [10, 0, 0, 1])
"266.0.0.1"
True
[NameMismatch "266.0.0.1"] -- 266 read in Word8 is 10
, testSubjectAltNameIP
res
( BS.pack
[ 0x20
, 0x01
, 0x0d
, 0xb8
, 0x85
, 0xa3
, 0
, 0
, 0
, 0
, 0x8a
, 0x2e
, 0x03
, 0x70
, 0x73
, 0x34
]
)
"2001:0db8:85a3:0000:0000:8a2e:0370:7334"
True
[]
, testSubjectAltNameIP
res
( BS.pack
[ 0x20
, 0x01
, 0x0d
, 0xb8
, 0x85
, 0xa3
, 0
, 0
, 0
, 0
, 0x8a
, 0x2e
, 0x03
, 0x70
, 0x73
, 0x34
]
)
"2001:0db8:85a3::8a2e:0370:7334"
True
[]
, testSubjectAltNameIP
res
( BS.pack
[ 0x20
, 0x01
, 0x0d
, 0xb8
, 0x85
, 0xa3
, 0
, 0
, 0
, 0
, 0x8a
, 0x2e
, 0x03
, 0x70
, 0x73
, 0x34
]
)
"2001:0db8:85a3:0:0:8a2e:0370:7334"
True
[]
, testSubjectAltNameIP
res
(BS.pack [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1])
"::1"
True
[]
]
, testGroup
"disabled"
[ testSubjectAltName res "www.example.com" "www.example.com" False []
, testSubjectAltName res "www.example.com" "www2.example.com" False []
, testSubjectAltName res "www.example.com" "WWW.EXAMPLE.COM" False []
, testSubjectAltName res "www.example.com" "www.EXAMPLE.COM" False []
, testSubjectAltName res "www.example.com" "WWW.example.com" False []
, testSubjectAltName res "www..example.com" "www..example.com" False []
, testSubjectAltName res "" "" False []
]
]
, testGroup
"key-usage"
[ testLeafKeyUsage res "none" [] [u2, u3] []
, testLeafKeyUsage res "valid" [u1, u2, u3] [u2, u3] []
, testLeafKeyUsage res "invalid" [u1, u3] [u2, u3] [LeafKeyUsageNotAllowed]
]
, testGroup
"key-purpose"
[ testLeafKeyPurpose res "none" [] [p2, p3] []
, testLeafKeyPurpose res "valid" [p1, p2, p3] [p2, p3] []
, testLeafKeyPurpose
res
"invalid"
[p1, p3]
[p2, p3]
[LeafKeyPurposeNotAllowed]
]
, testExhaustive
res
"exhaustive2"
"exhaustive"
[ SelfSigned
, Expired
, InvalidSignature SignatureInvalid
, NameMismatch "exhaustive"
]
]
where
(u1, u2, u3) = (KeyUsage_keyEncipherment, KeyUsage_dataEncipherment, KeyUsage_keyAgreement)
(p1, p2, p3) =
( KeyUsagePurpose_ClientAuth
, KeyUsagePurpose_CodeSigning
, KeyUsagePurpose_EmailProtection
)
-- | Runs the test suite.
main :: IO ()
main =
defaultMain $
testGroup
"Validation"
[ treeWithAlg "RSA" (AlgRSA 2048 hashSHA256)
, treeWithAlg "RSAPSS" (AlgRSAPSS 2048 pssParams hashSHA224)
, treeWithAlg "DSA" (AlgDSA dsaParams hashSHA1)
, treeWithAlg "ECDSA" (AlgEC curveName hashSHA512)
, treeWithAlg "Ed25519" AlgEd25519
, treeWithAlg "Ed448" AlgEd448
, treeWithAlg "ML-DSA-44" AlgMLDSA44
, treeWithAlg "ML-DSA-65" AlgMLDSA65
, treeWithAlg "ML-DSA-87" AlgMLDSA87
, treeRegression
]
where
pssParams = PSS.defaultPSSParams SHA224
-- DSA parameters were generated using 'openssl dsaparam -C 2048'
dsaParams =
DSA.Params
{ DSA.params_p =
0x9994B9B1FC22EC3A5F607B5130D314F35FC8D387015A6D8FA2B56D3CC1F13FE330A631DBC765CEFFD6986BDEB8512580BBAD93D56EE7A8997DB9C65C29313FBC5077DB6F1E9D9E6D3499F997F09C8CF8ECC9E5F38DC34C3D656CFDF463893DDF9E246E223D7E5C4E86F54426DDA5DE112FCEDBFB5B6D6F7C76ED190EA1A7761CA561E8E5803F9D616DAFF25E2CCD4011A6D78D5CE8ED28CC2D865C7EC01508BA96FBD1F8BB5E517B6A5208A90AC2D3DCAE50281C02510B86C16D449465CD4B3754FD91AA19031282122A25C68292F033091FCB9DEBDE0D220F81F7EE4AB6581D24BE48204AF3DA52BDB944DA53B76148055395B30954735DC911574D360C953B
, DSA.params_g =
0x10E51AEA37880C5E52DD477ED599D55050C47012D038B9E4B3199C9DE9A5B873B1ABC8B954F26AFEA6C028BCE1783CFE19A88C64E4ED6BFD638802A78457A5C25ABEA98BE9C6EF18A95504C324315EABE7C1EA50E754591E3EFD3D33D4AE47F82F8978ABC871C135133767ACC60683F065430C749C43893D73596B12D5835A78778D0140B2F63B32A5658308DD5BA6BBC49CF6692929FA6A966419404F9A2C216860E3F339EDDB49AD32C294BDB4C9C6BB0D1CC7B691C65968C3A0A5106291CD3810147C8A16B4BFE22968AD9D3890733F4AA9ACD8687A5B981653A4B1824004639956E8C1EDAF31A8224191E8ABD645D2901F5B164B4B93F98039A6EAEC6088
, DSA.params_q =
0xE1FDFADD32F46B5035EEB3DB81F9974FBCA69BE2223E62FCA8C77989B2AACDF7
}
curveName = ECC.SEC_p384r1