File Coverage

blib/lib/Net/IMP/Example/LogServerCertificate.pm
Criterion Covered Total %
statement 24 88 27.2
branch 0 28 0.0
condition 0 3 0.0
subroutine 8 14 57.1
pod 2 3 66.6
total 34 136 25.0


line stmt bran cond sub pod time code
1 1     1   871 use strict;
  1         2  
  1         23  
2 1     1   5 use warnings;
  1         2  
  1         30  
3              
4             package Net::IMP::Example::LogServerCertificate;
5 1     1   5 use base 'Net::IMP::Base';
  1         2  
  1         80  
6 1     1   5 use Net::SSLeay;
  1         2  
  1         41  
7              
8             use fields (
9 1         5 'done', # done or no SSL
10             'sbuf', # buffer on server side
11 1     1   5 );
  1         2  
12              
13 1     1   56 use Net::IMP qw(:log :DEFAULT); # import IMP_ constants
  1         2  
  1         143  
14 1     1   6 use Net::IMP::Debug;
  1         1  
  1         5  
15 1     1   6 use Carp 'croak';
  1         2  
  1         712  
16              
17             sub INTERFACE {
18             return ([
19             undef,
20 0     0 0   [ IMP_PASS, IMP_PREPASS, IMP_LOG ]
21             ])
22             }
23              
24              
25             # create new analyzer object
26             sub new_analyzer {
27 0     0 1   my ($factory,%args) = @_;
28 0           my $self = $factory->SUPER::new_analyzer(%args);
29              
30 0           $self->run_callback(
31             # we are not interested in data from client
32             [ IMP_PASS, 0, IMP_MAXOFFSET ],
33             # and we will not change data from server, only inspect
34             [ IMP_PREPASS, 1, IMP_MAXOFFSET ],
35             );
36              
37 0           $self->{sbuf} = '';
38 0           return $self;
39             }
40              
41             sub data {
42 0     0 1   my ($self,$dir,$data) = @_;
43 0 0         return if $dir == 0; # should not happen
44 0 0         return if $self->{done}; # done or no SSL
45 0 0         return if $data eq ''; # eof from server
46              
47 0           my $buf = $self->{sbuf} .= $data;
48              
49 0 0 0       if ( _read_ssl_handshake($self,\$buf,2) # Server Hello
50             and my $certs = _read_ssl_handshake($self,\$buf,11) # Certificates
51             ) {
52 0           $self->{done} = 1;
53              
54 0           my ($len) = unpack("xa3",substr($certs,0,4,''));
55 0           $len = unpack("N","\0$len");
56 0           substr($certs,$len) = '';
57 0           $len = unpack("N","\0".substr($certs,0,3,''));
58 0           substr($certs,$len) = '';
59 0           my $i = 0;
60 0           while ($certs ne '') {
61 0           my $clen = unpack("N","\0".substr($certs,0,3,''));
62 0           my $cert = substr($certs,0,$clen,'');
63 0 0         length($cert) == $clen or
64             die "invalid certificate length ($clen vs. ".length($cert).")";
65 0 0         if ( my $line = eval { _cert2line($cert) } ) {
  0            
66 0           $self->run_callback([ IMP_LOG,1,0,0,IMP_LOG_INFO,
67             sprintf("chain[%d]: %s",$i,$line)]);
68             } else {
69 0           warn "failed to convert cert to string: $@";
70             }
71 0           $i++;
72             }
73             }
74              
75             $self->run_callback([ IMP_PASS,1,IMP_MAXOFFSET ])
76 0 0         if $self->{done};
77             }
78              
79             sub _cert2line {
80 0     0     my $der = shift;
81 0           my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem());
82 0           Net::SSLeay::BIO_write($bio,$der);
83 0           my $cert = Net::SSLeay::d2i_X509_bio($bio);
84 0           Net::SSLeay::BIO_free($bio);
85 0 0         $cert or die "cannot parse certificate: ".
86             Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
87 0           my $not_before = Net::SSLeay::X509_get_notBefore($cert);
88 0           my $not_after = Net::SSLeay::X509_get_notAfter($cert);
89 0           $_ = Net::SSLeay::P_ASN1_TIME_put2string($_) for($not_before,$not_after);
90 0           my $subject = Net::SSLeay::X509_NAME_oneline(
91             Net::SSLeay::X509_get_subject_name($cert));
92 0           return "$subject | $not_before - $not_after";
93             }
94              
95              
96             sub _read_ssl_handshake {
97 0     0     my ($self,$buf,$expect_htype) = @_;
98 0 0         return if length($$buf) < 22; # need way more data
99              
100 0           my ($ctype,$version,$len,$htype) = unpack('CnnC',$$buf);
101 0 0         if ($ctype != 22) {
    0          
    0          
102 0           debug("no SSL >=3.0 handshake record");
103 0           goto bad;
104             } elsif ( $len > 2**14 ) {
105 0           debug("length looks way too big - assuming no ssl");
106 0           goto bad;
107             } elsif ( $htype != $expect_htype ) {
108 0           debug("unexpected handshake type $htype - assuming no ssl");
109 0           goto bad;
110             }
111              
112 0 0         length($$buf)-5 >= $len or return; # need more data
113 0           substr($$buf,0,5,'');
114 0           debug("got handshake type $htype length $len");
115 0           return substr($$buf,0,$len,'');
116              
117             bad:
118 0           $self->{done} = 1;
119 0           return;
120             }
121              
122              
123             # debugging stuff
124             sub _hexdump {
125 0     0     my ($buf,$len) = @_;
126 0 0         $buf = substr($buf,0,$len) if $len;
127 0           my @hx = map { sprintf("%02x",$_) } unpack('C*',$buf);
  0            
128 0           my $t = '';
129 0           while (@hx) {
130 0           $t .= join(' ',splice(@hx,0,16))."\n";
131             }
132 0           return $t;
133             }
134              
135              
136             1;
137              
138             __END__