File Coverage

File:lib/Net/SSL.pm
Coverage:21.1%

linestmtbrancondsubpodcode
1package Net::SSL;
2
3
1
1
1
1
use strict;
4
1
1
1
1
use vars qw(@ISA $VERSION $NEW_ARGS);
5
6
1
1
1
1
use MIME::Base64;
7
1
1
1
1
use Socket;
8
1
1
1
1
use Carp;
9
10require IO::Socket;
11@ISA=qw(IO::Socket::INET);
12my %REAL; # private to this package only
13my $DEFAULT_VERSION = '23';
14my $CRLF = "\015\012";
15
16require Crypt::SSLeay;
17$VERSION = '2.77';
18
19sub _default_context
20{
21
1
1
    require Crypt::SSLeay::MainContext;
22
1
    Crypt::SSLeay::MainContext::main_ctx(@_);
23}
24
25sub new {
26
1
1
1
    my($class, %arg) = @_;
27
1
    local $NEW_ARGS = \%arg;
28
1
    $class->SUPER::new(%arg);
29}
30
31sub DESTROY {
32
1
1
    my $self = shift;
33
1
    delete $REAL{$self};
34
1
    local $@;
35
1
1
    eval { $self->SUPER::DESTROY; };
36}
37
38sub configure
39{
40
1
1
0
    my($self, $arg) = @_;
41
1
25
    my $ssl_version = delete $arg->{SSL_Version} ||
42      $ENV{HTTPS_VERSION} || $DEFAULT_VERSION;
43
1
33
    my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0;
44
45
1
33
    my $ctx = delete $arg->{SSL_Context} || _default_context($ssl_version);
46
47
1
    *$self->{'ssl_ctx'} = $ctx;
48
1
    *$self->{'ssl_version'} = $ssl_version;
49
1
    *$self->{'ssl_debug'} = $ssl_debug;
50
1
    *$self->{'ssl_arg'} = $arg;
51
1
    *$self->{'ssl_peer_addr'} = $arg->{PeerAddr};
52
1
    *$self->{'ssl_peer_port'} = $arg->{PeerPort};
53
1
    *$self->{'ssl_new_arg'} = $NEW_ARGS;
54
1
    *$self->{'ssl_peer_verify'} = 0;
55
56    ## Crypt::SSLeay must also aware the SSL Proxy before calling
57    ## $socket->configure($args). Because the $sock->configure() will
58    ## die when failed to resolve the destination server IP address,
59    ## whatever the SSL proxy is used or not!
60    ## - dqbai, 2003-05-10
61
1
50
    if (my $proxy = $self->proxy) {
62
0
        my ($host, $port) = split(':',$proxy);
63
0
0
        $port || die("no port given for proxy server $proxy");
64
0
        $arg->{PeerAddr} = $host;
65
0
        $arg->{PeerPort} = $port;
66    }
67
68
1
    $self->SUPER::configure($arg);
69}
70
71# override to make sure there is really a timeout
72sub timeout {
73
0
0
0
1
    shift->SUPER::timeout || 60;
74}
75
76sub connect {
77
1
1
0
    my $self = shift;
78
79    # configure certs on connect() time, so we can throw an undef
80    # and have LWP understand the error
81
1
1
    eval { $self->configure_certs(); };
82
1
50
    if($@) {
83
0
        $@ = "configure certs failed: $@, $!";
84
0
        $self->die_with_error($@);
85    }
86
87    # finished, update set_verify status
88
1
50
    if(my $rv = *$self->{'ssl_ctx'}->set_verify()) {
89
0
        *$self->{'ssl_peer_verify'} = $rv;
90    }
91
92
1
50
    if ($self->proxy) {
93        # don't die() in connect, just return undef and set $@
94
0
0
        my $proxy_connect = eval { $self->proxy_connect_helper(@_); };
95
0
0
0
        if(! $proxy_connect || $@) {
96
0
            $@ = "proxy connect failed: $@; $!";
97
0
            die $@;
98        }
99    } else {
100
1
50
        *$self->{io_socket_peername}=@_ == 1 ? $_[0] : IO::Socket::sockaddr_in(@_);
101
1
50
        if(!$self->SUPER::connect(@_)) {
102            # better to die than return here
103
1
            $@ = "Connect failed: $@; $!";
104
1
            die $@;
105        }
106    }
107
108# print "ssl_version ".*$self->{ssl_version}."\n";
109
0
0
    my $debug = *$self->{'ssl_debug'} || 0;
110
0
    my $ssl = Crypt::SSLeay::Conn->new(*$self->{'ssl_ctx'}, $debug, $self);
111
0
    my $arg = *$self->{ssl_arg};
112
0
    my $new_arg = *$self->{ssl_new_arg};
113
0
    $arg->{SSL_Debug} = $debug;
114
115
0
    eval {
116
0
0
0
        local $SIG{ALRM} = sub { $self->die_with_error("SSL connect timeout") };
117        # timeout / 2 because we have 3 possible connects here
118
0
0
        alarm_ok() && alarm($self->timeout / 2);
119
120
0
        my $rv;
121        {
122
0
0
            local $SIG{PIPE} = \¨
123
0
0
            $rv = eval { $ssl->connect; };
124        }
125
0
0
        if ($rv <= 0) {
126
0
0
            alarm_ok() && alarm(0);
127
0
            $ssl = undef;
128
0
            my %args = (%$new_arg, %$arg);
129
0
0
0
            if(*$self->{ssl_version} == 23) {
130
0
                $args{SSL_Version} = 3;
131                # the new connect might itself be overridden with a REAL SSL
132
0
                my $new_ssl = Net::SSL->new(%args);
133
0
0
                $REAL{$self} = $REAL{$new_ssl} || $new_ssl;
134
0
                return $REAL{$self};
135            } elsif(*$self->{ssl_version} == 3) {
136                # $self->die_with_error("SSL negotiation failed");
137
0
                $args{SSL_Version} = 2;
138
0
                my $new_ssl = Net::SSL->new(%args);
139
0
                $REAL{$self} = $new_ssl;
140
0
                return $new_ssl;
141            } else {
142                # don't die, but do set $@, and return undef
143
0
0
                eval { $self->die_with_error("SSL negotiation failed") };
144
0
                $@ = "$@; $!";
145
0
                die $@;
146            }
147        }
148
0
0
        alarm_ok() && alarm(0);
149    };
150
151    # odd error in eval {} block, maybe alarm outside the evals
152
0
0
    if($@) {
153
0
        $! = "$@; $!";
154
0
        die $@;
155    }
156
157    # successful SSL connection gets stored
158
0
    *$self->{'ssl_ssl'} = $ssl;
159
0
    $self;
160}
161
162sub accept
163{
164
0
0
1
    die "NYI";
165}
166
167# Delegate these calls to the Crypt::SSLeay::Conn object
168sub get_peer_certificate {
169
0
0
0
    my $self = shift;
170
0
0
    $self = $REAL{$self} || $self;
171
0
    *$self->{'ssl_ssl'}->get_peer_certificate(@_);
172}
173
174sub get_peer_verify {
175
0
0
0
    my $self = shift;
176
0
0
    $self = $REAL{$self} || $self;
177
0
    *$self->{'ssl_peer_verify'};
178}
179
180sub get_shared_ciphers {
181
0
0
0
    my $self = shift;
182
0
0
    $self = $REAL{$self} || $self;
183
0
    *$self->{'ssl_ssl'}->get_shared_ciphers(@_);
184}
185sub get_cipher {
186
0
0
0
    my $self = shift;
187
0
0
    $self = $REAL{$self} || $self;
188
0
    *$self->{'ssl_ssl'}->get_cipher(@_);
189}
190
191#sub get_peer_certificate { *{shift()}->{'ssl_ssl'}->get_peer_certificate(@_) }
192#sub get_shared_ciphers { *{shift()}->{'ssl_ssl'}->get_shared_ciphers(@_) }
193#sub get_cipher { *{shift()}->{'ssl_ssl'}->get_cipher(@_) }
194
195sub ssl_context
196{
197
0
0
0
    my $self = shift;
198
0
0
    $self = $REAL{$self} || $self;
199
0
    *$self->{'ssl_ctx'};
200}
201
202sub die_with_error
203{
204
0
0
0
    my $self=shift;
205
0
    my $reason=shift;
206
207
0
    my $errs='';
208
0
    while(my $err=Crypt::SSLeay::Err::get_error_string()) {
209
0
0
       $errs.=" | " if $errs ne '';
210
0
       $errs.=$err;
211    }
212
0
    die "$reason: $errs";
213}
214
215sub alarm_ok() {
216
0
0
0
    $^O ne 'MSWin32';
217}
218
219sub read
220{
221
0
0
0
    my $self = shift;
222
0
0
    $self = $REAL{$self} || $self;
223
224
0
    local $SIG{__DIE__} = \&Carp::confess;
225
0
0
0
    local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") };
226
227
0
0
    alarm_ok() && alarm($self->timeout);
228
0
    my $n=*$self->{'ssl_ssl'}->read(@_);
229
0
0
    $self->die_with_error("read failed") if !defined $n;
230
0
0
    alarm_ok() && alarm(0);
231
232
0
    $n;
233}
234
235sub write
236{
237
0
0
1
    my $self = shift;
238
0
0
    $self = $REAL{$self} || $self;
239
0
    my $n=*$self->{'ssl_ssl'}->write(@_);
240
0
0
    $self->die_with_error("write failed") if !defined $n;
241
0
    $n;
242}
243
244*sysread = \&read;
245*syswrite = \&write;
246
247sub print
248{
249
0
0
0
    my $self = shift;
250
0
0
    $self = $REAL{$self} || $self;
251    # should we care about $, and $\??
252    # I think it is too expensive...
253
0
    $self->write(join("", @_));
254}
255
256sub printf
257{
258
0
0
0
    my $self = shift;
259
0
0
    $self = $REAL{$self} || $self;
260
0
    my $fmt = shift;
261
0
    $self->write(sprintf($fmt, @_));
262}
263
264
265sub getchunk
266{
267
0
0
0
    my $self = shift;
268
0
0
    $self = $REAL{$self} || $self;
269
0
    my $buf = ''; # warnings
270
0
    my $n = $self->read($buf, 32*1024);
271
0
0
    return unless defined $n;
272
0
    $buf;
273}
274
275# In order to implement these we will need to add a buffer in $self.
276# Is it worth it?
277
0
0
0
sub getc { shift->_unimpl("getc"); }
278
0
0
1
sub ungetc { shift->_unimpl("ungetc"); }
279
280#sub getline { shift->_unimpl("getline"); }
281
282# This is really inefficient, but we only use it for reading the proxy response
283# so that does not really matter.
284sub getline {
285
0
0
1
    my $self = shift;
286
0
0
    $self = $REAL{$self} || $self;
287
0
    my $val="";
288
0
    my $buf;
289
0
    do {
290
0
        $self->SUPER::recv($buf, 1);
291
0
        $val = $val . $buf;
292    } until ($buf eq "\n");
293
294
0
    $val;
295}
296
297
298
0
0
1
sub getlines { shift->_unimpl("getlines"); }
299
300# XXX: no way to disable <$sock>?? (tied handle perhaps?)
301
302sub _unimpl
303{
304
0
0
    my($self, $meth) = @_;
305
0
    die "$meth not implemented for Net::SSL sockets";
306}
307
308sub get_lwp_object {
309
0
0
0
    my $self = shift;
310
311
0
    my $lwp_object;
312
0
    my $i = 0;
313
0
    while(1) {
314        package DB;
315
0
        my @stack = caller($i++);
316
0
0
        last unless @stack;
317
0
        my @stack_args = @DB::args;
318
0
0
        my $stack_object = $stack_args[0] || next;
319
0
0
        ref($stack_object) || next;
320
0
0
        if($stack_object->isa('LWP::UserAgent')) {
321
0
            $lwp_object = $stack_object;
322
0
            last;
323        }
324    }
325
326
0
    $lwp_object;
327}
328
329sub proxy_connect_helper {
330
0
0
0
    my $self = shift;
331
332
0
    my $proxy = $self->proxy;
333
0
    my ($host, $port) = split(':',$proxy);
334
0
    my $conn_ok = 0;
335
0
    my $need_auth = 0;
336
0
    my $auth_basic = 0;
337
0
    my $realm = "";
338
0
    my $length = 0;
339
0
    my $line = "<noline>";
340
0
    my $lwp_object = $self->get_lwp_object;
341
342
0
    my $iaddr = gethostbyname($host);
343
0
0
    $iaddr || die("can't resolve proxy server name: $host, $!");
344
0
0
    $port || die("no port given for proxy server $proxy");
345
346
0
0
    $self->SUPER::connect($port, $iaddr)
347      || die("proxy connect to $host:$port failed: $!");
348
349
0
    my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr});
350
0
0
    $peer_port || die("no peer port given");
351
0
0
    $peer_addr || die("no peer addr given");
352
353
0
    my $connect_string;
354
0
0
0
    if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) {
355
0
        my $user = $ENV{"HTTPS_PROXY_USERNAME"};
356
0
        my $pass = $ENV{"HTTPS_PROXY_PASSWORD"};
357
358
0
        my $credentials = encode_base64("$user:$pass", "");
359
0
        $connect_string = join($CRLF,
360                               "CONNECT $peer_addr:$peer_port HTTP/1.0",
361                               "Proxy-authorization: Basic $credentials"
362                              );
363    }else{
364
0
        $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0";
365    }
366
0
    $connect_string .= $CRLF;
367
0
0
0
    if($lwp_object && $lwp_object->agent) {
368
0
        $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF;
369    }
370
0
    $connect_string .= $CRLF;
371
372
0
    $self->SUPER::send($connect_string);
373
0
    my $header;
374
0
    my $n = $self->SUPER::sysread($header, 8192);
375
0
0
    if($header =~ /HTTP\/\d+\.\d+\s+200\s+/is) {
376
0
        $conn_ok = 1;
377    }
378
379
0
0
    unless ($conn_ok) {
380
0
        die("PROXY ERROR HEADER, could be non-SSL URL:\n$header");
381    }
382
383
0
    $conn_ok;
384}
385
386# code adapted from LWP::UserAgent, with $ua->env_proxy API
387sub proxy {
388    # don't iterate through %ENV for speed
389
2
2
0
    my $proxy_server;
390
2
    for ('HTTPS_PROXY', 'https_proxy') {
391
4
        $proxy_server = $ENV{$_};
392
4
50
        last if $proxy_server;
393    }
394
2
50
    return unless $proxy_server;
395
396
0
    $proxy_server =~ s|^https?://||i;
397
398
0
    $proxy_server;
399}
400
401sub configure_certs {
402
1
1
0
    my $self = shift;
403
1
    my $ctx = *$self->{ssl_ctx};
404
405
1
    my $count = 0;
406
1
    for ('HTTPS_PKCS12_FILE', 'HTTPS_CERT_FILE', 'HTTPS_KEY_FILE') {
407
3
        my $file = $ENV{$_};
408
3
50
        if($file) {
409
0
0
            (-e $file) or die("$file file does not exist: $!");
410
0
            $count++;
411
0
0
0
0
            if (/PKCS12/) {
412
0
                $count++;
413
0
0
                $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || die("failed to load $file: $!");
414
0
                last;
415            } elsif (/CERT/) {
416
0
0
                $ctx->use_certificate_file($file ,1) || die("failed to load $file: $!");
417            } elsif (/KEY/) {
418
0
0
                $ctx->use_PrivateKey_file($file, 1) || die("failed to load $file: $!");
419            } else {
420
0
                die("setting $_ not supported");
421            }
422        }
423    }
424
425    # if both configs are set, then verify them
426
1
50
    if (($count == 2)) {
427
0
0
        if (! $ctx->check_private_key) {
428
0
            die("Private key and certificate do not match");
429        }
430    }
431
432
1
    $count; # number of successful cert loads/checks
433}
434
4351;