Skip to content

Commit 8624801

Browse files
drieuxdrieux
committed
support for subjectAltName
1 parent 9b568ed commit 8624801

File tree

2 files changed

+176
-6
lines changed

2 files changed

+176
-6
lines changed

‎lib/LWP/Protocol/https.pm‎

Lines changed: 67 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -50,17 +50,78 @@ EOT
5050
return (%ssl_opts, $self->SUPER::_extra_sock_opts);
5151
}
5252
53+
#------------------------------------------------------------
54+
# _cn_match($common_name, $san_name)
55+
# common_name: an IA5String
56+
# san_name: subjectAltName
57+
# initially we were only concerned with the dNSName
58+
# and the 'left-most' only wildcard as noted in
59+
# https://tools.ietf.org/html/rfc6125#section-6.4.3
60+
# this method does not match any wildcarding in the
61+
# domain name as listed in section-6.4.3.3
62+
#
63+
sub _cn_match {
64+
my( $me, $common_name, $san_name ) = @_;
65+
66+
# /CN has a '*.' prefix
67+
# MUST be an FQDN -- fishing?
68+
return 0 if( $common_name =~ /^\*\./ );
69+
70+
my $re = q{}; # empty string
71+
72+
# turn a leading "*." into a regex
73+
if( $san_name =~ /^\*\./ ) {
74+
$san_name =~ s/\*//;
75+
$re = "[^.]+";
76+
}
77+
78+
# quotemeta the rest and match anchored
79+
if( $common_name =~ /^$re\Q$san_name\E$/ ) {
80+
return 1;
81+
}
82+
return 0;
83+
}
84+
85+
#-------------------------------------------------------
86+
# _in_san( cn, cert )
87+
# 'cn' of the form /CN=host_to_check ( "Common Name" form )
88+
# 'cert' any object that implements a peer_certificate('subjectAltNames') method
89+
# which will return an array of ( type-id, value ) pairings per
90+
# http://tools.ietf.org/html/rfc5280#section-4.2.1.6
91+
# if there is no subjectAltNames there is nothing more to do.
92+
# currently we have a _cn_match() that will allow for simple compare.
93+
sub _in_san
94+
{
95+
my($me, $cn, $cert) = @_;
96+
97+
# we can return early if there are no SAN options.
98+
my @sans = $cert->peer_certificate('subjectAltNames');
99+
return unless scalar @sans;
100+
101+
(my $common_name = $cn) =~ s/.*=//; # strip off the prefix.
102+
103+
# get the ( type-id, value ) pairwise
104+
# currently only the basic CN to san_name check
105+
while( my ( $type_id, $value ) = splice( @sans, 0, 2 ) ) {
106+
return 'ok' if $me->_cn_match($common_name,$value);
107+
}
108+
return;
109+
}
110+
53111
sub _check_sock
54112
{
55113
my($self, $req, $sock) = @_;
56114
my $check = $req->header("If-SSL-Cert-Subject");
57115
if (defined $check) {
58-
my $cert = $sock->get_peer_certificate ||
59-
die "Missing SSL certificate";
60-
my $subject = $cert->subject_name;
61-
die "Bad SSL certificate subject: '$subject' !~ /$check/"
62-
unless $subject =~ /$check/;
63-
$req->remove_header("If-SSL-Cert-Subject"); # don't pass it on
116+
my $cert = $sock->get_peer_certificate ||
117+
die "Missing SSL certificate";
118+
my $subject = $cert->subject_name;
119+
unless ( $subject =~ /$check/ ) {
120+
my $ok = $self->_in_san( $check, $cert);
121+
die "Bad SSL certificate subject: '$subject' !~ /$check/"
122+
unless $ok;
123+
}
124+
$req->remove_header("If-SSL-Cert-Subject"); # don't pass it on
64125
}
65126
}
66127

‎t/method_in_san.t‎

Lines changed: 109 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,109 @@
1+
use warnings;
2+
use strict;
3+
use Test::More tests => 17;
4+
#--------------------------------------------------------------
5+
# this is just for testing the '_in_san()' method
6+
#--------------------------------------------------------------
7+
use LWP::Protocol::https;
8+
sub class_under_test { return 'LWP::Protocol::https'; }
9+
#-----------------------------
10+
test__in_san();
11+
test__cn_match();
12+
13+
#-----------------
14+
sub test__in_san {
15+
my $class = class_under_test();
16+
can_ok( $class, '_in_san' );
17+
{
18+
no strict qw(refs); ## no critic (ProhibitNoStrict)
19+
no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
20+
21+
# a bit of a monkey patch to make it simpler to test
22+
# the various basic cases under test
23+
24+
my $p_cert = bless {}, 'fauxCert';
25+
my @san_list;
26+
my $p_peer_certificate = 'fauxCert::peer_certificate';
27+
local *{$p_peer_certificate} = sub {
28+
return @san_list;
29+
};
30+
31+
#-----------------------------------
32+
# We need three simple cases, one without SAN
33+
# one with a pass, one with a fail connection.
34+
# until we need to deal with more than just the simple dns_match
35+
# futureNote: what if we use the 'type_id' -- and need to dispatch
36+
# to other than the '_cn_match()' method -- we may want to extend this
37+
# basic list of tests.
38+
my @tests = (
39+
{
40+
'san' => [],
41+
'cn' => '/CN=foo.bar.baz',
42+
'want' => undef,
43+
'label' => 'empty SAN',
44+
},
45+
{
46+
'san' => [2, '*.bar.baz'],
47+
'cn' => '/CN=foo.bar.baz',
48+
'want' => 'ok',
49+
'label' => 'CN matched by wild card SAN',
50+
},
51+
{
52+
'san' => [2, '*.bar.baz',],
53+
'cn' => '/CN=cat.rat.bat',
54+
'want' => undef,
55+
'label' => 'CN not in SAN',
56+
}
57+
);
58+
59+
foreach my $test (@tests) {
60+
my ($san, $cn,$want, $label) = @{$test}{qw(san cn want label)};
61+
@san_list = @{$san};
62+
my $have = $class->_in_san($cn, $p_cert);
63+
is($have, $want, $label);
64+
}
65+
}
66+
return;
67+
}
68+
69+
sub test__cn_match {
70+
my $class = class_under_test();
71+
can_ok( $class, '_cn_match' );
72+
73+
# [ common_name , san_name, must_match , 'label' ]
74+
75+
my @fail_cases = (
76+
['hostbar.foo' ,'ho*bar.foo' ,0, 'inline wildcard' ],
77+
['host.cat.foo','host.*.foo' ,0, 'wildcard between levels' ],
78+
['host.foo.bar','*foo.bar' ,0, 'wild card without a dot'],
79+
['abcdfoo.com' ,'*.foo.com' ,0, 'different domain name'],
80+
['*.foo.com' ,'*.foo.com' ,0, 'wild card query CN must be FQDN'],
81+
['baz.foo.bar' ,'*.red.foo.bar' ,0, 'wild card from the section below'],
82+
['baz.foo.bar' ,'*.foo.bar.' ,0, 'extra dot in SAN -- "dns style" dot at the end' ],
83+
);
84+
my @ok_cases = (
85+
['baz.foo.bar' ,'baz.foo.bar' ,1, 'matches directly' ],
86+
['baz.foo.bar' ,'*.foo.bar' ,1, 'matches by wild card' ],
87+
);
88+
# Include these non-dns-specific-cases, as they could be things that
89+
# might be passed in the /CN= and be a part of the SAN, but it is
90+
# not quite clear which way they should be addressed. Nor is it clear
91+
# that they should be rejected by the _cn_match()
92+
my @non_dns_specific_cases = (
93+
['127.0.0.1' , '127.0.0.1' ,1, 'dotQuad notation' ],
94+
['[email protected]' , '[email protected]' ,1, 'email compare' ],
95+
['schem://host', 'schem://host' ,1, 'url compare' ],
96+
);
97+
my @tests = (@fail_cases, @ok_cases, @non_dns_specific_cases );
98+
99+
# now we can just iterate over the groups
100+
foreach my $test ( @tests) {
101+
my ( $cn, $san_dns, $must_match, $label ) = @{$test};
102+
my $match = $class->_cn_match($cn, $san_dns);
103+
my $test_label = sprintf("%12s ~ %14s : %s", $cn,$san_dns,$label);
104+
is($match, $must_match, $test_label);
105+
}
106+
107+
return;
108+
}
109+
# the end

0 commit comments

Comments
 (0)