view release on metacpan or  search on metacpan

lib/Data/Transform/SSL.pm  view on Meta::CPAN

=head1 NAME

Data::Transform::SSL - SSL in a filter

=head1 DESCRIPTION

=head1 PUBLIC API

Data::Transform::SSL implements the L<Data::Transform> API. Only
differences and additions are documented here.

=cut

use base qw(Data::Transform);

our $VERSION = '0.03';

use Carp qw(croak);
use Scalar::Util qw(blessed);
use Net::SSLeay qw(die_now);
Net::SSLeay::load_error_strings();
Net::SSLeay::ERR_load_crypto_strings;
Net::SSLeay::SSLeay_add_ssl_algorithms();
Net::SSLeay::randomize();

sub BUF    () {  0 }
sub CTX    () {  1 }
sub SSL    () {  2 }
sub RB     () {  3 }
sub WB     () {  4 }
sub STATE  () {  5 }
sub KEY    () {  6 }
sub CERT   () {  7 }
sub TYPE   () {  8 }
sub OUTBUF () {  9 }
sub FLAGS  () { 10 }

sub STATE_DISC ()     { 0 }
sub STATE_CONN ()     { 1 }
sub STATE_SHUTDOWN () { 2 }

sub TYPE_SERVER () { 0 }
sub TYPE_CLIENT () { 1 }

# from IO::Socket::SSL
# from openssl/ssl.h, should be better in Net::SSLeay
sub SSL_SENT_SHUTDOWN     () { 1 }
sub SSL_RECEIVED_SHUTDOWN () { 2 }

# from openssl/x509_vfy.h
sub X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT () { 18 }

sub FLAGS_ALLOW_SELFSIGNED () { 0x00000001 }

sub _init {
   my ($self) = @_;

   my %args = ();
   if ($self->[TYPE] == TYPE_CLIENT) {
      # don't reference $self, so there isn't an extra reference keeping
      # it alive too long
      my $flags = $self->[FLAGS];
      $args{SSL_verify_callback} = sub {
         my ($ok, $ctx_store) = @_;
            my $cert = Net::SSLeay::X509_STORE_CTX_get_current_cert($ctx_store);
	    my $error = Net::SSLeay::X509_STORE_CTX_get_error($ctx_store);
            warn Net::SSLeay::X509_verify_cert_error_string($error);
            my $issuer = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_issuer_name($cert)); 
            my $subject = Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert));
            return 1
               if ($error == X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT and $flags & FLAGS_ALLOW_SELFSIGNED);
         return $ok;
      };
   }
   my $ctx = Net::SSLeay::CTX_new
      or die_now("Failed to create SSL_CTX $!");
   Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL())
      and die_if_ssl_error("Failed to set compatibility options");

   if ($self->[TYPE] == TYPE_SERVER) {
      Net::SSLeay::CTX_set_cipher_list($ctx, 'ALL');
      Net::SSLeay::set_cert_and_key($ctx,
            $self->[CERT],
            $self->[KEY],
         ) or die "key $!";
   } else {
      Net::SSLeay::CTX_load_verify_locations($ctx, '', '/etc/ssl/certs/');
      Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER(), $args{SSL_verify_callback});
   }
   # enable revocation checking
   # FIXME figure out how to do this only when we have a CRL because
   # certificate verifying returns an error if there isn't one.
#   my $store = Net::SSLeay::CTX_get_cert_store($ctx);
#   my $flag = Net::SSLeay::X509_V_FLAG_CRL_CHECK();
#   Net::SSLeay::X509_STORE_set_flags(
#     Net::SSLeay::CTX_get_cert_store($ctx),
#     Net::SSLeay::X509_V_FLAG_CRL_CHECK(),
#   );
   my $ssl = Net::SSLeay::new($ctx)
      or die_now("Failed to create SSL $!");
   if ($self->[TYPE] == TYPE_SERVER) {
      Net::SSLeay::set_cipher_list($ssl, 'ALL')
         or die_now("Failed to set cipher list $!");
   }
   my $rb = Net::SSLeay::BIO_new(Net::SSLeay::BIO_s_mem())
      or die_now("Could not create memory BIO $!");
   my $wb = Net::SSLeay::BIO_new(Net::SSLeay::BIO_s_mem())
      or die_now("Could not create memory BIO $!");
   Net::SSLeay::set_bio($ssl, $rb, $wb);

   @{$self}[CTX..STATE] = ($ctx, $ssl, $rb, $wb, STATE_DISC);
   return $self;
}

=head1 new

Accepts the following parameters:

=over 2

=item type