File Coverage

blib/lib/POE/Component/SSLify.pm

Criterion	Covered	Total	%
statement	94	116	81.0
branch	35	64	54.6
condition	17	36	47.2
subroutine	19	20	95.0
pod	9	9	100.0
total	174	245	71.0

#
# This file is part of POE-Component-SSLify
#
# This software is copyright (c) 2014 by Apocalypse.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict; use warnings;
package POE::Component::SSLify;
# git description: release-1.011-1-g57b6383
$POE::Component::SSLify::VERSION = '1.012';
our $AUTHORITY = 'cpan:APOCAL';

# ABSTRACT: Makes using SSL in the world of POE easy!

BEGIN {
	# should fix netbsd smoke failures, thanks BinGOs!
	#  Apocal: okay cores with a 0.9.7d I've built myself from source. Doesn't if I comment out engine lines.
	# BinGOs did an awesome job building various versions of openssl to try and track down the problem, it seems like
	# newer versions of openssl worked fine on netbsd, but I don't want to do crazy stuff like probing openssl versions
	# as it's fragile - best to let the user figure it out :)
	#
	# see http://www.cpantesters.org/cpan/report/1a660280-6eb1-11e0-a462-e9956c33433b
	# http://www.cpantesters.org/cpan/report/49a9f2aa-6df2-11e0-a462-e9956c33433b
	# http://www.cpantesters.org/cpan/report/78d9a234-6df5-11e0-a462-e9956c33433b
	# and many other reports :(
	#
	#(gdb) bt
	##0  0xbd9d3e7e in engine_table_select () from /usr/lib/libcrypto.so.2
	##1  0xbd9b3bed in ENGINE_get_default_RSA () from /usr/lib/libcrypto.so.2
	##2  0xbd9b1f6d in RSA_new_method () from /usr/lib/libcrypto.so.2
	##3  0xbd9b1cf6 in RSA_new () from /usr/lib/libcrypto.so.2
	##4  0xbd9cf8a1 in RSAPrivateKey_asn1_meth () from /usr/lib/libcrypto.so.2
	##5  0xbd9da64b in ASN1_item_ex_new () from /usr/lib/libcrypto.so.2
	##6  0xbd9da567 in ASN1_item_ex_new () from /usr/lib/libcrypto.so.2
	##7  0xbd9d88cc in ASN1_item_ex_d2i () from /usr/lib/libcrypto.so.2
	##8  0xbd9d8437 in ASN1_item_d2i () from /usr/lib/libcrypto.so.2
	##9  0xbd9cf8d5 in d2i_RSAPrivateKey () from /usr/lib/libcrypto.so.2
	##10 0xbd9ad546 in d2i_PrivateKey () from /usr/lib/libcrypto.so.2
	##11 0xbd995e63 in PEM_read_bio_PrivateKey () from /usr/lib/libcrypto.so.2
	##12 0xbd980430 in PEM_read_bio_RSAPrivateKey () from /usr/lib/libcrypto.so.2
	##13 0xbda2e9dc in SSL_CTX_use_RSAPrivateKey_file () from /usr/lib/libssl.so.3
	##14 0xbda5aabe in XS_Net__SSLeay_CTX_use_RSAPrivateKey_file (cv=0x8682c80)
	#    at SSLeay.c:1716
	##15 0x08115401 in Perl_pp_entersub () at pp_hot.c:2885
	##16 0x080e0ab7 in Perl_runops_debug () at dump.c:2049
	##17 0x08078624 in S_run_body (oldscope=1) at perl.c:2308
	##18 0x08077ef2 in perl_run (my_perl=0x823f030) at perl.c:2233
	##19 0x0805e321 in main (argc=3, argv=0xbfbfe6a0, env=0xbfbfe6b0)
	#    at perlmain.c:117
	##20 0x0805e0c6 in ___start ()
	#(gdb)
	if ( ! defined &LOAD_SSL_ENGINES ) { *LOAD_SSL_ENGINES = sub () { 0 } }
}

# We need Net::SSLeay or all's a failure!
BEGIN {
	# We need >= 1.36 because it contains a lot of important fixes
	eval "use Net::SSLeay 1.36 qw( die_now die_if_ssl_error FILETYPE_PEM )";

	# Check for errors...
	if ( $@ ) {
		# Oh boy!
		die $@;
	} else {
		# Finally, load our subclasses :)
		# ClientHandle isa ServerHandle so it will get loaded automatically
		require POE::Component::SSLify::ClientHandle;

		# Initialize Net::SSLeay
		# Taken from http://search.cpan.org/~flora/Net-SSLeay-1.36/lib/Net/SSLeay.pm#Low_level_API
		Net::SSLeay::load_error_strings();
		Net::SSLeay::SSLeay_add_ssl_algorithms();
		if ( LOAD_SSL_ENGINES ) {
			Net::SSLeay::ENGINE_load_builtin_engines();
			Net::SSLeay::ENGINE_register_all_complete();
		}
		Net::SSLeay::randomize();
	}
}

# Do the exporting magic...
use parent 'Exporter';
our @EXPORT_OK = qw(
	Client_SSLify Server_SSLify
	SSLify_Options SSLify_GetCTX SSLify_GetCipher SSLify_GetSocket SSLify_GetSSL SSLify_ContextCreate SSLify_GetStatus
);

# Bring in some socket-related stuff
use Symbol qw( gensym );

# we need IO 1.24 for it's win32 fixes but it includes IO::Handle 1.27_02 which is dev...
# unfortunately we have to jump to IO 1.25 which includes IO::Handle 1.28... argh!
use IO::Handle 1.28;

# Use Scalar::Util's weaken() for the connref stuff
use Scalar::Util qw( weaken );
use Task::Weaken 1.03; # to make sure it actually works!

# load POE ( just to fool dzil AutoPrereqs :)
require POE;

# The server-side CTX stuff
my $ctx;

# global so users of this module can override it locally
our $IGNORE_SSL_ERRORS = 0;

#pod =func Client_SSLify
#pod
#pod This function sslifies a client-side socket. You can pass several options to it:
#pod
#pod 	my $socket = shift;
#pod 	$socket = Client_SSLify( $socket, $version, $options, $ctx, $callback );
#pod 		$socket is the non-ssl socket you got from somewhere ( required )
#pod 		$version is the SSL version you want to use
#pod 		$options is the SSL options you want to use
#pod 		$ctx is the custom SSL context you want to use
#pod 		$callback is the callback hook on success/failure of sslification
#pod
#pod 		# This is an example of the callback and you should pass it as Client_SSLify( $socket, ... , \&callback );
#pod 		sub callback {
#pod 			my( $socket, $status, $errval ) = @_;
#pod 			# $socket is the original sslified socket in case you need to play with it
#pod 			# $status is either 1 or 0; with 1 signifying success and 0 failure
#pod 			# $errval will be defined if $status == 0; it's the numeric SSL error code
#pod 			# check http://www.openssl.org/docs/ssl/SSL_get_error.html for the possible error values ( and import them from Net::SSLeay! )
#pod
#pod 			# The return value from the callback is discarded
#pod 		}
#pod
#pod If $ctx is defined, SSLify will ignore $version and $options. Otherwise, it will be created from the $version and
#pod $options parameters. If all of them are undefined, it will follow the defaults in L.
#pod
#pod BEWARE: If you passed in a CTX, SSLify will do Net::SSLeay::CTX_free( $ctx ) when the
#pod socket is destroyed. This means you cannot reuse contexts!
#pod
#pod NOTE: The way to have a client socket with proper certificates set up is:
#pod
#pod 	my $socket = shift;	# get the socket from somewhere
#pod 	my $ctx = SSLify_ContextCreate( 'server.key', 'server.crt' );
#pod 	$socket = Client_SSLify( $socket, undef, undef, $ctx );
#pod
#pod NOTE: You can pass the callback anywhere in the arguments, we'll figure it out for you! If you want to call a POE event, please look
#pod into the postback/callback stuff in L.
#pod
#pod 	# we got this from POE::Wheel::SocketFactory
#pod 	sub event_SuccessEvent {
#pod 		my $socket = $_[ARG0];
#pod 		$socket = Client_SSLify( $socket, $_[SESSION]->callback( 'sslify_result' ) );
#pod 		$_[HEAP]->{client} = POE::Wheel::ReadWrite->new(
#pod 			Handle => $socket,
#pod 			...
#pod 		);
#pod 		return;
#pod 	}
#pod
#pod 	# the callback event
#pod 	sub event_sslify_result {
#pod 		my ($creation_args, $called_args) = @_[ARG0, ARG1];
#pod 		my( $socket, $status, $errval ) = @$called_args;
#pod
#pod 		if ( $status ) {
#pod 			print "Yay, SSLification worked!";
#pod 		} else {
#pod 			print "Aw, SSLification failed with error $errval";
#pod 		}
#pod 	}
#pod =cut

sub Client_SSLify {
	# Get the socket + version + options + ctx + callback
	my( $socket, $version, $options, $custom_ctx, $callback ) = @_;

	# Validation...
	if ( ! defined $socket ) {
		die "Did not get a defined socket";
	}

	# Mangle the callback stuff
	if ( defined $version and ref $version and ref( $version ) eq 'CODE' ) {
		$callback = $version;
		$version = $options = $custom_ctx = undef;
	} elsif ( defined $options and ref $options and ref( $options ) eq 'CODE' ) {
		$callback = $options;
		$options = $custom_ctx = undef;
	} elsif ( defined $custom_ctx and ref $custom_ctx and ref( $custom_ctx ) eq 'CODE' ) {
		$callback = $custom_ctx;
		$custom_ctx = undef;
	}

	# From IO::Handle POD
	# If an error occurs blocking will return undef and $! will be set.
	if ( ! defined $socket->blocking( 0 ) ) {
		die "Unable to set nonblocking mode on socket: $!";
	}

	# Now, we create the new socket and bind it to our subclass of Net::SSLeay::Handle
	my $newsock = gensym();
	tie( *$newsock, 'POE::Component::SSLify::ClientHandle', $socket, $version, $options, $custom_ctx, $callback ) or die "Unable to tie to our subclass: $!";

	# argh, store the newsock in the tied class to use for callback
	if ( defined $callback ) {
		tied( *$newsock )->{'orig_socket'} = $newsock;
		weaken( tied( *$newsock )->{'orig_socket'} );
	}

	# All done!
	return $newsock;
}

#pod =func Server_SSLify
#pod
#pod This function sslifies a server-side socket. You can pass several options to it:
#pod
#pod 	my $socket = shift;
#pod 	$socket = Server_SSLify( $socket, $ctx, $callback );
#pod 		$socket is the non-ssl socket you got from somewhere ( required )
#pod 		$ctx is the custom SSL context you want to use; overrides the global ctx set in SSLify_Options
#pod 		$callback is the callback hook on success/failure of sslification
#pod
#pod BEWARE: L must be called first if you aren't passing a $ctx. If you want to set some options per-connection, do this:
#pod
#pod 	my $socket = shift;	# get the socket from somewhere
#pod 	my $ctx = SSLify_ContextCreate();
#pod 	# set various options on $ctx as desired
#pod 	$socket = Server_SSLify( $socket, $ctx );
#pod
#pod NOTE: You can use L to modify the global, and avoid doing this on every connection if the
#pod options are the same...
#pod
#pod Please look at L for more details on the callback hook.
#pod =cut

sub Server_SSLify {
	# Get the socket!
	my( $socket, $custom_ctx, $callback ) = @_;

	# Validation...
	if ( ! defined $socket ) {
		die "Did not get a defined socket";
	}

	# If we don't have a ctx ready, we can't do anything...
	if ( ! defined $ctx and ! defined $custom_ctx ) {
		die 'Please do SSLify_Options() first ( or pass in a $ctx object )';
	}

	# mangle custom_ctx depending on callback
	if ( defined $custom_ctx and ref $custom_ctx and ref( $custom_ctx ) eq 'CODE' ) {
		$callback = $custom_ctx;
		$custom_ctx = undef;
	}

	# From IO::Handle POD
	# If an error occurs blocking will return undef and $! will be set.
	if ( ! defined $socket->blocking( 0 ) ) {
		die "Unable to set nonblocking mode on socket: $!";
	}

	# Now, we create the new socket and bind it to our subclass of Net::SSLeay::Handle
	my $newsock = gensym();
	tie( *$newsock, 'POE::Component::SSLify::ServerHandle', $socket, ( $custom_ctx || $ctx ), $callback ) or die "Unable to tie to our subclass: $!";

	# argh, store the newsock in the tied class to use for connref
	if ( defined $callback ) {
		tied( *$newsock )->{'orig_socket'} = $newsock;
		weaken( tied( *$newsock )->{'orig_socket'} );
	}

	# All done!
	return $newsock;
}

#pod =func SSLify_ContextCreate
#pod
#pod Accepts some options, and returns a brand-new Net::SSLeay context object ( $ctx )
#pod
#pod 	my $ctx = SSLify_ContextCreate( $key, $cert, $version, $options );
#pod 		$key is the certificate key file
#pod 		$cert is the certificate file
#pod 		$version is the SSL version to use
#pod 		$options is the SSL options to use
#pod
#pod You can then call various Net::SSLeay methods on the context
#pod
#pod 	my $mode = Net::SSLeay::CTX_get_mode( $ctx );
#pod
#pod By default we don't use the SSL key + certificate files
#pod
#pod By default we use the version: default. Known versions of the SSL connection - look at
#pod L for more info.
#pod
#pod 	* sslv2
#pod 	* sslv3
#pod 	* tlsv1
#pod 	* sslv23
#pod 	* default ( sslv23 )
#pod
#pod By default we don't set any options - look at L for more info.
#pod =cut

sub SSLify_ContextCreate {
	# Get the key + cert + version + options
	my( $key, $cert, $version, $options ) = @_;

	return _createSSLcontext( $key, $cert, $version, $options );
}

#pod =func SSLify_Options
#pod
#pod Call this function to initialize the global server-side context object. This will be the default context whenever you call
#pod L without passing a custom context to it.
#pod
#pod 	SSLify_Options( $key, $cert, $version, $options );
#pod 		$key is the certificate key file ( required )
#pod 		$cert is the certificate file ( required )
#pod 		$version is the SSL version to use
#pod 		$options is the SSL options to use
#pod
#pod By default we use the version: default
#pod
#pod By default we use the options: Net::SSLeay::OP_ALL
#pod
#pod Please look at L for more info on the available versions/options.
#pod =cut

sub SSLify_Options {
	# Get the key + cert + version + options
	my( $key, $cert, $version, $options ) = @_;

	# sanity
	if ( ! defined $key or ! defined $cert ) {
		die 'no key/cert specified';
	}

	# Set the default
	if ( ! defined $options ) {
		$options = Net::SSLeay::OP_ALL();
	}

	# set the context, possibly overwriting the previous one
	if ( defined $ctx ) {
		Net::SSLeay::CTX_free( $ctx );
		undef $ctx;
	}
	$ctx = _createSSLcontext( $key, $cert, $version, $options );

	# all done!
	return 1;
}

sub _createSSLcontext {
	my( $key, $cert, $version, $options ) = @_;

	my $context;
	if ( defined $version and ! ref $version ) {
		if ( $version eq 'sslv2' ) {
			$context = Net::SSLeay::CTX_v2_new();
		} elsif ( $version eq 'sslv3' ) {
			$context = Net::SSLeay::CTX_v3_new();
		} elsif ( $version eq 'tlsv1' ) {
			$context = Net::SSLeay::CTX_tlsv1_new();
		} elsif ( $version eq 'sslv23' ) {
			$context = Net::SSLeay::CTX_v23_new();
		} elsif ( $version eq 'default' ) {
			$context = Net::SSLeay::CTX_new();
		} else {
			die "unknown SSL version: $version";
		}
	} else {
		$context = Net::SSLeay::CTX_new();
	}
	if ( ! defined $context ) {
		die_now( "Failed to create SSL_CTX $!" );
		return;
	}

	# do we need to set options?
	if ( defined $options ) {
		Net::SSLeay::CTX_set_options( $context, $options );
		die_if_ssl_error( 'ssl ctx set options' ) if ! $IGNORE_SSL_ERRORS;
	}

	# do we need to set key/etc?
	if ( defined $key ) {
		# Following will ask password unless private key is not encrypted
		Net::SSLeay::CTX_use_RSAPrivateKey_file( $context, $key, FILETYPE_PEM );
		die_if_ssl_error( 'private key' ) if ! $IGNORE_SSL_ERRORS;
	}

	# Set the cert file
	if ( defined $cert ) {
		Net::SSLeay::CTX_use_certificate_chain_file( $context, $cert );
		die_if_ssl_error( 'certificate' ) if ! $IGNORE_SSL_ERRORS;
	}

	# All done!
	return $context;
}

#pod =func SSLify_GetCTX
#pod
#pod Returns the actual Net::SSLeay context object in case you wanted to play with it :)
#pod
#pod If passed in a socket, it will return that socket's $ctx instead of the global.
#pod
#pod 	my $ctx = SSLify_GetCTX();			# get the one set via SSLify_Options
#pod 	my $ctx = SSLify_GetCTX( $sslified_sock );	# get the one in the object
#pod =cut

sub SSLify_GetCTX {
	my $sock = shift;
	if ( ! defined $sock ) {
		return $ctx;
	} else {
		return tied( *$sock )->{'ctx'};
	}
}

#pod =func SSLify_GetCipher
#pod
#pod Returns the cipher used by the SSLified socket
#pod
#pod 	print "SSL Cipher is: " . SSLify_GetCipher( $sslified_sock ) . "\n";
#pod
#pod NOTE: Doing this immediately after Client_SSLify or Server_SSLify will result in "(NONE)" because the SSL handshake
#pod is not done yet. The socket is nonblocking, so you will have to wait a little bit for it to get ready.
#pod
#pod 	apoc@blackhole:~/mygit/perl-poe-sslify/examples$ perl serverclient.pl
#pod 	got connection from: 127.0.0.1 - commencing Server_SSLify()
#pod 	SSLified: 127.0.0.1 cipher type: ((NONE))
#pod 	Connected to server, commencing Client_SSLify()
#pod 	SSLified the connection to the server
#pod 	Connected to SSL server
#pod 	Input: hola
#pod 	got input from: 127.0.0.1 cipher type: (AES256-SHA) input: 'hola'
#pod 	Got Reply: hola
#pod 	Input: ^C
#pod 	stopped at serverclient.pl line 126.
#pod =cut

sub SSLify_GetCipher {
	my $sock = shift;
	return Net::SSLeay::get_cipher( tied( *$sock )->{'ssl'} );
}

#pod =func SSLify_GetSocket
#pod
#pod Returns the actual socket used by the SSLified socket, useful for stuff like getpeername()/getsockname()
#pod
#pod 	print "Remote IP is: " . inet_ntoa( ( unpack_sockaddr_in( getpeername( SSLify_GetSocket( $sslified_sock ) ) ) )[1] ) . "\n";
#pod =cut

sub SSLify_GetSocket {
	my $sock = shift;
	return tied( *$sock )->{'socket'};
}

#pod =func SSLify_GetSSL
#pod
#pod Returns the actual Net::SSLeay object so you can call methods on it
#pod
#pod 	print Net::SSLeay::dump_peer_certificate( SSLify_GetSSL( $sslified_sock ) );
#pod =cut

sub SSLify_GetSSL {
	my $sock = shift;
	return tied( *$sock )->{'ssl'};
}

#pod =func SSLify_GetStatus
#pod
#pod Returns the status of the SSL negotiation/handshake/connection. See L
#pod for more info.
#pod
#pod 	my $status = SSLify_GetStatus( $socket );
#pod 		-1 = still in negotiation stage ( or error )
#pod 		 0 = internal SSL error, connection will be dead
#pod 		 1 = negotiation successful
#pod =cut

sub SSLify_GetStatus {
	my $sock = shift;
	return tied( *$sock )->{'status'};
}

1;

__END__