add GetStatus and finalize connref stuff
Apocalypse
11 years ago
4 | 4 | We now load certificate files via CTX_use_certificate_chain_file(), thanks Zephaniah E. Loss-Cutler-Hull <warp-spam_perl@aehallh.com> |
5 | 5 | OpenSSL docs suggest it - http://www.openssl.org/docs/ssl/SSL_CTX_use_certificate.html#NOTES |
6 | 6 | PLEASE yell at me if you need the old functionality - the docs suggest this is the "better" way to do it... |
7 | ||
8 | Add the ability to pass a subref to call on connection/negotiation success, thanks Zephaniah E. Loss-Cutler-Hull <warp-spam_perl@aehallh.com> | |
9 | NOTE: This will not work if you do a renegotiation or any other zany SSL stuff! | |
10 | Add the SSLify_GetStatus function to get the status of the connection | |
7 | 11 | |
8 | 12 | 1.003 |
9 | 13 | Released: 2011-02-28 15:52:24 UTC |
28 | 28 | # again, because OpenSSL I/O functions (read, write, ...) can handle that entirely |
29 | 29 | # by self (it's needed to connect() once to determine connection type). |
30 | 30 | my $res = Net::SSLeay::connect( $ssl ) or die_if_ssl_error( 'ssl connect' ); |
31 | #warn "Net::SSLeay::connect(TIEHANDLE) -> $res"; | |
31 | ||
32 | 32 | my $self = bless { |
33 | 33 | 'ssl' => $ssl, |
34 | 34 | 'ctx' => $ctx, |
19 | 19 | # again, because OpenSSL I/O functions (read, write, ...) can handle that entirely |
20 | 20 | # by self (it's needed to accept() once to determine connection type). |
21 | 21 | my $res = Net::SSLeay::accept( $ssl ) and die_if_ssl_error( 'ssl accept' ); |
22 | #warn "Net::SSLeay::accept(TIEHANDLE) -> $res"; | |
22 | ||
23 | 23 | my $self = bless { |
24 | 24 | 'ssl' => $ssl, |
25 | 25 | 'ctx' => $ctx, |
34 | 34 | |
35 | 35 | sub _check_status { |
36 | 36 | my $self = shift; |
37 | my $method = shift; | |
38 | 37 | |
39 | 38 | # Okay, is negotiation done? |
40 | 39 | # http://www.openssl.org/docs/ssl/SSL_connect.html#RETURN_VALUES |
41 | if ( $self->{'status'} == -1 ) { | |
42 | # client or server? | |
43 | my $res; | |
44 | if ( exists $self->{'client'} ) { | |
45 | $res = Net::SSLeay::connect( $self->{'ssl'} ); | |
46 | # warn "Net::SSLeay::connect($method) -> $res"; | |
47 | } else { | |
48 | $res = Net::SSLeay::accept( $self->{'ssl'} ); | |
49 | # warn "Net::SSLeay::accept($method) -> $res"; | |
50 | } | |
51 | ||
52 | if ( $res == 0 ) { | |
53 | # TODO error? | |
54 | } elsif ( $res == 1 ) { | |
55 | $self->{'status'} = 1; | |
56 | ||
57 | # call the hook function for successful connect | |
58 | $self->{'on_connect'}->( $self ) if defined $self->{'on_connect'}; | |
59 | } | |
40 | if ( exists $self->{'client'} ) { | |
41 | $self->{'status'} = Net::SSLeay::connect( $self->{'ssl'} ); | |
42 | } else { | |
43 | $self->{'status'} = Net::SSLeay::accept( $self->{'ssl'} ); | |
44 | } | |
45 | ||
46 | if ( $self->{'status'} == 0 ) { | |
47 | # TODO error? | |
48 | } elsif ( $self->{'status'} == 1 ) { | |
49 | # call the hook function for successful connect | |
50 | $self->{'on_connect'}->( $self->{'orig_socket'} ) if defined $self->{'on_connect'}; | |
60 | 51 | } |
61 | 52 | } |
62 | 53 | |
69 | 60 | my( $buf, $len, $offset ) = \( @_ ); |
70 | 61 | |
71 | 62 | # Check connection status |
72 | $self->_check_status( 'READ' ); | |
63 | $self->_check_status if $self->{'status'} == -1; | |
73 | 64 | |
74 | 65 | # If we have no offset, replace the buffer with some input |
75 | 66 | if ( ! defined $$offset ) { |
109 | 100 | my( $self, $buf, $len, $offset ) = @_; |
110 | 101 | |
111 | 102 | # Check connection status |
112 | $self->_check_status( 'WRITE' ); | |
103 | $self->_check_status if $self->{'status'} == -1; | |
113 | 104 | |
114 | 105 | # If we have nothing to offset, then start from the beginning |
115 | 106 | if ( ! defined $offset ) { |
29 | 29 | # Do the exporting magic... |
30 | 30 | require Exporter; |
31 | 31 | our @ISA = qw( Exporter ); |
32 | our @EXPORT_OK = qw( Client_SSLify Server_SSLify SSLify_Options SSLify_GetCTX SSLify_GetCipher SSLify_GetSocket SSLify_GetSSL SSLify_ContextCreate ); | |
32 | our @EXPORT_OK = qw( | |
33 | Client_SSLify Server_SSLify | |
34 | SSLify_Options SSLify_GetCTX SSLify_GetCipher SSLify_GetSocket SSLify_GetSSL SSLify_ContextCreate SSLify_GetStatus | |
35 | ); | |
33 | 36 | |
34 | 37 | # Bring in some socket-related stuff |
35 | 38 | use Symbol qw( gensym ); |
37 | 40 | # we need IO 1.24 for it's win32 fixes but it includes IO::Handle 1.27_02 which is dev... |
38 | 41 | # unfortunately we have to jump to IO 1.25 which includes IO::Handle 1.28... argh! |
39 | 42 | use IO::Handle 1.28; |
43 | ||
44 | # Use Scalar::Util's weaken() for the connref stuff | |
45 | use Scalar::Util qw( weaken ); | |
46 | use Task::Weaken 1.03; # to make sure it actually works! | |
40 | 47 | |
41 | 48 | # The server-side CTX stuff |
42 | 49 | my $ctx = undef; |
53 | 60 | $socket = Client_SSLify( $socket ); # the default |
54 | 61 | $socket = Client_SSLify( $socket, $version, $options ); # sets more options for the context |
55 | 62 | $socket = Client_SSLify( $socket, undef, undef, $ctx ); # pass in a custom context |
56 | $socket = Client_SSLify( $socket, sub { print "CONNECTED" } ); # call your connection function | |
63 | $socket = Client_SSLify( $socket, sub { warn "CONNECTED" } ); # call your connection function | |
57 | 64 | |
58 | 65 | If $ctx is defined, SSLify will ignore other args. If $ctx isn't defined, SSLify |
59 | 66 | will create it from the $version + $options parameters. |
114 | 121 | my $newsock = gensym(); |
115 | 122 | tie( *$newsock, 'POE::Component::SSLify::ClientHandle', $socket, $version, $options, $ctx, $connref ) or die "Unable to tie to our subclass: $!"; |
116 | 123 | |
124 | # argh, store the newsock in the tied class to use for connref | |
125 | if ( defined $connref ) { | |
126 | tied( *$newsock )->{'orig_socket'} = $newsock; | |
127 | weaken( tied( *$newsock )->{'orig_socket'} ); | |
128 | } | |
129 | ||
117 | 130 | # All done! |
118 | 131 | return $newsock; |
119 | 132 | } |
124 | 137 | to call when connection/negotiation is done. |
125 | 138 | |
126 | 139 | my $socket = shift; # get the socket from somewhere |
127 | $socket = Server_SSLify( $socket ); | |
140 | $socket = Server_SSLify( $socket ); # the default | |
128 | 141 | $socket = Server_SSLify( $socket, $ctx ); # use your custom context |
129 | $socket = Server_SSLify( $socket, sub { print "CONNECTED" } ); # call your connection function | |
142 | $socket = Server_SSLify( $socket, sub { warn "CONNECTED" } ); # call your connection function | |
130 | 143 | |
131 | 144 | NOTE: SSLify_Options must be set first! |
132 | 145 | |
176 | 189 | # Now, we create the new socket and bind it to our subclass of Net::SSLeay::Handle |
177 | 190 | my $newsock = gensym(); |
178 | 191 | tie( *$newsock, 'POE::Component::SSLify::ServerHandle', $socket, ( $custom_ctx || $ctx ), $connref ) or die "Unable to tie to our subclass: $!"; |
192 | ||
193 | # argh, store the newsock in the tied class to use for connref | |
194 | if ( defined $connref ) { | |
195 | tied( *$newsock )->{'orig_socket'} = $newsock; | |
196 | weaken( tied( *$newsock )->{'orig_socket'} ); | |
197 | } | |
179 | 198 | |
180 | 199 | # All done! |
181 | 200 | return $newsock; |
371 | 390 | return tied( *$sock )->{'ssl'}; |
372 | 391 | } |
373 | 392 | |
393 | =func SSLify_GetStatus | |
394 | ||
395 | Returns the status of the SSL negotiation/handshake/connection. | |
396 | ||
397 | -1 == still in negotiation stage | |
398 | 0 == internal SSL error, connection will be dead | |
399 | 1 == negotiation successful | |
400 | =cut | |
401 | ||
402 | sub SSLify_GetStatus { | |
403 | my $sock = shift; | |
404 | return tied( *$sock )->{'status'}; | |
405 | } | |
406 | ||
374 | 407 | 1; |
375 | 408 | |
376 | 409 | =pod |
0 | #!/usr/bin/perl | |
1 | ||
2 | # Thanks to ASCENT for this test! | |
3 | ||
4 | use strict; use warnings; | |
5 | ||
6 | my $numtests; | |
7 | BEGIN { | |
8 | $numtests = 14; | |
9 | ||
10 | # disabled for testing now... | |
11 | # eval "use Test::NoWarnings"; | |
12 | # if ( ! $@ ) { | |
13 | # # increment by one | |
14 | # $numtests++; | |
15 | # | |
16 | # } | |
17 | } | |
18 | ||
19 | use Test::More tests => $numtests; | |
20 | ||
21 | use POE 1.267; | |
22 | use POE::Component::Client::TCP; | |
23 | use POE::Component::Server::TCP; | |
24 | use POE::Component::SSLify qw/Client_SSLify Server_SSLify SSLify_Options SSLify_GetCipher SSLify_ContextCreate SSLify_GetSocket SSLify_GetSSL/; | |
25 | ||
26 | # TODO rewrite this to use Test::POE::Server::TCP and stuff :) | |
27 | ||
28 | my $port; | |
29 | ||
30 | POE::Component::Server::TCP->new | |
31 | ( | |
32 | Alias => 'myserver', | |
33 | Address => '127.0.0.1', | |
34 | Port => 0, | |
35 | ||
36 | Started => sub | |
37 | { | |
38 | use Socket qw/sockaddr_in/; | |
39 | $port = (sockaddr_in($_[HEAP]->{listener}->getsockname))[0]; | |
40 | }, | |
41 | ClientConnected => sub | |
42 | { | |
43 | ok(1, 'SERVER: accepted'); | |
44 | }, | |
45 | ClientDisconnected => sub | |
46 | { | |
47 | ok(1, 'SERVER: client disconnected'); | |
48 | $_[KERNEL]->post( 'myserver' => 'shutdown'); | |
49 | }, | |
50 | ClientPreConnect => sub | |
51 | { | |
52 | eval { SSLify_Options('mylib/example.key', 'mylib/example.crt', 'sslv3') }; | |
53 | eval { SSLify_Options('../mylib/example.key', '../mylib/example.crt', 'sslv3') } if ($@); | |
54 | ok(!$@, "SERVER: SSLify_Options $@"); | |
55 | ||
56 | my $socket = eval { Server_SSLify( $_[ARG0], sub { | |
57 | pass( "Got connect hook for server" ); | |
58 | } ) }; | |
59 | ok(!$@, "SERVER: Server_SSLify $@"); | |
60 | ok(1, 'SERVER: SSLify_GetCipher: '. SSLify_GetCipher($socket)); | |
61 | ||
62 | # We pray that IO::Handle is sane... | |
63 | ok( SSLify_GetSocket( $socket )->blocking == 0, 'SERVER: SSLified socket is non-blocking?'); | |
64 | ||
65 | return ($socket); | |
66 | }, | |
67 | ClientInput => sub | |
68 | { | |
69 | my ($kernel, $heap, $line) = @_[KERNEL, HEAP, ARG0]; | |
70 | ||
71 | die "Unknown line from CLIENT: $line"; | |
72 | }, | |
73 | ClientError => sub | |
74 | { | |
75 | # Thanks to H. Merijn Brand for spotting this FAIL in 5.12.0! | |
76 | # The default PoCo::Server::TCP handler will throw a warning, which causes Test::NoWarnings to FAIL :( | |
77 | my ($syscall, $errno, $error) = @_[ ARG0..ARG2 ]; | |
78 | ||
79 | # TODO are there other "errors" that is harmless? | |
80 | $error = "Normal disconnection" unless $error; | |
81 | my $msg = "Got SERVER $syscall error $errno: $error"; | |
82 | unless ( $syscall eq 'read' and $errno == 0 ) { | |
83 | fail( $msg ); | |
84 | } else { | |
85 | diag( $msg ) if $ENV{TEST_VERBOSE}; | |
86 | } | |
87 | }, | |
88 | ); | |
89 | ||
90 | POE::Component::Client::TCP->new | |
91 | ( | |
92 | Alias => 'myclient', | |
93 | RemoteAddress => '127.0.0.1', | |
94 | RemotePort => $port, | |
95 | Connected => sub | |
96 | { | |
97 | ok(1, 'CLIENT: connected'); | |
98 | }, | |
99 | PreConnect => sub | |
100 | { | |
101 | my $ctx = eval { SSLify_ContextCreate(undef, undef, 'sslv3') }; | |
102 | ok(!$@, "CLIENT: SSLify_ContextCreate $@"); | |
103 | my $socket = eval { Client_SSLify($_[ARG0], undef, undef, $ctx, sub { | |
104 | pass( "Got connect hook for client" ); | |
105 | $poe_kernel->post( 'myclient' => 'shutdown' ); | |
106 | }) }; | |
107 | ok(!$@, "CLIENT: Client_SSLify $@"); | |
108 | ok(1, 'CLIENT: SSLify_GetCipher: '. SSLify_GetCipher($socket)); | |
109 | ||
110 | # We pray that IO::Handle is sane... | |
111 | ok( SSLify_GetSocket( $socket )->blocking == 0, 'CLIENT: SSLified socket is non-blocking?'); | |
112 | ||
113 | return ($socket); | |
114 | }, | |
115 | ServerInput => sub | |
116 | { | |
117 | my ($kernel, $heap, $line) = @_[KERNEL, HEAP, ARG0]; | |
118 | ||
119 | $kernel->yield('shutdown'); | |
120 | }, | |
121 | ServerError => sub | |
122 | { | |
123 | # Thanks to H. Merijn Brand for spotting this FAIL in 5.12.0! | |
124 | # The default PoCo::Client::TCP handler will throw a warning, which causes Test::NoWarnings to FAIL :( | |
125 | my ($syscall, $errno, $error) = @_[ ARG0..ARG2 ]; | |
126 | ||
127 | # TODO are there other "errors" that is harmless? | |
128 | $error = "Normal disconnection" unless $error; | |
129 | my $msg = "Got CLIENT $syscall error $errno: $error"; | |
130 | unless ( $syscall eq 'read' and $errno == 0 ) { | |
131 | fail( $msg ); | |
132 | } else { | |
133 | diag( $msg ) if $ENV{TEST_VERBOSE}; | |
134 | } | |
135 | }, | |
136 | ); | |
137 | ||
138 | $poe_kernel->run(); | |
139 | ||
140 | pass( 'shut down sanely' ); | |
141 | ||
142 | exit 0; |