File Coverage

blib/lib/IO/Socket/SSL/Utils.pm
Criterion Covered Total %
statement 93 204 45.5
branch 28 104 26.9
condition 19 62 30.6
subroutine 10 19 52.6
pod 13 13 100.0
total 163 402 40.5


line stmt bran cond sub pod time code
1              
2             package IO::Socket::SSL::Utils;
3 14     14   6745 use strict;
  14         35  
  14         431  
4 14     14   74 use warnings;
  14         36  
  14         461  
5 14     14   68 use Carp 'croak';
  14         30  
  14         673  
6 14     14   110 use Net::SSLeay;
  14         26  
  14         51093  
7              
8             # old versions of Exporter do not export 'import' yet
9             require Exporter;
10             *import = \&Exporter::import;
11              
12             our $VERSION = '2.014';
13             our @EXPORT = qw(
14             PEM_file2cert PEM_string2cert PEM_cert2file PEM_cert2string
15             PEM_file2key PEM_string2key PEM_key2file PEM_key2string
16             KEY_free CERT_free
17             KEY_create_rsa CERT_asHash CERT_create
18             );
19              
20             sub PEM_file2cert {
21 10     10 1 286 my $file = shift;
22 10 50       232 my $bio = Net::SSLeay::BIO_new_file($file,'r') or
23             croak "cannot read $file: $!";
24 10         660 my $cert = Net::SSLeay::PEM_read_bio_X509($bio);
25 10         125 Net::SSLeay::BIO_free($bio);
26 10 50       35 $cert or croak "cannot parse $file as PEM X509 cert: ".
27             Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
28 10         32 return $cert;
29             }
30              
31             sub PEM_cert2file {
32 0     0 1 0 my ($cert,$file) = @_;
33 0 0       0 my $string = Net::SSLeay::PEM_get_string_X509($cert)
34             or croak("cannot get string from cert");
35 0 0       0 open( my $fh,'>',$file ) or croak("cannot write $file: $!");
36 0         0 print $fh $string;
37             }
38              
39             sub PEM_string2cert {
40 592     592 1 264328 my $string = shift;
41 592         3076 my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem());
42 592         4086 Net::SSLeay::BIO_write($bio,$string);
43 592         53424 my $cert = Net::SSLeay::PEM_read_bio_X509($bio);
44 592         3816 Net::SSLeay::BIO_free($bio);
45 592 50       2039 $cert or croak "cannot parse string as PEM X509 cert: ".
46             Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
47 592         2047 return $cert;
48             }
49              
50             sub PEM_cert2string {
51 0     0 1 0 my $cert = shift;
52 0   0     0 return Net::SSLeay::PEM_get_string_X509($cert)
53             || croak("cannot get string from cert");
54             }
55              
56             sub PEM_file2key {
57 0     0 1 0 my $file = shift;
58 0 0       0 my $bio = Net::SSLeay::BIO_new_file($file,'r') or
59             croak "cannot read $file: $!";
60 0         0 my $key = Net::SSLeay::PEM_read_bio_PrivateKey($bio);
61 0         0 Net::SSLeay::BIO_free($bio);
62 0 0       0 $key or croak "cannot parse $file as PEM private key: ".
63             Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
64 0         0 return $key;
65             }
66              
67             sub PEM_key2file {
68 0     0 1 0 my ($key,$file) = @_;
69 0 0       0 my $string = Net::SSLeay::PEM_get_string_PrivateKey($key)
70             or croak("cannot get string from key");
71 0 0       0 open( my $fh,'>',$file ) or croak("cannot write $file: $!");
72 0         0 print $fh $string;
73             }
74              
75             sub PEM_string2key {
76 0     0 1 0 my $string = shift;
77 0         0 my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem());
78 0         0 Net::SSLeay::BIO_write($bio,$string);
79 0         0 my $key = Net::SSLeay::PEM_read_bio_PrivateKey($bio);
80 0         0 Net::SSLeay::BIO_free($bio);
81 0 0       0 $key or croak "cannot parse string as PEM private key: ".
82             Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
83 0         0 return $key;
84             }
85              
86             sub PEM_key2string {
87 0     0 1 0 my $key = shift;
88 0   0     0 return Net::SSLeay::PEM_get_string_PrivateKey($key)
89             || croak("cannot get string from key");
90             }
91              
92             sub CERT_free {
93 78 50   78 1 46675 my $cert = shift or return;
94 78         1197 Net::SSLeay::X509_free($cert);
95             }
96              
97             sub KEY_free {
98 0 0   0 1 0 my $key = shift or return;
99 0         0 Net::SSLeay::EVP_PKEY_free($key);
100             }
101              
102             sub KEY_create_rsa {
103 16   50 16 1 75 my $bits = shift || 2048;
104 16         60 my $key = Net::SSLeay::EVP_PKEY_new();
105 16         1805784 my $rsa = Net::SSLeay::RSA_generate_key($bits, 0x10001); # 0x10001 = RSA_F4
106 16         268 Net::SSLeay::EVP_PKEY_assign_RSA($key,$rsa);
107 16         172 return $key;
108             }
109              
110             if (defined &Net::SSLeay::EC_KEY_generate_key) {
111             push @EXPORT,'KEY_create_ec';
112             *KEY_create_ec = sub {
113 0   0 0   0 my $curve = shift || 'prime256v1';
114 0         0 my $key = Net::SSLeay::EVP_PKEY_new();
115 0         0 my $ec = Net::SSLeay::EC_KEY_generate_key($curve);
116 0         0 Net::SSLeay::EVP_PKEY_assign_EC_KEY($key,$ec);
117 0         0 return $key;
118             }
119             }
120              
121             # extract information from cert
122             my %gen2i = qw( OTHERNAME 0 EMAIL 1 DNS 2 X400 3 DIRNAME 4 EDIPARTY 5 URI 6 IP 7 RID 8 );
123             my %i2gen = reverse %gen2i;
124             sub CERT_asHash {
125 0     0 1 0 my $cert = shift;
126 0   0     0 my $digest_name = shift || 'sha256';
127              
128 0         0 my %hash = (
129             version => Net::SSLeay::X509_get_version($cert),
130             not_before => _asn1t2t(Net::SSLeay::X509_get_notBefore($cert)),
131             not_after => _asn1t2t(Net::SSLeay::X509_get_notAfter($cert)),
132             serial => Net::SSLeay::P_ASN1_INTEGER_get_dec(
133             Net::SSLeay::X509_get_serialNumber($cert)),
134             signature_alg => Net::SSLeay::OBJ_obj2txt (
135             Net::SSLeay::P_X509_get_signature_alg($cert)),
136             crl_uri => [ Net::SSLeay::P_X509_get_crl_distribution_points($cert) ],
137             keyusage => [ Net::SSLeay::P_X509_get_key_usage($cert) ],
138             extkeyusage => {
139             oid => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,0) ],
140             nid => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,1) ],
141             sn => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,2) ],
142             ln => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,3) ],
143             },
144             "pubkey_digest_$digest_name" => Net::SSLeay::X509_pubkey_digest(
145             $cert,_digest($digest_name)),
146             "x509_digest_$digest_name" => Net::SSLeay::X509_digest(
147             $cert,_digest($digest_name)),
148             "fingerprint_$digest_name" => Net::SSLeay::X509_get_fingerprint(
149             $cert,$digest_name),
150             );
151              
152 0         0 my $subj = Net::SSLeay::X509_get_subject_name($cert);
153 0         0 my %subj;
154 0         0 for ( 0..Net::SSLeay::X509_NAME_entry_count($subj)-1 ) {
155 0         0 my $e = Net::SSLeay::X509_NAME_get_entry($subj,$_);
156 0         0 my $o = Net::SSLeay::X509_NAME_ENTRY_get_object($e);
157 0         0 $subj{ Net::SSLeay::OBJ_obj2txt($o) } =
158             Net::SSLeay::P_ASN1_STRING_get(
159             Net::SSLeay::X509_NAME_ENTRY_get_data($e));
160             }
161 0         0 $hash{subject} = \%subj;
162              
163 0 0       0 if ( my @names = Net::SSLeay::X509_get_subjectAltNames($cert) ) {
164 0         0 my $alt = $hash{subjectAltNames} = [];
165 0         0 while (my ($t,$v) = splice(@names,0,2)) {
166 0   0     0 $t = $i2gen{$t} || die "unknown type $t in subjectAltName";
167 0 0       0 if ( $t eq 'IP' ) {
168 0 0       0 if (length($v) == 4) {
    0          
169 0         0 $v = join('.',unpack("CCCC",$v));
170             } elsif ( length($v) == 16 ) {
171 0         0 my @v = unpack("nnnnnnnn",$v);
172 0         0 my ($best0,$last0);
173 0         0 for(my $i=0;$i<@v;$i++) {
174 0 0       0 if ($v[$i] == 0) {
175 0 0       0 if ($last0) {
176 0         0 $last0->[1] = $i;
177 0         0 $last0->[2]++;
178 0 0       0 $best0 = $last0 if ++$last0->[2]>$best0->[2];
179             } else {
180 0         0 $last0 = [ $i,$i,0 ];
181 0   0     0 $best0 ||= $last0;
182             }
183             } else {
184 0         0 $last0 = undef;
185             }
186             }
187 0 0       0 if ($best0) {
188 0         0 $v = '';
189 0 0       0 $v .= join(':', map { sprintf( "%x",$_) } @v[0..$best0->[0]-1]) if $best0->[0]>0;
  0         0  
190 0         0 $v .= '::';
191 0 0       0 $v .= join(':', map { sprintf( "%x",$_) } @v[$best0->[1]+1..$#v]) if $best0->[1]<$#v;
  0         0  
192             } else {
193 0         0 $v = join(':', map { sprintf( "%x",$_) } @v);
  0         0  
194             }
195             }
196             }
197 0         0 push @$alt,[$t,$v]
198             }
199             }
200              
201 0         0 my $issuer = Net::SSLeay::X509_get_issuer_name($cert);
202 0         0 my %issuer;
203 0         0 for ( 0..Net::SSLeay::X509_NAME_entry_count($issuer)-1 ) {
204 0         0 my $e = Net::SSLeay::X509_NAME_get_entry($issuer,$_);
205 0         0 my $o = Net::SSLeay::X509_NAME_ENTRY_get_object($e);
206 0         0 $issuer{ Net::SSLeay::OBJ_obj2txt($o) } =
207             Net::SSLeay::P_ASN1_STRING_get(
208             Net::SSLeay::X509_NAME_ENTRY_get_data($e));
209             }
210 0         0 $hash{issuer} = \%issuer;
211              
212 0         0 my @ext;
213 0         0 for( 0..Net::SSLeay::X509_get_ext_count($cert)-1 ) {
214 0         0 my $e = Net::SSLeay::X509_get_ext($cert,$_);
215 0         0 my $o = Net::SSLeay::X509_EXTENSION_get_object($e);
216 0         0 my $nid = Net::SSLeay::OBJ_obj2nid($o);
217 0 0       0 push @ext, {
    0          
218             oid => Net::SSLeay::OBJ_obj2txt($o),
219             nid => ( $nid > 0 ) ? $nid : undef,
220             sn => ( $nid > 0 ) ? Net::SSLeay::OBJ_nid2sn($nid) : undef,
221             critical => Net::SSLeay::X509_EXTENSION_get_critical($e),
222             data => Net::SSLeay::X509V3_EXT_print($e),
223             }
224             }
225 0         0 $hash{ext} = \@ext;
226              
227 0 0       0 if ( defined(&Net::SSLeay::P_X509_get_ocsp_uri)) {
228 0         0 $hash{ocsp_uri} = [ Net::SSLeay::P_X509_get_ocsp_uri($cert) ];
229             } else {
230 0         0 $hash{ocsp_uri} = [];
231 0         0 for( @ext ) {
232 0 0       0 $_->{sn} or next;
233 0 0       0 $_->{sn} eq 'authorityInfoAccess' or next;
234 0         0 push @{ $hash{ocsp_uri}}, $_->{data} =~m{\bOCSP - URI:(\S+)}g;
  0         0  
235             }
236             }
237              
238 0         0 return \%hash;
239             }
240              
241             sub CERT_create {
242 120 50   120 1 36919 my %args = @_%2 ? %{ shift() } : @_;
  0         0  
243              
244 120         954 my $cert = Net::SSLeay::X509_new();
245 120   50     590 my $digest_name = delete $args{digest} || 'sha256';
246              
247             Net::SSLeay::ASN1_INTEGER_set(
248             Net::SSLeay::X509_get_serialNumber($cert),
249 120   33     883 delete $args{serial} || rand(2**32),
250             );
251              
252             # version default to 2 (V3)
253             Net::SSLeay::X509_set_version($cert,
254 120   50     551 delete $args{version} || 2 );
255              
256             # not_before default to now
257             Net::SSLeay::ASN1_TIME_set(
258             Net::SSLeay::X509_get_notBefore($cert),
259             delete $args{not_before} || time()
260 120   33     1422 );
261              
262             # not_after default to now+365 days
263             Net::SSLeay::ASN1_TIME_set(
264             Net::SSLeay::X509_get_notAfter($cert),
265 120   33     782 delete $args{not_after} || time() + 365*86400
266             );
267              
268             # set subject
269 120         262 my $subj_e = Net::SSLeay::X509_get_subject_name($cert);
270             my $subj = delete $args{subject} || {
271 120   100     318 organizationName => 'IO::Socket::SSL',
272             commonName => 'IO::Socket::SSL Test'
273             };
274 120         598 while ( my ($k,$v) = each %$subj ) {
275             # Not everything we get is nice - try with MBSTRING_UTF8 first and if it
276             # fails try V_ASN1_T61STRING and finally V_ASN1_OCTET_STRING
277 116 0 33     1913 Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,0x1000,$v,-1,0)
      33        
278             or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,20,$v,-1,0)
279             or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,4,$v,-1,0)
280             or croak("failed to add entry for $k - ".
281             Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()));
282             }
283              
284 120         3281 my @ext = (
285             &Net::SSLeay::NID_subject_key_identifier => 'hash',
286             &Net::SSLeay::NID_authority_key_identifier => 'keyid',
287             );
288 120 100       3839 if ( my $altsubj = delete $args{subjectAltNames} ) {
289             push @ext,
290             &Net::SSLeay::NID_subject_alt_name =>
291 17         248 join(',', map { "$_->[0]:$_->[1]" } @$altsubj)
  46         293  
292             }
293              
294 120   66     334 my $key = delete $args{key} || KEY_create_rsa();
295 120         1115 Net::SSLeay::X509_set_pubkey($cert,$key);
296              
297 120         264 my $is = delete $args{issuer};
298 120   66     514 my $issuer_cert = delete $args{issuer_cert} || $is && $is->[0] || $cert;
299 120   66     465 my $issuer_key = delete $args{issuer_key} || $is && $is->[1] || $key;
300              
301 120         196 my %purpose;
302 120 100       261 if (my $p = delete $args{purpose}) {
303 2 50       29 if (!ref($p)) {
    50          
304 0 0 0     0 $purpose{lc($2)} = (!$1 || $1 eq '+') ? 1:0
305             while $p =~m{([+-]?)(\w+)}g;
306             } elsif (ref($p) eq 'ARRAY') {
307 0         0 for(@$p) {
308 0 0       0 m{^([+-]?)(\w+)$} or die "invalid entry in purpose: $_";
309 0 0 0     0 $purpose{lc($2)} = (!$1 || $1 eq '+') ? 1:0
310             }
311             } else {
312 2         30 while( my ($k,$v) = each %$p) {
313 2 50 33     31 $purpose{lc($k)} = ($v && $v ne '-')?1:0;
314             }
315             }
316             }
317 120 100       276 if (delete $args{CA}) {
318             # add defaults for CA
319 10         111 %purpose = (
320             ca => 1, sslca => 1, emailca => 1, objca => 1,
321             %purpose
322             );
323             }
324 120 100       250 if (!%purpose) {
325 108         360 %purpose = (server => 1, client => 1);
326             }
327              
328 120         235 my (%key_usage,%ext_key_usage,%cert_type,%basic_constraints);
329              
330 120         304 my %dS = ( digitalSignature => \%key_usage );
331 120         240 my %kE = ( keyEncipherment => \%key_usage );
332 120         397 my %CA = ( 'CA:TRUE' => \%basic_constraints, %dS, keyCertSign => \%key_usage );
333 120         200 my @disable;
334 120         3625 for(
335             [ client => { %dS, %kE, clientAuth => \%ext_key_usage, client => \%cert_type } ],
336             [ server => { %dS, %kE, serverAuth => \%ext_key_usage, server => \%cert_type } ],
337             [ email => { %dS, %kE, emailProtection => \%ext_key_usage, email => \%cert_type } ],
338             [ objsign => { %dS, %kE, codeSigning => \%ext_key_usage, objsign => \%cert_type } ],
339              
340             [ CA => { %CA }],
341             [ sslCA => { %CA, sslCA => \%cert_type }],
342             [ emailCA => { %CA, emailCA => \%cert_type }],
343             [ objCA => { %CA, objCA => \%cert_type }],
344              
345             [ emailProtection => { %dS, %kE, emailProtection => \%ext_key_usage, email => \%cert_type } ],
346             [ codeSigning => { %dS, %kE, codeSigning => \%ext_key_usage, objsign => \%cert_type } ],
347              
348             [ timeStamping => { timeStamping => \%ext_key_usage } ],
349             [ digitalSignature => { digitalSignature => \%key_usage } ],
350             [ nonRepudiation => { nonRepudiation => \%key_usage } ],
351             [ keyEncipherment => { keyEncipherment => \%key_usage } ],
352             [ dataEncipherment => { dataEncipherment => \%key_usage } ],
353             [ keyAgreement => { keyAgreement => \%key_usage } ],
354             [ keyCertSign => { keyCertSign => \%key_usage } ],
355             [ cRLSign => { cRLSign => \%key_usage } ],
356             [ encipherOnly => { encipherOnly => \%key_usage } ],
357             [ decipherOnly => { decipherOnly => \%key_usage } ],
358             [ clientAuth => { clientAuth => \%ext_key_usage } ],
359             [ serverAuth => { serverAuth => \%ext_key_usage } ],
360             ) {
361 2640 100       4517 exists $purpose{lc($_->[0])} or next;
362 258 50       595 if (delete $purpose{lc($_->[0])}) {
363 258         351 while (my($k,$h) = each %{$_->[1]}) {
  1280         2939  
364 1022         1619 $h->{$k} = 1;
365             }
366             } else {
367 0         0 push @disable, $_->[1];
368             }
369             }
370 120 50       1319 die "unknown purpose ".join(",",keys %purpose) if %purpose;
371 120         242 for(@disable) {
372 0         0 while (my($k,$h) = each %$_) {
373 0         0 delete $h->{$k};
374             }
375             }
376              
377 120 100       256 if (%basic_constraints) {
378 10         292 push @ext,&Net::SSLeay::NID_basic_constraints,
379             => join(",",'critical', sort keys %basic_constraints);
380             } else {
381 110         2989 push @ext, &Net::SSLeay::NID_basic_constraints => 'critical,CA:FALSE';
382             }
383 120 50       3630 push @ext,&Net::SSLeay::NID_key_usage
384             => join(",",'critical', sort keys %key_usage) if %key_usage;
385 120 50       3271 push @ext,&Net::SSLeay::NID_netscape_cert_type
386             => join(",",sort keys %cert_type) if %cert_type;
387 120 100       2883 push @ext,&Net::SSLeay::NID_ext_key_usage
388             => join(",",sort keys %ext_key_usage) if %ext_key_usage;
389 120         6676 Net::SSLeay::P_X509_add_extensions($cert, $issuer_cert, @ext);
390              
391 120         239 my %have_ext;
392 120         356 for(my $i=0;$i<@ext;$i+=2) {
393 727         1837 $have_ext{ $ext[$i] }++
394             }
395 120 50       181 for my $ext (@{ $args{ext} || [] }) {
  120         562  
396             my $nid = $ext->{nid}
397             || $ext->{sn} && Net::SSLeay::OBJ_sn2nid($ext->{sn})
398 0   0     0 || croak "cannot determine NID of extension";
399 0 0       0 $have_ext{$nid} and next;
400 0         0 my $val = $ext->{data};
401 0 0       0 if ($nid == 177) {
402             # authorityInfoAccess:
403             # OpenSSL i2v does not output the same way as expected by i2v :(
404 0         0 for (split(/\n/,$val)) {
405 0         0 s{ - }{;}; # "OCSP - URI:..." -> "OCSP;URI:..."
406 0 0       0 $_ = "critical,$_" if $ext->{critical};
407 0         0 Net::SSLeay::P_X509_add_extensions($cert,$issuer_cert,$nid,$_);
408             }
409             } else {
410 0 0       0 $val = "critical,$val" if $ext->{critical};
411 0         0 Net::SSLeay::P_X509_add_extensions($cert, $issuer_cert, $nid, $val);
412             }
413             }
414              
415 120         1916 Net::SSLeay::X509_set_issuer_name($cert,
416             Net::SSLeay::X509_get_subject_name($issuer_cert));
417 120         363 Net::SSLeay::X509_sign($cert,$issuer_key,_digest($digest_name));
418              
419 120         1388 return ($cert,$key);
420             }
421              
422              
423              
424             if ( defined &Net::SSLeay::ASN1_TIME_timet ) {
425             *_asn1t2t = \&Net::SSLeay::ASN1_TIME_timet
426             } else {
427             require Time::Local;
428             my %mon2i = qw(
429             Jan 0 Feb 1 Mar 2 Apr 3 May 4 Jun 5
430             Jul 6 Aug 7 Sep 8 Oct 9 Nov 10 Dec 11
431             );
432             *_asn1t2t = sub {
433             my $t = Net::SSLeay::P_ASN1_TIME_put2string( shift );
434             my ($mon,$d,$h,$m,$s,$y,$tz) = split(/[\s:]+/,$t);
435             defined( $mon = $mon2i{$mon} ) or die "invalid month in $t";
436             $tz ||= $y =~s{^(\d+)([A-Z]\S*)}{$1} && $2;
437             if ( ! $tz ) {
438             return Time::Local::timelocal($s,$m,$h,$d,$mon,$y)
439             } elsif ( $tz eq 'GMT' ) {
440             return Time::Local::timegm($s,$m,$h,$d,$mon,$y)
441             } else {
442             die "unexpected TZ $tz from ASN1_TIME_print";
443             }
444             }
445             }
446              
447             {
448             my %digest;
449             sub _digest {
450 120     120   198 my $digest_name = shift;
451 120   66     195256 return $digest{$digest_name} ||= do {
452 6         26 Net::SSLeay::SSLeay_add_ssl_algorithms();
453 6 50       16042 Net::SSLeay::EVP_get_digestbyname($digest_name)
454             or die "Digest algorithm $digest_name is not available";
455             };
456             }
457             }
458              
459              
460             1;
461              
462             __END__