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__ |