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

use strict;
use warnings;

package Net::IMP::Example::LogServerCertificate;
use base 'Net::IMP::Base';
use Net::SSLeay;

use fields (
    'done',    # done or no SSL
    'sbuf',    # buffer on server side
);

use Net::IMP qw(:log :DEFAULT); # import IMP_ constants
use Net::IMP::Debug;
use Carp 'croak';

sub INTERFACE {
    return ([
	undef,
	[ IMP_PASS, IMP_PREPASS, IMP_LOG ]
    ])
}


# create new analyzer object
sub new_analyzer {
    my ($factory,%args) = @_;
    my $self = $factory->SUPER::new_analyzer(%args);

    $self->run_callback(
	# we are not interested in data from client
	[ IMP_PASS, 0, IMP_MAXOFFSET ],
	# and we will not change data from server, only inspect
	[ IMP_PREPASS, 1, IMP_MAXOFFSET ],
    );

    $self->{sbuf} = '';
    return $self;
}

sub data {
    my ($self,$dir,$data) = @_;
    return if $dir == 0; # should not happen
    return if $self->{done}; # done or no SSL
    return if $data eq ''; # eof from server

    my $buf = $self->{sbuf} .= $data;

    if ( _read_ssl_handshake($self,\$buf,2)                  # Server Hello
	and my $certs = _read_ssl_handshake($self,\$buf,11)  # Certificates
    ) {
	$self->{done} = 1;

	my ($len) = unpack("xa3",substr($certs,0,4,''));
	$len = unpack("N","\0$len");
	substr($certs,$len) = '';
	$len = unpack("N","\0".substr($certs,0,3,''));
	substr($certs,$len) = '';
	my $i = 0;
	while ($certs ne '') {
	    my $clen = unpack("N","\0".substr($certs,0,3,''));
	    my $cert = substr($certs,0,$clen,'');
	    length($cert) == $clen or
		die "invalid certificate length ($clen vs. ".length($cert).")";
	    if ( my $line = eval { _cert2line($cert) } ) {
		$self->run_callback([ IMP_LOG,1,0,0,IMP_LOG_INFO,
		    sprintf("chain[%d]: %s",$i,$line)]);
	    } else {
		warn "failed to convert cert to string: $@";
	    }
	    $i++;
	}
    }

    $self->run_callback([ IMP_PASS,1,IMP_MAXOFFSET ])
	if $self->{done};
}

sub _cert2line {
    my $der = shift;
    my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem());
    Net::SSLeay::BIO_write($bio,$der);
    my $cert = Net::SSLeay::d2i_X509_bio($bio);
    Net::SSLeay::BIO_free($bio);
    $cert or die "cannot parse certificate: ".
	Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
    my $not_before = Net::SSLeay::X509_get_notBefore($cert);
    my $not_after = Net::SSLeay::X509_get_notAfter($cert);
    $_ = Net::SSLeay::P_ASN1_TIME_put2string($_) for($not_before,$not_after);
    my $subject = Net::SSLeay::X509_NAME_oneline(
	Net::SSLeay::X509_get_subject_name($cert));
    return "$subject | $not_before - $not_after";
}


sub _read_ssl_handshake {
    my ($self,$buf,$expect_htype) = @_;
    return if length($$buf) < 22; # need way more data

    my ($ctype,$version,$len,$htype) = unpack('CnnC',$$buf);
    if ($ctype != 22) {
	debug("no SSL >=3.0 handshake record");
	goto bad;
    } elsif ( $len > 2**14 ) {
	debug("length looks way too big - assuming no ssl");
	goto bad;
    } elsif ( $htype != $expect_htype ) {
	debug("unexpected handshake type $htype - assuming no ssl");
	goto bad;
    }

    length($$buf)-5 >= $len or return; # need more data
    substr($$buf,0,5,'');
    debug("got handshake type $htype length $len");
    return substr($$buf,0,$len,'');

    bad:
    $self->{done} = 1;
    return;
}


# debugging stuff
sub _hexdump {
    my ($buf,$len) = @_;
    $buf = substr($buf,0,$len) if $len;
    my @hx = map { sprintf("%02x",$_) } unpack('C*',$buf);
    my $t = '';
    while (@hx) {
	$t .= join(' ',splice(@hx,0,16))."\n";
    }
    return $t;
}


1;

__END__