1-- | Validation test suite. 2module Main (main) where 3 4import Control.Applicative 5import Control.Monad (unless) 6 7import Crypto.Hash.Algorithms 8 9import qualified Crypto.PubKey.DSA as DSA 10import qualified Crypto.PubKey.ECC.Types as ECC 11import qualified Crypto.PubKey.RSA.PSS as PSS 12 13import Data.Default.Class 14import Data.Monoid 15import Data.String (fromString) 16import Data.X509 17import Data.X509.CertificateStore 18import Data.X509.Validation 19 20import Data.Hourglass 21import System.Hourglass 22 23import Test.Tasty 24import Test.Tasty.HUnit 25 26import Certificate 27 28 29-- Runtime data, dynamically generated and shared by all test cases -- 30 31data RData pub priv = RData 32 { rootStore :: CertificateStore 33 , past :: (DateTime, DateTime) 34 , present :: (DateTime, DateTime) 35 , future :: (DateTime, DateTime) 36 , pastDate :: DateTime 37 , presentDate :: DateTime 38 , futureDate :: DateTime 39 , root :: Pair pub priv 40 , intermediate :: Pair pub priv 41 , intermediate0 :: Pair pub priv 42 , intermediatePast :: Pair pub priv 43 , intermediateFuture :: Pair pub priv 44 , keys1 :: Keys pub priv 45 , keys2 :: Keys pub priv 46 , keys3 :: Keys pub priv 47 } 48 49mkDateTime :: Date -> DateTime 50mkDateTime d = DateTime d (TimeOfDay 0 0 0 0) 51 52mkStore :: [Pair pub priv] -> CertificateStore 53mkStore ps = makeCertificateStore (map pairSignedCert ps) 54 55initData :: Alg pub priv -> IO (RData pub priv) 56initData alg = do 57 today <- timeGetDate <$> timeCurrent 58 59 let m3 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = -3 } 60 let m2 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = -2 } 61 let m1 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = -1 } 62 let n1 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = 1 } 63 let n2 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = 2 } 64 let n3 = mkDateTime $ today `dateAddPeriod` mempty { periodYears = 3 } 65 66 -- two-year validity periods in past, present and future 67 let vPast = (m3, m1) -- Year-3 .. Year-1 68 let vPresent = (m1, n1) -- Year-1 .. Year+1 69 let vFuture = (n1, n3) -- Year+1 .. Year+3 70 71 -- CA basic constraints and key usage extensions 72 let bc = Just $ ExtBasicConstraints True Nothing 73 let bc0 = Just $ ExtBasicConstraints True (Just 0) 74 let ku = Nothing 75 76 -- Root CAs in past, present and future. Need distinct DNs because the 77 -- certificate store contains all 3 simultaneously. 78 rootPast <- generateKeys alg >>= mkCA 1 "RootCA - R1" vPast bc ku Self 79 rootPresent <- generateKeys alg >>= mkCA 2 "RootCA - R2" vPresent bc ku Self 80 rootFuture <- generateKeys alg >>= mkCA 3 "RootCA - R3" vFuture bc ku Self 81 82 -- Intermediate CAs in past, present and future. Also includes a CA with 83 -- a depth constraint. 84 pIntermediateP <- generateKeys alg >>= mkCA 11 "IntermediateCA" vPast bc ku (CA rootPast) 85 pIntermediate <- generateKeys alg >>= mkCA 12 "IntermediateCA" vPresent bc ku (CA rootPresent) 86 pIntermediate0 <- generateKeys alg >>= mkCA 12 "IntermediateCA" vPresent bc0 ku (CA rootPresent) 87 pIntermediateF <- generateKeys alg >>= mkCA 13 "IntermediateCA" vFuture bc ku (CA rootFuture) 88 89 -- Additional keys to be reused in test cases. This removes the cost of 90 -- generating individual keys. A key should be used only once per case. 91 k1 <- generateKeys alg 92 k2 <- generateKeys alg 93 k3 <- generateKeys alg 94 95 return RData 96 { rootStore = mkStore [ rootPast, rootPresent, rootFuture ] 97 , past = vPast 98 , present = vPresent 99 , future = vFuture 100 , pastDate = m2 -- Year-2 101 , presentDate = mkDateTime today 102 , futureDate = n2 -- Year+2 103 , root = rootPresent 104 , intermediate = pIntermediate 105 , intermediate0 = pIntermediate0 106 , intermediatePast = pIntermediateP 107 , intermediateFuture = pIntermediateF 108 , keys1 = k1 109 , keys2 = k2 110 , keys3 = k3 111 } 112 113freeData :: RData pub priv -> IO () 114freeData _ = return () 115 116 117-- Test utilities -- 118 119-- | Asserts order-insensitive equality for lists. This also ignores 120-- duplicate elements. 121assertEqualList :: (Eq a, Show a) => String -- ^ The message prefix 122 -> [a] -- ^ The expected value 123 -> [a] -- ^ The actual value 124 -> Assertion 125assertEqualList preface expected actual = 126 unless (actual `same` expected) (assertFailure msg) 127 where 128 a `same` b = all (`elem` b) a && all (`elem` a) b 129 msg = (if null preface then "" else preface ++ "\n") ++ 130 " expected: " ++ show expected ++ "\n but got: " ++ show actual 131 132-- | Asserts the validation result of a certificate chain. 133assertValidationResult :: RData pub priv -- ^ Common test resources (CA store) 134 -> ValidationChecks -- ^ Checks to do 135 -> HostName -- ^ Connection identification 136 -> [Pair pub priv] -- ^ Certificate chain to validate 137 -> [FailedReason] -- ^ Expected validation result 138 -> Assertion 139assertValidationResult rd checks hostname ps expected = do 140 actual <- validate HashSHA256 defaultHooks checks store def ident chain 141 assertEqualList "Unexpected validation result" expected actual 142 where 143 store = rootStore rd 144 ident = (hostname, fromString ":443") 145 chain = CertificateChain (map pairSignedCert ps) 146 147-- | Simplified access to test resource from 'withResource'. 148testWithRes :: IO r -> TestName -> (r -> Assertion) -> TestTree 149testWithRes res caseName f = testCase caseName (res >>= f) 150 151 152-- Test cases -- 153 154-- | Tests a leaf certificate signed by an intermediate CA, but using a chain 155-- where the intermediate CA may use a different key. This tests the signature 156-- of the leaf certificate provided both CAs have the same subject DN. 157testSignature :: IO (RData pub priv) -- ^ Common test resources 158 -> TestName -- ^ Case name 159 -> (RData pub priv -> Pair pub priv) -- ^ CA to use for signature 160 -> (RData pub priv -> Pair pub priv) -- ^ CA to use for validation 161 -> [FailedReason] -- ^ Expected validation result 162 -> TestTree 163testSignature res caseName f g expected = testWithRes res caseName $ \rd -> do 164 pair <- mkLeaf "signature" (present rd) (CA $ f rd) (keys1 rd) 165 assertValidationResult rd defaultChecks "signature" [pair, g rd] expected 166 167-- | Tests an empty certificate chain. 168testEmpty :: IO (RData pub priv) -- ^ Common test resources 169 -> TestName -- ^ Case name 170 -> [FailedReason] -- ^ Expected validation result 171 -> TestTree 172testEmpty res caseName expected = testWithRes res caseName $ \rd -> 173 assertValidationResult rd defaultChecks "empty" [] expected 174 175-- | Tests a certificate chain where the intermediate CA is missing. 176testIncompleteChain :: IO (RData pub priv) -- ^ Common test resources 177 -> TestName -- ^ Case name 178 -> [FailedReason] -- ^ Expected validation result 179 -> TestTree 180testIncompleteChain res caseName expected = testWithRes res caseName $ \rd -> do 181 pair <- mkLeaf "incomplete" (present rd) (CA $ intermediate rd) (keys1 rd) 182 assertValidationResult rd defaultChecks "incomplete" [pair] expected 183 184-- | Tests a self-signed certificate. 185testSelfSigned :: IO (RData pub priv) -- ^ Common test resources 186 -> TestName -- ^ Case name 187 -> [FailedReason] -- ^ Expected validation result 188 -> TestTree 189testSelfSigned res caseName expected = testWithRes res caseName $ \rd -> do 190 pair <- mkLeaf "self-signed" (present rd) Self (keys1 rd) 191 assertValidationResult rd defaultChecks "self-signed" [pair] expected 192 193-- | Tests key usage of intermediate CA, with or without 'checkCAConstraints'. 194testCAKeyUsage :: IO (RData pub priv) -- ^ Common test resources 195 -> TestName -- ^ Case name 196 -> Bool -- ^ Value for 'checkCAConstraints' 197 -> ExtKeyUsageFlag -- ^ Intermediate CA key usage 198 -> [FailedReason] -- ^ Expected validation result 199 -> TestTree 200testCAKeyUsage res caseName check flag expected = testWithRes res caseName $ \rd -> do 201 ca <- mkCA 20 "KeyUsageCA" (present rd) bc ku (CA $ root rd) (keys1 rd) 202 pair <- mkLeaf "ca-key-usage" (present rd) (CA ca) (keys2 rd) 203 assertValidationResult rd checks "ca-key-usage" [pair, ca] expected 204 where 205 checks = defaultChecks { checkCAConstraints = check } 206 bc = Just (ExtBasicConstraints True Nothing) 207 ku = Just (ExtKeyUsage [flag]) 208 209-- | Tests CA flag of intermediate CA, with or without 'checkCAConstraints'. 210testNotCA :: IO (RData pub priv) -- ^ Common test resources 211 -> TestName -- ^ Case name 212 -> Bool -- ^ Value for 'checkCAConstraints' 213 -> [FailedReason] -- ^ Expected validation result 214 -> TestTree 215testNotCA res caseName check expected = testWithRes res caseName $ \rd -> do 216 ca <- mkCA 20 "NotCA" (present rd) bc Nothing (CA $ root rd) (keys1 rd) 217 pair <- mkLeaf "not-ca" (present rd) (CA ca) (keys2 rd) 218 assertValidationResult rd checks "not-ca" [pair, ca] expected 219 where 220 checks = defaultChecks { checkCAConstraints = check } 221 bc = Just (ExtBasicConstraints False Nothing) 222 223-- | Tests an intermediate CA without basic constraints, with or without 224-- 'checkCAConstraints'. 225testNoBasic :: IO (RData pub priv) -- ^ Common test resources 226 -> TestName -- ^ Case name 227 -> Bool -- ^ Value for 'checkCAConstraints' 228 -> [FailedReason] -- ^ Expected validation result 229 -> TestTree 230testNoBasic res caseName check expected = testWithRes res caseName $ \rd -> do 231 ca <- mkCA 20 "NoBC" (present rd) bc Nothing (CA $ root rd) (keys1 rd) 232 pair <- mkLeaf "no-bc" (present rd) (CA ca) (keys2 rd) 233 assertValidationResult rd checks "no-bc" [pair, ca] expected 234 where 235 checks = defaultChecks { checkCAConstraints = check } 236 bc = Nothing 237 238-- | Tests basic constraints depth, with or without 'checkCAConstraints'. 239testBadDepth :: IO (RData pub priv) -- ^ Common test resources 240 -> TestName -- ^ Case name 241 -> Bool -- ^ Value for 'checkCAConstraints' 242 -> [FailedReason] -- ^ Expected validation result 243 -> TestTree 244testBadDepth res caseName check expected = testWithRes res caseName $ \rd -> do 245 -- a new CA signed by intermediate0 should fail because of the depth limit 246 ca <- mkCA 20 "TooDeep" (present rd) bc Nothing (CA $ intermediate0 rd) (keys1 rd) 247 pair <- mkLeaf "bad-depth" (present rd) (CA ca) (keys2 rd) 248 assertValidationResult rd checks "bad-depth" [pair, ca, intermediate0 rd] expected 249 where 250 checks = defaultChecks { checkCAConstraints = check } 251 bc = Just (ExtBasicConstraints True Nothing) 252 253-- | Tests a non-V3 leaf certificate, with or without 'checkLeafV3'. 254testLeafNotV3 :: IO (RData pub priv) -- ^ Common test resources 255 -> TestName -- ^ Case name 256 -> Bool -- ^ Value for 'checkLeafV3' 257 -> [FailedReason] -- ^ Expected validation result 258 -> TestTree 259testLeafNotV3 res caseName check expected = testWithRes res caseName $ \rd -> do 260 pair <- mkCertificate 1 100 dn (present rd) leafStdExts (CA $ intermediate rd) (keys1 rd) 261 assertValidationResult rd checks "leaf-not-v3" [pair, intermediate rd] expected 262 where 263 checks = defaultChecks { checkLeafV3 = check } 264 dn = mkDn "leaf-not-v3" 265 266-- | Tests a certificate chain containing a non-related certificate, with or 267-- without 'checkStrictOrdering'. 268testStrictOrdering :: IO (RData pub priv) -- ^ Common test resources 269 -> TestName -- ^ Case name 270 -> Bool -- ^ Value for 'checkStrictOrdering' 271 -> [FailedReason] -- ^ Expected validation result 272 -> TestTree 273testStrictOrdering res caseName check expected = testWithRes res caseName $ \rd -> do 274 ca <- mkCA 20 "CA" (present rd) bc Nothing (CA $ intermediate rd) (keys1 rd) 275 extra <- mkCA 21 "Extra" (present rd) bc Nothing (CA $ intermediate rd) (keys2 rd) 276 pair <- mkLeaf "strict-ordering" (present rd) (CA ca) (keys3 rd) 277 assertValidationResult rd checks "strict-ordering" [pair, ca, extra, intermediate rd] expected 278 where 279 checks = defaultChecks { checkStrictOrdering = check } 280 bc = Just (ExtBasicConstraints True Nothing) 281 282-- | Tests validity of leaf certificate. 283testLeafDates :: IO (RData pub priv) -- ^ Common test resources 284 -> TestName -- ^ Case name 285 -> Bool -- ^ Value for 'checkTimeValidity' 286 -> (RData pub priv -> (DateTime, DateTime)) -- ^ Validity period to use 287 -> [FailedReason] -- ^ Expected validation result 288 -> TestTree 289testLeafDates res caseName check f expected = testWithRes res caseName $ \rd -> do 290 pair <- mkLeaf "leaf-dates" (f rd) (CA $ intermediate rd) (keys1 rd) 291 assertValidationResult rd checks "leaf-dates" [pair, intermediate rd] expected 292 where 293 checks = defaultChecks { checkTimeValidity = check } 294 295-- | Tests validity of intermediate CA. 296testIntermediateDates :: IO (RData pub priv) -- ^ Common test resources 297 -> TestName -- ^ Case name 298 -> Bool -- ^ Value for 'checkTimeValidity' 299 -> (RData pub priv -> Pair pub priv) -- ^ Intermediate CA to use 300 -> [FailedReason] -- ^ Expected validation result 301 -> TestTree 302testIntermediateDates res caseName check f expected = testWithRes res caseName $ \rd -> do 303 pair <- mkLeaf "intermediate-dates" (present rd) (CA $ f rd) (keys1 rd) 304 assertValidationResult rd checks "intermediate-dates" [pair, f rd] expected 305 where 306 checks = defaultChecks { checkTimeValidity = check } 307 308-- | Tests validity of leaf certificate and intermediate CA, 309-- using 'checkAtTime'. 310testTimeshift :: IO (RData pub priv) -- ^ Common test resources 311 -> TestName -- ^ Case name 312 -> (RData pub priv -> (DateTime, DateTime)) -- ^ Leaf validity period 313 -> (RData pub priv -> Pair pub priv) -- ^ Intermediate CA to use 314 -> (RData pub priv -> DateTime) -- ^ Value for 'checkAtTime' 315 -> [FailedReason] -- ^ Expected validation result 316 -> TestTree 317testTimeshift res caseName f g h expected = testWithRes res caseName $ \rd -> do 318 let checks = defaultChecks { checkAtTime = Just $ h rd } 319 pair <- mkLeaf "timeshift" (f rd) (CA $ g rd) (keys1 rd) 320 assertValidationResult rd checks "timeshift" [pair, g rd] expected 321 322-- | Tests an empty DistinguishedName. 323testNoCommonName :: IO (RData pub priv) -- ^ Common test resources 324 -> TestName -- ^ Case name 325 -> [FailedReason] -- ^ Expected validation result 326 -> TestTree 327testNoCommonName res caseName expected = testWithRes res caseName $ \rd -> do 328 pair <- mkCertificate 2 100 dn (present rd) leafStdExts (CA $ intermediate rd) (keys1 rd) 329 assertValidationResult rd defaultChecks "no-cn" [pair, intermediate rd] expected 330 where 331 dn = DistinguishedName [] 332 333-- | Tests certificate CommonName against expected hostname, with or without 334-- 'checkFQHN'. 335testCommonName :: IO (RData pub priv) -- ^ Common test resources 336 -> String -- ^ Certificate CommonName 337 -> HostName -- ^ Connection identification 338 -> Bool -- ^ Value for 'checkFQHN' 339 -> [FailedReason] -- ^ Expected validation result 340 -> TestTree 341testCommonName res cn hostname check expected = testWithRes res caseName $ \rd -> do 342 pair <- mkLeaf cn (present rd) (CA $ intermediate rd) (keys1 rd) 343 assertValidationResult rd checks hostname [pair, intermediate rd] expected 344 where 345 caseName = if null hostname then "empty" else hostname 346 checks = defaultChecks { checkFQHN = check } 347 348-- | Tests certificate SubjectAltName against expected hostname, with or 349-- without 'checkFQHN'. 350testSubjectAltName :: IO (RData pub priv) -- ^ Common test resources 351 -> String -- ^ Certificate SubjectAltName 352 -> HostName -- ^ Connection identification 353 -> Bool -- ^ Value for 'checkFQHN' 354 -> [FailedReason] -- ^ Expected validation result 355 -> TestTree 356testSubjectAltName res san hostname check expected = testWithRes res caseName $ \rd -> do 357 pair <- mkCertificate 2 100 dn (present rd) (ext:leafStdExts) (CA $ intermediate rd) (keys1 rd) 358 assertValidationResult rd checks hostname [pair, intermediate rd] expected 359 where 360 caseName = if null hostname then "empty" else hostname 361 checks = defaultChecks { checkFQHN = check } 362 dn = mkDn "cn-not-used" -- this CN value is to be tested too 363 -- (to make sure CN is *not* considered when a 364 -- SubjectAltName exists) 365 ext = mkExtension False $ 366 -- wraps test value with other values 367 ExtSubjectAltName [ AltNameDNS "dummy1" 368 , AltNameRFC822 "test@example.com" 369 , AltNameDNS san 370 , AltNameDNS "dummy2" 371 ] 372 373-- | Tests 'checkLeafKeyUsage'. 374testLeafKeyUsage :: IO (RData pub priv) -- ^ Common test resources 375 -> TestName -- ^ Case name 376 -> [ExtKeyUsageFlag] -- ^ Certificate flags 377 -> [ExtKeyUsageFlag] -- ^ Flags required for validation 378 -> [FailedReason] -- ^ Expected validation result 379 -> TestTree 380testLeafKeyUsage res caseName cFlags vFlags expected = testWithRes res caseName $ \rd -> do 381 pair <- mkCertificate 2 100 dn (present rd) exts (CA $ intermediate rd) (keys1 rd) 382 assertValidationResult rd checks "key-usage" [pair, intermediate rd] expected 383 where 384 checks = defaultChecks { checkLeafKeyUsage = vFlags } 385 dn = mkDn "key-usage" 386 exts = if null cFlags then [] else [mkExtension False (ExtKeyUsage cFlags)] 387 388-- | Tests 'checkLeafKeyPurpose'. 389testLeafKeyPurpose :: IO (RData pub priv) -- ^ Common test resources 390 -> TestName -- ^ Case name 391 -> [ExtKeyUsagePurpose] -- ^ Certificate flags 392 -> [ExtKeyUsagePurpose] -- ^ Flags required for validation 393 -> [FailedReason] -- ^ Expected validation result 394 -> TestTree 395testLeafKeyPurpose res caseName cFlags vFlags expected = testWithRes res caseName $ \rd -> do 396 pair <- mkCertificate 2 100 dn (present rd) exts (CA $ intermediate rd) (keys1 rd) 397 assertValidationResult rd checks "key-purpose" [pair, intermediate rd] expected 398 where 399 checks = defaultChecks { checkLeafKeyPurpose = vFlags } 400 dn = mkDn "key-purpose" 401 exts = if null cFlags then [] else [mkExtension False (ExtExtendedKeyUsage cFlags)] 402 403-- | Tests validation with multiple failure reasons in exhaustive mode. 404testExhaustive :: IO (RData pub priv) -- ^ Common test resources 405 -> String -- ^ Certificate CommonName 406 -> HostName -- ^ Connection identification 407 -> [FailedReason] -- ^ Expected validation result 408 -> TestTree 409testExhaustive res cn hostname expected = testWithRes res caseName $ \rd -> do 410 -- build an expired self-signed certificate with an invalid signature: 411 -- the certificate is actually signed by a clone using a different key 412 p1 <- mkLeaf cn (past rd) Self (keys1 rd) 413 p2 <- mkLeaf cn (past rd) (CA p1) (keys2 rd) 414 assertValidationResult rd checks hostname [p2] expected 415 where 416 caseName = if null hostname then "empty" else hostname 417 checks = defaultChecks { checkExhaustive = True } 418 419 420-- | All validation test cases. 421treeWithAlg :: TestName -> Alg pub priv -> TestTree 422treeWithAlg groupName alg = withResource (initData alg) freeData $ \res -> 423 testGroup groupName 424 [ testGroup "signature" 425 [ testSignature res "valid" intermediate intermediate [] 426 , testSignature res "invalid" intermediate intermediate0 [InvalidSignature SignatureInvalid] 427 ] 428 , testGroup "chain" 429 [ testEmpty res "empty" [EmptyChain] 430 , testIncompleteChain res "incomplete" [UnknownCA] 431 , testSelfSigned res "self-signed" [SelfSigned] 432 , testGroup "leaf-not-v3" 433 [ testLeafNotV3 res "v3-disallowed" True [LeafNotV3] 434 , testLeafNotV3 res "v3-allowed" False [] 435 ] 436 , testGroup "strict-ordering" 437 [ testStrictOrdering res "enabled" True [UnknownCA] 438 , testStrictOrdering res "disabled" False [] 439 ] 440 ] 441 , testGroup "ca-constraints" 442 [ testGroup "enabled" 443 [ testCAKeyUsage res "cert-sign" True KeyUsage_keyCertSign [] 444 , testCAKeyUsage res "crl-sign" True KeyUsage_cRLSign [NotAllowedToSign] 445 , testNotCA res "not-ca" True [NotAnAuthority] 446 , testNoBasic res "no-basic" True [NotAnAuthority] 447 , testBadDepth res "bad-depth" True [AuthorityTooDeep] 448 ] 449 , testGroup "disabled" 450 [ testCAKeyUsage res "cert-sign" False KeyUsage_keyCertSign [] 451 , testCAKeyUsage res "crl-sign" False KeyUsage_cRLSign [] 452 , testNotCA res "not-ca" False [] 453 , testNoBasic res "no-basic" False [] 454 , testBadDepth res "bad-depth" False [] 455 ] 456 ] 457 , testGroup "dates" 458 [ testGroup "leaf" 459 [ testGroup "enabled" 460 [ testLeafDates res "past" True past [Expired] 461 , testLeafDates res "present" True present [] 462 , testLeafDates res "future" True future [InFuture] 463 ] 464 , testGroup "disabled" 465 [ testLeafDates res "past" False past [] 466 , testLeafDates res "present" False present [] 467 , testLeafDates res "future" False future [] 468 ] 469 ] 470 , testGroup "intermediate" 471 [ testGroup "enabled" 472 [ testIntermediateDates res "past" True intermediatePast [Expired] 473 , testIntermediateDates res "present" True intermediate [] 474 , testIntermediateDates res "future" True intermediateFuture [InFuture] 475 ] 476 , testGroup "disabled" 477 [ testIntermediateDates res "past" False intermediatePast [] 478 , testIntermediateDates res "present" False intermediate [] 479 , testIntermediateDates res "future" False intermediateFuture [] 480 ] 481 ] 482 , testGroup "timeshift" 483 [ testGroup "at-past" 484 [ testTimeshift res "past" past intermediatePast pastDate [] 485 , testTimeshift res "present" present intermediate pastDate [InFuture] 486 , testTimeshift res "future" future intermediateFuture pastDate [InFuture] 487 ] 488 , testGroup "at-present" 489 [ testTimeshift res "past" past intermediatePast presentDate [Expired] 490 , testTimeshift res "present" present intermediate presentDate [] 491 , testTimeshift res "future" future intermediateFuture presentDate [InFuture] 492 ] 493 , testGroup "in-future" 494 [ testTimeshift res "past" past intermediatePast futureDate [Expired] 495 , testTimeshift res "present" present intermediate futureDate [Expired] 496 , testTimeshift res "future" future intermediateFuture futureDate [] 497 ] 498 ] 499 ] 500 , testGroup "CommonName" 501 [ testNoCommonName res "no-common-name" [NoCommonName] 502 , testGroup "simple" 503 [ testCommonName res "www.example.com" "www.example.com" True [] 504 , testCommonName res "www.example.com" "www2.example.com" True [NameMismatch "www2.example.com"] 505 , testCommonName res "www.example.com" "WWW.EXAMPLE.COM" True [] 506 , testCommonName res "www.example.com" "www.EXAMPLE.COM" True [] 507 , testCommonName res "www.example.com" "WWW.example.com" True [] 508 , testCommonName res "www..example.com" "www..example.com" True [NameMismatch "www..example.com"] -- InvalidName "www..example.com" 509 , testCommonName res "" "" True [NameMismatch ""] -- InvalidName "" 510 ] 511 , testGroup "wildcard" 512 [ testCommonName res "*.example.com" "example.com" True [NameMismatch "example.com"] 513 , testCommonName res "*.example.com" "www.example.com" True [] 514 , testCommonName res "*.example.com" "www.EXAMPLE.com" True [] 515 , testCommonName res "*.example.com" "www2.example.com" True [] 516 , testCommonName res "*.example.com" "www.m.example.com" True [NameMismatch "www.m.example.com"] 517 , testCommonName res "*" "single" True [NameMismatch "single"] -- InvalidWildcard 518 ] 519 , testGroup "disabled" 520 [ testCommonName res "www.example.com" "www.example.com" False [] 521 , testCommonName res "www.example.com" "www2.example.com" False [] 522 , testCommonName res "www.example.com" "WWW.EXAMPLE.COM" False [] 523 , testCommonName res "www.example.com" "www.EXAMPLE.COM" False [] 524 , testCommonName res "www.example.com" "WWW.example.com" False [] 525 , testCommonName res "www..example.com" "www..example.com" False [] 526 , testCommonName res "" "" False [] 527 ] 528 ] 529 , testGroup "SubjectAltName" 530 [ testGroup "simple" 531 [ testSubjectAltName res "www.example.com" "www.example.com" True [] 532 , testSubjectAltName res "www.example.com" "www2.example.com" True [NameMismatch "www2.example.com"] 533 , testSubjectAltName res "www.example.com" "WWW.EXAMPLE.COM" True [] 534 , testSubjectAltName res "www.example.com" "www.EXAMPLE.COM" True [] 535 , testSubjectAltName res "www.example.com" "WWW.example.com" True [] 536 , testSubjectAltName res "www..example.com" "www..example.com" True [NameMismatch "www..example.com"] -- InvalidName "www..example.com" 537 , testSubjectAltName res "" "" True [NameMismatch ""] -- InvalidName "" 538 ] 539 , testGroup "wildcard" 540 [ testSubjectAltName res "*.example.com" "example.com" True [NameMismatch "example.com"] 541 , testSubjectAltName res "*.example.com" "www.example.com" True [] 542 , testSubjectAltName res "*.example.com" "www.EXAMPLE.com" True [] 543 , testSubjectAltName res "*.example.com" "www2.example.com" True [] 544 , testSubjectAltName res "*.example.com" "www.m.example.com" True [NameMismatch "www.m.example.com"] 545 , testSubjectAltName res "*" "single" True [NameMismatch "single"] -- InvalidWildcard 546 ] 547 , testSubjectAltName res "www.example.com" "cn-not-used" True [NameMismatch "cn-not-used"] 548 , testGroup "disabled" 549 [ testSubjectAltName res "www.example.com" "www.example.com" False [] 550 , testSubjectAltName res "www.example.com" "www2.example.com" False [] 551 , testSubjectAltName res "www.example.com" "WWW.EXAMPLE.COM" False [] 552 , testSubjectAltName res "www.example.com" "www.EXAMPLE.COM" False [] 553 , testSubjectAltName res "www.example.com" "WWW.example.com" False [] 554 , testSubjectAltName res "www..example.com" "www..example.com" False [] 555 , testSubjectAltName res "" "" False [] 556 ] 557 ] 558 , testGroup "key-usage" 559 [ testLeafKeyUsage res "none" [] [u2, u3] [] 560 , testLeafKeyUsage res "valid" [u1, u2, u3] [u2, u3] [] 561 , testLeafKeyUsage res "invalid" [u1, u3] [u2, u3] [LeafKeyUsageNotAllowed] 562 ] 563 , testGroup "key-purpose" 564 [ testLeafKeyPurpose res "none" [] [p2, p3] [] 565 , testLeafKeyPurpose res "valid" [p1, p2, p3] [p2, p3] [] 566 , testLeafKeyPurpose res "invalid" [p1, p3] [p2, p3] [LeafKeyPurposeNotAllowed] 567 ] 568 , testExhaustive res "exhaustive2" "exhaustive" 569 [ SelfSigned 570 , Expired 571 , InvalidSignature SignatureInvalid 572 , NameMismatch "exhaustive" 573 ] 574 ] 575 where 576 (u1, u2, u3) = (KeyUsage_keyEncipherment, KeyUsage_dataEncipherment, KeyUsage_keyAgreement) 577 (p1, p2, p3) = (KeyUsagePurpose_ClientAuth, KeyUsagePurpose_CodeSigning, KeyUsagePurpose_EmailProtection) 578 579-- | Runs the test suite. 580main :: IO () 581main = defaultMain $ testGroup "Validation" 582 [ treeWithAlg "RSA" (AlgRSA 2048 hashSHA256) 583 , treeWithAlg "RSAPSS" (AlgRSAPSS 2048 pssParams hashSHA224) 584 , treeWithAlg "DSA" (AlgDSA dsaParams hashSHA1) 585 , treeWithAlg "ECDSA" (AlgEC curveName hashSHA512) 586 , treeWithAlg "Ed25519" AlgEd25519 587 , treeWithAlg "Ed448" AlgEd448 588 ] 589 where 590 pssParams = PSS.defaultPSSParams SHA224 591 -- DSA parameters were generated using 'openssl dsaparam -C 2048' 592 dsaParams = DSA.Params 593 { DSA.params_p = 0x9994B9B1FC22EC3A5F607B5130D314F35FC8D387015A6D8FA2B56D3CC1F13FE330A631DBC765CEFFD6986BDEB8512580BBAD93D56EE7A8997DB9C65C29313FBC5077DB6F1E9D9E6D3499F997F09C8CF8ECC9E5F38DC34C3D656CFDF463893DDF9E246E223D7E5C4E86F54426DDA5DE112FCEDBFB5B6D6F7C76ED190EA1A7761CA561E8E5803F9D616DAFF25E2CCD4011A6D78D5CE8ED28CC2D865C7EC01508BA96FBD1F8BB5E517B6A5208A90AC2D3DCAE50281C02510B86C16D449465CD4B3754FD91AA19031282122A25C68292F033091FCB9DEBDE0D220F81F7EE4AB6581D24BE48204AF3DA52BDB944DA53B76148055395B30954735DC911574D360C953B 594 , DSA.params_g = 0x10E51AEA37880C5E52DD477ED599D55050C47012D038B9E4B3199C9DE9A5B873B1ABC8B954F26AFEA6C028BCE1783CFE19A88C64E4ED6BFD638802A78457A5C25ABEA98BE9C6EF18A95504C324315EABE7C1EA50E754591E3EFD3D33D4AE47F82F8978ABC871C135133767ACC60683F065430C749C43893D73596B12D5835A78778D0140B2F63B32A5658308DD5BA6BBC49CF6692929FA6A966419404F9A2C216860E3F339EDDB49AD32C294BDB4C9C6BB0D1CC7B691C65968C3A0A5106291CD3810147C8A16B4BFE22968AD9D3890733F4AA9ACD8687A5B981653A4B1824004639956E8C1EDAF31A8224191E8ABD645D2901F5B164B4B93F98039A6EAEC6088 595 , DSA.params_q = 0xE1FDFADD32F46B5035EEB3DB81F9974FBCA69BE2223E62FCA8C77989B2AACDF7 596 } 597 curveName = ECC.SEC_p384r1 598