aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP/InterIMAP.pm
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2015-09-11 00:20:10 +0200
committerGuilhem Moulin <guilhem@fripost.org>2015-09-11 01:00:47 +0200
commitfba1c36f3710badb61f45a406cd57425669ed2ed (patch)
tree20e876eeff414145bb5b2ce3ec95a370ad83e2e8 /lib/Net/IMAP/InterIMAP.pm
parentea086d30d021f7c018e4d307223162cf051de336 (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.pm101
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;