diff options
author | Guilhem Moulin <guilhem@fripost.org> | 2015-09-11 00:20:10 +0200 |
---|---|---|
committer | Guilhem Moulin <guilhem@fripost.org> | 2015-09-11 01:00:47 +0200 |
commit | fba1c36f3710badb61f45a406cd57425669ed2ed (patch) | |
tree | 20e876eeff414145bb5b2ce3ec95a370ad83e2e8 /lib/Net/IMAP/InterIMAP.pm | |
parent | ea086d30d021f7c018e4d307223162cf051de336 (diff) |
Factor the SSL code (imaps and STARTTLS).
Also, add SSL options SINGLE_ECDH_USE, SINGLE_DH_USE, NO_SSLv2, NO_SSLv3
and NO_COMPRESSION to the compiled-in CTX options.
And use SSL_MODE_AUTO_RETRY to avoid SSL_read failures during a
handshake.
Diffstat (limited to 'lib/Net/IMAP/InterIMAP.pm')
-rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 101 |
1 files changed, 50 insertions, 51 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 4222c78..0876682 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -271,28 +271,13 @@ sub new($%) { } } else { + require 'IO/Socket/INET.pm'; my %args = (Proto => 'tcp', Blocking => 1); $args{PeerHost} = $self->{host} // $self->fail("Missing option host"); $args{PeerPort} = $self->{port} // $self->fail("Missing option port"); - my $socket; - if ($self->{type} eq 'imap') { - require 'IO/Socket/INET.pm'; - $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@"); - } - else { - require 'IO/Socket/SSL.pm'; - if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { - $args{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; - } - my $fpr = delete $self->{SSL_fingerprint}; - $args{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; - $socket = IO::Socket::SSL->new(%args) - or $self->fail("Failed connect or SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); - - # ensure we're talking to the right server - $self->_fingerprint_match($socket, $fpr) if defined $fpr; - } + my $socket = IO::Socket::INET->new(%args) or $self->fail("Cannot bind: $@"); + $self->_start_ssl($socket) if $self->{type} eq 'imaps'; $socket->sockopt(SO_KEEPALIVE, 1); $self->{$_} = $socket for qw/STDOUT STDIN/; @@ -350,21 +335,7 @@ sub new($%) { if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'NO') { # RFC 2595 section 5.1 $self->fail("Server did not advertise STARTTLS capability.") unless grep {$_ eq 'STARTTLS'} @caps; - - require 'IO/Socket/SSL.pm'; - $self->_send('STARTTLS'); - - my %sslargs; - if (defined (my $vrfy = delete $self->{SSL_verify_trusted_peer})) { - $sslargs{SSL_verify_mode} = 0 if uc $vrfy eq 'NO'; - } - my $fpr = delete $self->{SSL_fingerprint}; - $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; - IO::Socket::SSL->start_SSL($self->{STDIN}, %sslargs) - or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); - - # ensure we're talking to the right server - $self->_fingerprint_match($self->{STDIN}, $fpr) if defined $fpr; + $self->_start_ssl($self->{STDIN}) if $self->{type} eq 'imaps'; # refresh the previous CAPABILITY list since the previous one could have been spoofed delete $self->{_CAPABILITIES}; @@ -1210,17 +1181,52 @@ sub push_flag_updates($$@) { # Private methods -# $self->_fingerprint_match($socket, $fingerprint) -# Croak unless the fingerprint of the peer certificate of the -# IO::Socket::SSL object doesn't match the given $fingerprint. -sub _fingerprint_match($$$) { - my ($self, $socket, $fpr) = @_; +# $self->_start_ssl($socket) +# Upgrade the $socket to IO::Socket::SSL. +sub _start_ssl($$) { + my ($self, $socket) = @_; + require 'IO/Socket/SSL.pm'; + require 'Net/SSLeay.pm'; + + my %sslargs = (SSL_create_ctx_callback => sub($) { + my $ctx = shift; + my $rv; + + # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_options.html + $rv = Net::SSLeay::CTX_get_options($ctx) + | Net::SSLeay::OP_SINGLE_ECDH_USE() + | Net::SSLeay::OP_SINGLE_DH_USE() + | Net::SSLeay::OP_NO_SSLv2() + | Net::SSLeay::OP_NO_SSLv3() + | Net::SSLeay::OP_NO_COMPRESSION(); + Net::SSLeay::CTX_set_options($ctx, $rv); + + # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html + $rv = Net::SSLeay::CTX_get_mode($ctx) + | Net::SSLeay::MODE_AUTO_RETRY() # don't fail SSL_read on renegociation + | Net::SSLeay::MODE_RELEASE_BUFFERS(); + Net::SSLeay::CTX_set_mode($ctx, $rv); + }); + + my $fpr = delete $self->{SSL_fingerprint}; + my $vrfy = delete $self->{SSL_verify_trusted_peer}; + $sslargs{SSL_verify_mode} = uc ($vrfy // 'YES') ne 'NO' ? Net::SSLeay::VERIFY_PEER() + : Net::SSLeay::VERIFY_NONE(); + $sslargs{$_} = $self->{$_} foreach grep /^SSL_/, keys %$self; + + IO::Socket::SSL->start_SSL($socket, %sslargs) + or $self->fail("Failed SSL handshake: $!\n$IO::Socket::SSL::SSL_ERROR"); + + # ensure we're talking to the right server + if (defined $fpr) { + my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256'; + my $fpr2 = $socket->get_fingerprint($algo); + $fpr =~ s/.*\$//; + $fpr2 =~ s/.*\$//; + $self->fail("Fingerprint don't match! MiTM in action?") + unless uc $fpr eq uc $fpr2; + } - my $algo = $fpr =~ /^([^\$]+)\$/ ? $1 : 'sha256'; - my $fpr2 = $socket->get_fingerprint($algo); - $fpr =~ s/.*\$//; - $fpr2 =~ s/.*\$//; - $self->fail("Fingerprint don't match! MiTM in action?") unless uc $fpr eq uc $fpr2; } @@ -1244,14 +1250,7 @@ sub _getline($;$) { # (read at most 2^14 bytes, the maximum length of an SSL # frame, to ensure to guaranty that there is no pending data) my $n = $stdout->sysread(my $buf,16384,0); - unless (defined $n) { - next unless $! == EWOULDBLOCK and - (ref $stdout ne 'IO::Socket::SSL' or - # sysread might fail if must finish a SSL handshake first - ($IO::Socket::SSL::SSL_ERROR == Net::SSLeay::ERROR_WANT_READ() or - $IO::Socket::SSL::SSL_ERROR == Net::SSLeay::ERROR_WANT_WRITE())); - $self->panic("Can't read: $!") - } + $self->panic("Can't read: $!") unless defined $n; $self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF $self->{_OUTRAWCOUNT} += $n; |