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.

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;