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


line stmt bran cond sub pod time code
1             #
2             # This file is part of POE-Component-SSLify
3             #
4             # This software is copyright (c) 2014 by Apocalypse.
5             #
6             # This is free software; you can redistribute it and/or modify it under
7             # the same terms as the Perl 5 programming language system itself.
8             #
9 13     13   1943833 use strict; use warnings;
  13     13   34  
  13         478  
  13         68  
  13         22  
  13         1379  
10             package POE::Component::SSLify;
11             # git description: release-1.009-7-gf804305
12             $POE::Component::SSLify::VERSION = '1.010';
13             our $AUTHORITY = 'cpan:APOCAL';
14              
15             # ABSTRACT: Makes using SSL in the world of POE easy!
16              
17             BEGIN {
18             # should fix netbsd smoke failures, thanks BinGOs!
19             # Apocal: okay cores with a 0.9.7d I've built myself from source. Doesn't if I comment out engine lines.
20             # BinGOs did an awesome job building various versions of openssl to try and track down the problem, it seems like
21             # newer versions of openssl worked fine on netbsd, but I don't want to do crazy stuff like probing openssl versions
22             # as it's fragile - best to let the user figure it out :)
23             #
24             # see http://www.cpantesters.org/cpan/report/1a660280-6eb1-11e0-a462-e9956c33433b
25             # http://www.cpantesters.org/cpan/report/49a9f2aa-6df2-11e0-a462-e9956c33433b
26             # http://www.cpantesters.org/cpan/report/78d9a234-6df5-11e0-a462-e9956c33433b
27             # and many other reports :(
28             #
29             #(gdb) bt
30             ##0 0xbd9d3e7e in engine_table_select () from /usr/lib/libcrypto.so.2
31             ##1 0xbd9b3bed in ENGINE_get_default_RSA () from /usr/lib/libcrypto.so.2
32             ##2 0xbd9b1f6d in RSA_new_method () from /usr/lib/libcrypto.so.2
33             ##3 0xbd9b1cf6 in RSA_new () from /usr/lib/libcrypto.so.2
34             ##4 0xbd9cf8a1 in RSAPrivateKey_asn1_meth () from /usr/lib/libcrypto.so.2
35             ##5 0xbd9da64b in ASN1_item_ex_new () from /usr/lib/libcrypto.so.2
36             ##6 0xbd9da567 in ASN1_item_ex_new () from /usr/lib/libcrypto.so.2
37             ##7 0xbd9d88cc in ASN1_item_ex_d2i () from /usr/lib/libcrypto.so.2
38             ##8 0xbd9d8437 in ASN1_item_d2i () from /usr/lib/libcrypto.so.2
39             ##9 0xbd9cf8d5 in d2i_RSAPrivateKey () from /usr/lib/libcrypto.so.2
40             ##10 0xbd9ad546 in d2i_PrivateKey () from /usr/lib/libcrypto.so.2
41             ##11 0xbd995e63 in PEM_read_bio_PrivateKey () from /usr/lib/libcrypto.so.2
42             ##12 0xbd980430 in PEM_read_bio_RSAPrivateKey () from /usr/lib/libcrypto.so.2
43             ##13 0xbda2e9dc in SSL_CTX_use_RSAPrivateKey_file () from /usr/lib/libssl.so.3
44             ##14 0xbda5aabe in XS_Net__SSLeay_CTX_use_RSAPrivateKey_file (cv=0x8682c80)
45             # at SSLeay.c:1716
46             ##15 0x08115401 in Perl_pp_entersub () at pp_hot.c:2885
47             ##16 0x080e0ab7 in Perl_runops_debug () at dump.c:2049
48             ##17 0x08078624 in S_run_body (oldscope=1) at perl.c:2308
49             ##18 0x08077ef2 in perl_run (my_perl=0x823f030) at perl.c:2233
50             ##19 0x0805e321 in main (argc=3, argv=0xbfbfe6a0, env=0xbfbfe6b0)
51             # at perlmain.c:117
52             ##20 0x0805e0c6 in ___start ()
53             #(gdb)
54 13 50   13   129 if ( ! defined &LOAD_SSL_ENGINES ) { *LOAD_SSL_ENGINES = sub () { 0 } }
  13         1569  
55             }
56              
57             # We need Net::SSLeay or all's a failure!
58             BEGIN {
59             # We need >= 1.36 because it contains a lot of important fixes
60 13     13   932 eval "use Net::SSLeay 1.36 qw( die_now die_if_ssl_error FILETYPE_PEM )";
  13     13   10067  
  13         99012  
  13         6792  
61              
62             # Check for errors...
63 13 50       77 if ( $@ ) {
64             # Oh boy!
65 0         0 die $@;
66             } else {
67             # Finally, load our subclasses :)
68             # ClientHandle isa ServerHandle so it will get loaded automatically
69 13         7015 require POE::Component::SSLify::ClientHandle;
70              
71             # Initialize Net::SSLeay
72             # Taken from http://search.cpan.org/~flora/Net-SSLeay-1.36/lib/Net/SSLeay.pm#Low_level_API
73 13         23938 Net::SSLeay::load_error_strings();
74 13         2162 Net::SSLeay::SSLeay_add_ssl_algorithms();
75 13         19 if ( LOAD_SSL_ENGINES ) {
76             Net::SSLeay::ENGINE_load_builtin_engines();
77             Net::SSLeay::ENGINE_register_all_complete();
78             }
79 13         144 Net::SSLeay::randomize();
80             }
81             }
82              
83             # Do the exporting magic...
84 13     13   10975 use parent 'Exporter';
  13         17  
  13         78  
85             our @EXPORT_OK = qw(
86             Client_SSLify Server_SSLify
87             SSLify_Options SSLify_GetCTX SSLify_GetCipher SSLify_GetSocket SSLify_GetSSL SSLify_ContextCreate SSLify_GetStatus
88             );
89              
90             # Bring in some socket-related stuff
91 13     13   1549 use Symbol qw( gensym );
  13         646  
  13         785  
92              
93             # we need IO 1.24 for it's win32 fixes but it includes IO::Handle 1.27_02 which is dev...
94             # unfortunately we have to jump to IO 1.25 which includes IO::Handle 1.28... argh!
95 13     13   559 use IO::Handle 1.28;
  13         5980  
  13         543  
96              
97             # Use Scalar::Util's weaken() for the connref stuff
98 13     13   75 use Scalar::Util qw( weaken );
  13         21  
  13         1379  
99 13     13   7310 use Task::Weaken 1.03; # to make sure it actually works!
  13         2476  
  13         14207  
100              
101             # load POE ( just to fool dzil AutoPrereqs :)
102             require POE;
103              
104             # The server-side CTX stuff
105             my $ctx;
106              
107             # global so users of this module can override it locally
108             our $IGNORE_SSL_ERRORS = 0;
109              
110             #pod =func Client_SSLify
111             #pod
112             #pod This function sslifies a client-side socket. You can pass several options to it:
113             #pod
114             #pod my $socket = shift;
115             #pod $socket = Client_SSLify( $socket, $version, $options, $ctx, $callback );
116             #pod $socket is the non-ssl socket you got from somewhere ( required )
117             #pod $version is the SSL version you want to use
118             #pod $options is the SSL options you want to use
119             #pod $ctx is the custom SSL context you want to use
120             #pod $callback is the callback hook on success/failure of sslification
121             #pod
122             #pod # This is an example of the callback and you should pass it as Client_SSLify( $socket, ... , \&callback );
123             #pod sub callback {
124             #pod my( $socket, $status, $errval ) = @_;
125             #pod # $socket is the original sslified socket in case you need to play with it
126             #pod # $status is either 1 or 0; with 1 signifying success and 0 failure
127             #pod # $errval will be defined if $status == 0; it's the numeric SSL error code
128             #pod # check http://www.openssl.org/docs/ssl/SSL_get_error.html for the possible error values ( and import them from Net::SSLeay! )
129             #pod
130             #pod # The return value from the callback is discarded
131             #pod }
132             #pod
133             #pod If $ctx is defined, SSLify will ignore $version and $options. Otherwise, it will be created from the $version and
134             #pod $options parameters. If all of them are undefined, it will follow the defaults in L.
135             #pod
136             #pod BEWARE: If you passed in a CTX, SSLify will do Net::SSLeay::CTX_free( $ctx ) when the
137             #pod socket is destroyed. This means you cannot reuse contexts!
138             #pod
139             #pod NOTE: The way to have a client socket with proper certificates set up is:
140             #pod
141             #pod my $socket = shift; # get the socket from somewhere
142             #pod my $ctx = SSLify_ContextCreate( 'server.key', 'server.crt' );
143             #pod $socket = Client_SSLify( $socket, undef, undef, $ctx );
144             #pod
145             #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
146             #pod into the postback/callback stuff in L.
147             #pod
148             #pod # we got this from POE::Wheel::SocketFactory
149             #pod sub event_SuccessEvent {
150             #pod my $socket = $_[ARG0];
151             #pod $socket = Client_SSLify( $socket, $_[SESSION]->callback( 'sslify_result' ) );
152             #pod $_[HEAP]->{client} = POE::Wheel::ReadWrite->new(
153             #pod Handle => $socket,
154             #pod ...
155             #pod );
156             #pod return;
157             #pod }
158             #pod
159             #pod # the callback event
160             #pod sub event_sslify_result {
161             #pod my ($creation_args, $called_args) = @_[ARG0, ARG1];
162             #pod my( $socket, $status, $errval ) = @$called_args;
163             #pod
164             #pod if ( $status ) {
165             #pod print "Yay, SSLification worked!";
166             #pod } else {
167             #pod print "Aw, SSLification failed with error $errval";
168             #pod }
169             #pod }
170             #pod =cut
171              
172             sub Client_SSLify {
173             # Get the socket + version + options + ctx + callback
174 29     29 1 13919 my( $socket, $version, $options, $custom_ctx, $callback ) = @_;
175              
176             # Validation...
177 29 50       104 if ( ! defined $socket ) {
178 0         0 die "Did not get a defined socket";
179             }
180              
181             # Mangle the callback stuff
182 29 100 66     386 if ( defined $version and ref $version and ref( $version ) eq 'CODE' ) {
    50 66        
    50 33        
      33        
      33        
      33        
183 3         15 $callback = $version;
184 3         10 $version = $options = $custom_ctx = undef;
185             } elsif ( defined $options and ref $options and ref( $options ) eq 'CODE' ) {
186 0         0 $callback = $options;
187 0         0 $options = $custom_ctx = undef;
188             } elsif ( defined $custom_ctx and ref $custom_ctx and ref( $custom_ctx ) eq 'CODE' ) {
189 0         0 $callback = $custom_ctx;
190 0         0 $custom_ctx = undef;
191             }
192              
193             # From IO::Handle POD
194             # If an error occurs blocking will return undef and $! will be set.
195 29 50       205 if ( ! defined $socket->blocking( 0 ) ) {
196 0         0 die "Unable to set nonblocking mode on socket: $!";
197             }
198              
199             # Now, we create the new socket and bind it to our subclass of Net::SSLeay::Handle
200 29         119 my $newsock = gensym();
201 29 50       676 tie( *$newsock, 'POE::Component::SSLify::ClientHandle', $socket, $version, $options, $custom_ctx, $callback ) or die "Unable to tie to our subclass: $!";
202              
203             # argh, store the newsock in the tied class to use for callback
204 29 100       82 if ( defined $callback ) {
205 3         14 tied( *$newsock )->{'orig_socket'} = $newsock;
206 3         21 weaken( tied( *$newsock )->{'orig_socket'} );
207             }
208              
209             # All done!
210 29         91 return $newsock;
211             }
212              
213             #pod =func Server_SSLify
214             #pod
215             #pod This function sslifies a server-side socket. You can pass several options to it:
216             #pod
217             #pod my $socket = shift;
218             #pod $socket = Server_SSLify( $socket, $ctx, $callback );
219             #pod $socket is the non-ssl socket you got from somewhere ( required )
220             #pod $ctx is the custom SSL context you want to use; overrides the global ctx set in SSLify_Options
221             #pod $callback is the callback hook on success/failure of sslification
222             #pod
223             #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:
224             #pod
225             #pod my $socket = shift; # get the socket from somewhere
226             #pod my $ctx = SSLify_ContextCreate();
227             #pod # set various options on $ctx as desired
228             #pod $socket = Server_SSLify( $socket, $ctx );
229             #pod
230             #pod NOTE: You can use L to modify the global, and avoid doing this on every connection if the
231             #pod options are the same...
232             #pod
233             #pod Please look at L for more details on the callback hook.
234             #pod =cut
235              
236             sub Server_SSLify {
237             # Get the socket!
238 29     29 1 12681 my( $socket, $custom_ctx, $callback ) = @_;
239              
240             # Validation...
241 29 50       115 if ( ! defined $socket ) {
242 0         0 die "Did not get a defined socket";
243             }
244              
245             # If we don't have a ctx ready, we can't do anything...
246 29 0 33     95 if ( ! defined $ctx and ! defined $custom_ctx ) {
247 0         0 die 'Please do SSLify_Options() first ( or pass in a $ctx object )';
248             }
249              
250             # mangle custom_ctx depending on callback
251 29 50 66     128 if ( defined $custom_ctx and ref $custom_ctx and ref( $custom_ctx ) eq 'CODE' ) {
      66        
252 3         7 $callback = $custom_ctx;
253 3         3 $custom_ctx = undef;
254             }
255              
256             # From IO::Handle POD
257             # If an error occurs blocking will return undef and $! will be set.
258 29 50       251 if ( ! defined $socket->blocking( 0 ) ) {
259 0         0 die "Unable to set nonblocking mode on socket: $!";
260             }
261              
262             # Now, we create the new socket and bind it to our subclass of Net::SSLeay::Handle
263 29         108 my $newsock = gensym();
264 29 50 33     783 tie( *$newsock, 'POE::Component::SSLify::ServerHandle', $socket, ( $custom_ctx || $ctx ), $callback ) or die "Unable to tie to our subclass: $!";
265              
266             # argh, store the newsock in the tied class to use for connref
267 29 100       83 if ( defined $callback ) {
268 3         14 tied( *$newsock )->{'orig_socket'} = $newsock;
269 3         34 weaken( tied( *$newsock )->{'orig_socket'} );
270             }
271              
272             # All done!
273 29         92 return $newsock;
274             }
275              
276             #pod =func SSLify_ContextCreate
277             #pod
278             #pod Accepts some options, and returns a brand-new Net::SSLeay context object ( $ctx )
279             #pod
280             #pod my $ctx = SSLify_ContextCreate( $key, $cert, $version, $options );
281             #pod $key is the certificate key file
282             #pod $cert is the certificate file
283             #pod $version is the SSL version to use
284             #pod $options is the SSL options to use
285             #pod
286             #pod You can then call various Net::SSLeay methods on the context
287             #pod
288             #pod my $mode = Net::SSLeay::CTX_get_mode( $ctx );
289             #pod
290             #pod By default we don't use the SSL key + certificate files
291             #pod
292             #pod By default we use the version: default. Known versions of the SSL connection - look at
293             #pod L for more info.
294             #pod
295             #pod * sslv2
296             #pod * sslv3
297             #pod * tlsv1
298             #pod * sslv23
299             #pod * default ( sslv23 )
300             #pod
301             #pod By default we don't set any options - look at L for more info.
302             #pod =cut
303              
304             sub SSLify_ContextCreate {
305             # Get the key + cert + version + options
306 26     26 1 12254 my( $key, $cert, $version, $options ) = @_;
307              
308 26         74 return _createSSLcontext( $key, $cert, $version, $options );
309             }
310              
311             #pod =func SSLify_Options
312             #pod
313             #pod Call this function to initialize the global server-side context object. This will be the default context whenever you call
314             #pod L without passing a custom context to it.
315             #pod
316             #pod SSLify_Options( $key, $cert, $version, $options );
317             #pod $key is the certificate key file ( required )
318             #pod $cert is the certificate file ( required )
319             #pod $version is the SSL version to use
320             #pod $options is the SSL options to use
321             #pod
322             #pod By default we use the version: default
323             #pod
324             #pod By default we use the options: Net::SSLeay::OP_ALL
325             #pod
326             #pod Please look at L for more info on the available versions/options.
327             #pod =cut
328              
329             sub SSLify_Options {
330             # Get the key + cert + version + options
331 29     29 1 128482 my( $key, $cert, $version, $options ) = @_;
332              
333             # sanity
334 29 50 33     226 if ( ! defined $key or ! defined $cert ) {
335 0         0 die 'no key/cert specified';
336             }
337              
338             # Set the default
339 29 50       83 if ( ! defined $options ) {
340 29         717 $options = Net::SSLeay::OP_ALL();
341             }
342              
343             # set the context, possibly overwriting the previous one
344 29 100       1482 if ( defined $ctx ) {
345 18         163 Net::SSLeay::CTX_free( $ctx );
346 18         28 undef $ctx;
347             }
348 29         91 $ctx = _createSSLcontext( $key, $cert, $version, $options );
349              
350             # all done!
351 29         79 return 1;
352             }
353              
354             sub _createSSLcontext {
355 58     58   146 my( $key, $cert, $version, $options ) = @_;
356              
357 58         72 my $context;
358 58 100 66     307 if ( defined $version and ! ref $version ) {
359 52 50       221 if ( $version eq 'sslv2' ) {
    50          
    0          
    0          
    0          
360 0         0 $context = Net::SSLeay::CTX_v2_new();
361             } elsif ( $version eq 'sslv3' ) {
362 52         5431 $context = Net::SSLeay::CTX_v3_new();
363             } elsif ( $version eq 'tlsv1' ) {
364 0         0 $context = Net::SSLeay::CTX_tlsv1_new();
365             } elsif ( $version eq 'sslv23' ) {
366 0         0 $context = Net::SSLeay::CTX_v23_new();
367             } elsif ( $version eq 'default' ) {
368 0         0 $context = Net::SSLeay::CTX_new();
369             } else {
370 0         0 die "unknown SSL version: $version";
371             }
372             } else {
373 6         1217 $context = Net::SSLeay::CTX_new();
374             }
375 58 50       195 if ( ! defined $context ) {
376 0         0 die_now( "Failed to create SSL_CTX $!" );
377 0         0 return;
378             }
379              
380             # do we need to set options?
381 58 100       139 if ( defined $options ) {
382 29         170 Net::SSLeay::CTX_set_options( $context, $options );
383 29 50       180 die_if_ssl_error( 'ssl ctx set options' ) if ! $IGNORE_SSL_ERRORS;
384             }
385              
386             # do we need to set key/etc?
387 58 100       617 if ( defined $key ) {
388             # Following will ask password unless private key is not encrypted
389 29         537 Net::SSLeay::CTX_use_RSAPrivateKey_file( $context, $key, FILETYPE_PEM );
390 29 50       5163 die_if_ssl_error( 'private key' ) if ! $IGNORE_SSL_ERRORS;
391             }
392              
393             # Set the cert file
394 58 100       429 if ( defined $cert ) {
395 29         4282 Net::SSLeay::CTX_use_certificate_chain_file( $context, $cert );
396 29 50       205 die_if_ssl_error( 'certificate' ) if ! $IGNORE_SSL_ERRORS;
397             }
398              
399             # All done!
400 58         414 return $context;
401             }
402              
403             #pod =func SSLify_GetCTX
404             #pod
405             #pod Returns the actual Net::SSLeay context object in case you wanted to play with it :)
406             #pod
407             #pod If passed in a socket, it will return that socket's $ctx instead of the global.
408             #pod
409             #pod my $ctx = SSLify_GetCTX(); # get the one set via SSLify_Options
410             #pod my $ctx = SSLify_GetCTX( $sslified_sock ); # get the one in the object
411             #pod =cut
412              
413             sub SSLify_GetCTX {
414 0     0 1 0 my $sock = shift;
415 0 0       0 if ( ! defined $sock ) {
416 0         0 return $ctx;
417             } else {
418 0         0 return tied( *$sock )->{'ctx'};
419             }
420             }
421              
422             #pod =func SSLify_GetCipher
423             #pod
424             #pod Returns the cipher used by the SSLified socket
425             #pod
426             #pod print "SSL Cipher is: " . SSLify_GetCipher( $sslified_sock ) . "\n";
427             #pod
428             #pod NOTE: Doing this immediately after Client_SSLify or Server_SSLify will result in "(NONE)" because the SSL handshake
429             #pod is not done yet. The socket is nonblocking, so you will have to wait a little bit for it to get ready.
430             #pod
431             #pod apoc@blackhole:~/mygit/perl-poe-sslify/examples$ perl serverclient.pl
432             #pod got connection from: 127.0.0.1 - commencing Server_SSLify()
433             #pod SSLified: 127.0.0.1 cipher type: ((NONE))
434             #pod Connected to server, commencing Client_SSLify()
435             #pod SSLified the connection to the server
436             #pod Connected to SSL server
437             #pod Input: hola
438             #pod got input from: 127.0.0.1 cipher type: (AES256-SHA) input: 'hola'
439             #pod Got Reply: hola
440             #pod Input: ^C
441             #pod stopped at serverclient.pl line 126.
442             #pod =cut
443              
444             sub SSLify_GetCipher {
445 110     110 1 2286899 my $sock = shift;
446 110         1027 return Net::SSLeay::get_cipher( tied( *$sock )->{'ssl'} );
447             }
448              
449             #pod =func SSLify_GetSocket
450             #pod
451             #pod Returns the actual socket used by the SSLified socket, useful for stuff like getpeername()/getsockname()
452             #pod
453             #pod print "Remote IP is: " . inet_ntoa( ( unpack_sockaddr_in( getpeername( SSLify_GetSocket( $sslified_sock ) ) ) )[1] ) . "\n";
454             #pod =cut
455              
456             sub SSLify_GetSocket {
457 52     52 1 92 my $sock = shift;
458 52         383 return tied( *$sock )->{'socket'};
459             }
460              
461             #pod =func SSLify_GetSSL
462             #pod
463             #pod Returns the actual Net::SSLeay object so you can call methods on it
464             #pod
465             #pod print Net::SSLeay::dump_peer_certificate( SSLify_GetSSL( $sslified_sock ) );
466             #pod =cut
467              
468             sub SSLify_GetSSL {
469 3     3 1 2427 my $sock = shift;
470 3         51 return tied( *$sock )->{'ssl'};
471             }
472              
473             #pod =func SSLify_GetStatus
474             #pod
475             #pod Returns the status of the SSL negotiation/handshake/connection. See L
476             #pod for more info.
477             #pod
478             #pod my $status = SSLify_GetStatus( $socket );
479             #pod -1 = still in negotiation stage ( or error )
480             #pod 0 = internal SSL error, connection will be dead
481             #pod 1 = negotiation successful
482             #pod =cut
483              
484             sub SSLify_GetStatus {
485 10     10 1 3646 my $sock = shift;
486 10         55 return tied( *$sock )->{'status'};
487             }
488              
489             1;
490              
491             __END__