1#!/usr/bin/perl
2
3# Copyright (c) 2021 Steffen Ullrich <sullr@cpan.org>
4# Public Domain
5
6use strict;
7use warnings;
8use IO::Socket::SSL::Utils;
9
10# primitive CA - ROOT
11my @ca = cert(
12    CA => 1,
13    subject => { CN => 'ROOT' }
14);
15out('caR.pem', pem(crt => $ca[0]));
16out('caR.key', pem(key => $ca[1]));
17
18# server certificate where SAN contains in-label wildcards, which a
19# client MAY choose to accept as per RFC 6125 section 6.4.3.
20my @leafcert = cert(
21    issuer => \@ca,
22    purpose => 'server',
23    subject => { CN => 'server.local' },
24    subjectAltNames => [
25	[ DNS => 'bar.server.local' ],
26	[ DNS => 'www*.server.local'],
27	[ DNS => '*.www.server.local'],
28	[ DNS => 'foo.server.local' ],
29	[ DNS => 'server.local' ],
30    ]
31);
32out('server-unusual-wildcard.pem', pem(@leafcert));
33
34@leafcert = cert(
35    issuer => \@ca,
36    purpose => 'server',
37    subject => { CN => 'server.local' },
38    subjectAltNames => [
39	[ DNS => 'bar.server.local' ],
40	[ DNS => '*.www.server.local'],
41	[ DNS => 'foo.server.local' ],
42	[ DNS => 'server.local' ],
43    ]
44);
45out('server-common-wildcard.pem', pem(@leafcert));
46
47# alternative CA - OLD_ROOT
48my @caO = cert(
49    CA => 1,
50    subject => { CN => 'OLD_ROOT' }
51);
52out('caO.pem', pem(crt => $caO[0]));
53out('caO.key', pem(key => $caO[1]));
54
55# alternative ROOT CA, signed by OLD_ROOT, same key as other ROOT CA
56my @caX = cert(
57    issuer => \@caO,
58    CA => 1,
59    subject => { CN => 'ROOT' },
60    key => $ca[1],
61);
62out('caX.pem', pem(crt => $caX[0]));
63out('caX.key', pem(key => $caX[1]));
64
65# subCA below ROOT
66my @subcaR = cert(
67    issuer => \@ca,
68    CA => 1,
69    subject => { CN => 'SubCA.of.ROOT' }
70);
71out('subcaR.pem', pem(crt => $subcaR[0]));
72out('subcaR.key', pem(key => $subcaR[1]));
73out('chainSX.pem', pem($subcaR[0]), pem($caX[0]));
74
75@leafcert = cert(
76    issuer => \@subcaR,
77    purpose => 'server',
78    subject => { CN => 'server.subca.local' },
79    subjectAltNames => [
80	[ DNS => 'server.subca.local' ],
81    ]
82);
83out('server-subca.pem', pem(@leafcert));
84out('server-subca-chainSX.pem', pem(@leafcert, $subcaR[0], $caX[0]));
85out('server-subca-chainS.pem', pem(@leafcert, $subcaR[0]));
86
87
88sub cert { CERT_create(not_after => 10*365*86400+time(), @_) }
89sub pem {
90    my @default = qw(crt key);
91    my %m = (key => \&PEM_key2string, crt => \&PEM_cert2string);
92    my $result = '';
93    while (my $f = shift(@_)) {
94	my $v;
95	if ($f =~m{^(key|crt)$}) {
96	    $v = shift(@_);
97	} else {
98	    $v = $f;
99	    $f = shift(@default) || 'crt';
100	}
101	$f = $m{$f} || die "wrong key $f";
102	$result .= $f->($v);
103    }
104    return $result;
105}
106
107sub out {
108    my $file = shift;
109    open(my $fh,'>',"$file") or die "failed to create $file: $!";
110    print $fh @_
111}
112