File Coverage

blib/lib/IO/Socket/SSL/Intercept.pm

Criterion	Covered	Total	%
statement	15	96	15.6
branch	0	52	0.0
condition	0	11	0.0
subroutine	5	14	35.7
pod	4	6	66.6
total	24	179	13.4

package IO::Socket::SSL::Intercept;
use strict;
use warnings;
use Carp 'croak';
use IO::Socket::SSL::Utils;
use Net::SSLeay;

our $VERSION = '2.056';


sub new {
    my ($class,%args) = @_;

    my $cacert = delete $args{proxy_cert};
    if ( ! $cacert ) {
	if ( my $f = delete $args{proxy_cert_file} ) {
	    $cacert = PEM_file2cert($f);
	} else {
	    croak "no proxy_cert or proxy_cert_file given";
	}
    }

    my $cakey  = delete $args{proxy_key};
    if ( ! $cakey ) {
	if ( my $f = delete $args{proxy_key_file} ) {
	    $cakey = PEM_file2key($f);
	} else {
	    croak "no proxy_cert or proxy_cert_file given";
	}
    }

    my $certkey = delete $args{cert_key};
    if ( ! $certkey ) {
	if ( my $f = delete $args{cert_key_file} ) {
	    $certkey = PEM_file2key($f);
	}
    }

    my $cache = delete $args{cache} || {};
    if (ref($cache) eq 'CODE') {
	# check cache type
	my $type = $cache->('type');
	if (!$type) {
	    # old cache interface - change into new interface
	    # get: $cache->(fp)
	    # set: $cache->(fp,cert,key)
	    my $oc = $cache;
	    $cache = sub {
		my ($fp,$create_cb) = @_;
		my @ck = $oc->($fp);
		$oc->($fp, @ck = &$create_cb) if !@ck;
		return @ck;
	    };
	} elsif ($type == 1) {
	    # current interface:
	    # get/set: $cache->(fp,cb_create)
	} else {
	    die "invalid type of cache: $type";
	}
    }

    my $self = bless {
	cacert => $cacert,
	cakey => $cakey,
	certkey => $certkey,
	cache => $cache,
	serial => delete $args{serial},
    };
    return $self;
}

sub DESTROY {
    # call various ssl _free routines
    my $self = shift or return;
    for ( \$self->{cacert},
	map { \$_->{cert} } ref($self->{cache}) ne 'CODE' ? values %{$self->{cache}} :()) {
	$$_ or next;
	CERT_free($$_);
	$$_ = undef;
    }
    for ( \$self->{cakey}, \$self->{pubkey} ) {
	$$_ or next;
	KEY_free($$_);
	$$_ = undef;
    }
}

sub clone_cert {
    my ($self,$old_cert,$clone_key) = @_;

    my $hash = CERT_asHash($old_cert);
    my $create_cb = sub {
	# if not in cache create new certificate based on original
	# copy most but not all extensions
	if (my $ext = $hash->{ext}) {
	    @$ext = grep {
		defined($_->{sn}) && $_->{sn} !~m{^(?:
		    authorityInfoAccess    |
		    subjectKeyIdentifier   |
		    authorityKeyIdentifier |
		    certificatePolicies    |
		    crlDistributionPoints
		)$}x
	    } @$ext;
	}
	my ($clone,$key) = CERT_create(
	    %$hash,
	    ignore_invalid_args => 1,
	    issuer_cert => $self->{cacert},
	    issuer_key => $self->{cakey},
	    key => $self->{certkey},
	    serial =>
		! defined($self->{serial}) ? (unpack('L',$hash->{x509_digest_sha256}))[0] :
		ref($self->{serial}) eq 'CODE' ? $self->{serial}($old_cert,$hash) :
		++$self->{serial},
	);
	return ($clone,$key);
    };

    $clone_key ||= substr(unpack("H*", $hash->{x509_digest_sha256}),0,32);
    my $c = $self->{cache};
    return $c->($clone_key,$create_cb) if ref($c) eq 'CODE';

    my $e = $c->{$clone_key} ||= do {
	my ($cert,$key) = &$create_cb;
	{ cert => $cert, key => $key };
    };
    $e->{atime} = time();
    return ($e->{cert},$e->{key});
}


sub STORABLE_freeze { my $self = shift; $self->serialize() }
sub STORABLE_thaw   { my ($class,undef,$data) = @_; $class->unserialize($data) }

sub serialize {
    my $self = shift;
    my $data = pack("N",2); # version
    $data .= pack("N/a", PEM_cert2string($self->{cacert}));
    $data .= pack("N/a", PEM_key2string($self->{cakey}));
    if ( $self->{certkey} ) {
	$data .= pack("N/a", PEM_key2string($self->{certkey}));
    } else {
	$data .= pack("N/a", '');
    }
    $data .= pack("N",$self->{serial});
    if ( ref($self->{cache}) eq 'HASH' ) {
	while ( my($k,$v) = each %{ $self->{cache}} ) {
	    $data .= pack("N/aN/aN/aN", $k,
		PEM_cert2string($k->{cert}),
		$k->{key} ? PEM_key2string($k->{key}) : '',
		$k->{atime});
	}
    }
    return $data;
}

sub unserialize {
    my ($class,$data) = @_;
    unpack("N",substr($data,0,4,'')) == 2 or
	croak("serialized with wrong version");
    ( my $cacert,my $cakey,my $certkey,my $serial,$data)
	= unpack("N/aN/aN/aNa*",$data);
    my $self = bless {
	serial => $serial,
	cacert => PEM_string2cert($cacert),
	cakey => PEM_string2key($cakey),
	$certkey ? ( certkey => PEM_string2key($certkey)):(),
    }, ref($class)||$class;

    $self->{cache} = {} if $data ne '';
    while ( $data ne '' ) {
	(my $key,my $cert,my $certkey, my $atime,$data) = unpack("N/aN/aNa*",$data);
	$self->{cache}{$key} = {
	    cert => PEM_string2cert($cert),
	    $key ? ( key => PEM_string2key($certkey)):(),
	    atime => $atime
	};
    }
    return $self;
}

1;

__END__