From 90d926f6f32dd3ff06e5c49e6a982777ead9f691 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 15 Sep 2015 16:48:29 +0200 Subject: Remove support for the Binary Content extension [RFC3516]. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit “If the server does not know how to decode the section's CTE, it MUST fail the request and issue a "NO" response that contains the "UNKNOWN-CTE" extended response code.” — [RFC3516 section 4.3] Unfortunately the client doesn't know which message couldn't be decoded, so it can't fallback and use BODY instead. This made ‘use-binary=NO’ pretty much mandatory. Hence we remove support for BINARY [RFC3516]. Instead, we increase the thresold for when to add Zlib full flush points from 4096 to the buffer size (32768). --- lib/Net/IMAP/InterIMAP.pm | 39 +++++++++++---------------------------- 1 file changed, 11 insertions(+), 28 deletions(-) (limited to 'lib/Net/IMAP/InterIMAP.pm') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 6f44879..a761614 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -772,9 +772,7 @@ sub remove_message($@) { # Issue an APPEND command with the given mails. Croak if the server # did not advertise "UIDPLUS" (RFC 4315) in its CAPABILITY list. # Each $mail is a hash reference with key 'RFC822' and optionally -# 'FLAGS' and 'INTERNALDATE'. If the server supports the "BINARY" -# extension (RFC 3516), the key 'RFC822' can be replaced with 'BINARY' -# to send the mail body as a binary literal. +# 'FLAGS' and 'INTERNALDATE'. # Providing multiple mails is only allowed for servers supporting # "MULTIAPPEND" (RFC 3502). # Return the list of UIDs allocated for the new messages. @@ -801,11 +799,8 @@ sub append($$@) { my $str = ' '; $str .= '('.join(' ', grep {lc $_ ne '\recent'} @{$mail->{FLAGS}}).') ' if defined $mail->{FLAGS}; $str .= '"'.$mail->{INTERNALDATE}.'" ' if defined $mail->{INTERNALDATE}; - my ($body, $t) = defined $mail->{RFC822} ? ($mail->{RFC822}, 0) - : defined $mail->{BINARY} ? ($mail->{BINARY}, 1) - : $self->panic("Missing message body in APPEND"); $self->_cmd_extend(\$str); - $self->_cmd_extend_lit($body, $t); + $self->_cmd_extend_lit($mail->{RFC822} // $self->panic("Missing message body in APPEND")); } $self->_cmd_flush(); @@ -1075,8 +1070,7 @@ sub pull_updates($;$) { # FETCH new messages since the UIDNEXT found in the persistent cache # (or 1 in no such UIDNEXT is found), and process each response on the # fly with the callback. -# The list of attributes to FETCH, $attr, much contain either BODY or -# BINARY. +# The list of attributes to FETCH, $attr, must contain BODY[]. # If an @ignore list is supplied, then these messages are ignored from # the UID FETCH range. # Finally, update the UIDNEXT from the persistent cache to the value @@ -1582,20 +1576,17 @@ sub _cmd_extend($$) { } -# $self->_cmd_extend_lit($lit, [$lit8]) +# $self->_cmd_extend_lit($lit) # Append the literal $lit to the command buffer. $lit must be a -# scalar reference. If $lit8 is true, a literal8 is sent instead [RFC -# 3516]. -sub _cmd_extend_lit($$;$) { - my ($self, $lit, $lit8) = @_; +# scalar reference. +sub _cmd_extend_lit($$) { + my ($self, $lit) = @_; my $len = length($$lit); my $d = $self->{_Z_DEFLATE}; - # create a full flush point for long binary literals - my $z_flush = ($len > 4096 and !($self->{'use-binary'} // 1 and !$lit8)) ? 1 : 0; - $lit8 = $lit8 ? '~' : ''; # literal8, RFC 3516 BINARY - - my $strlen = $lit8.'{'.$len.$self->{_LITPLUS}.'}'.$CRLF; + # create a full flush point for long literals, cf. RFC 4978 section 4 + my $z_flush = $len > $BUFSIZE ? 1 : 0; + my $strlen = "{$len$self->{_LITPLUS}}$CRLF"; if ($self->{_LITPLUS} ne '') { $self->_cmd_extend_(\$strlen); @@ -2086,14 +2077,6 @@ sub _resp($$;$$$) { elsif (s/\A(?:RFC822|BODY\[\]) //) { $mail{RFC822} = \$self->_nstring(\$_); } - elsif (s/\ABINARY\[\] //) { - if (s/\A~\{([0-9]+)\}\z//) { # literal8, RFC 3516 BINARY - (my $lit, $_) = $self->_getline($1); - $mail{BINARY} = $lit; - } else { - $mail{RFC822} = \$self->_nstring(\$_); - } - } elsif (s/\AFLAGS \((\\?$RE_ATOM_CHAR+(?: \\?$RE_ATOM_CHAR+)*)?\)//) { $mail{FLAGS} = defined $1 ? [ split / /, $1 ] : []; } @@ -2103,7 +2086,7 @@ sub _resp($$;$$$) { my $uid = $mail{UID} // $self->panic(); # sanity check $self->panic() unless defined $mail{MODSEQ} or !$self->_enabled('QRESYNC'); # sanity check - if (!exists $mail{RFC822} and !exists $mail{BINARY} and !exists $mail{ENVELOPE} and # ignore new mails + if (!exists $mail{RFC822} and !exists $mail{ENVELOPE} and # ignore new mails (!exists $self->{_MODIFIED}->{$uid} or $self->{_MODIFIED}->{$uid}->[0] < $mail{MODSEQ} or ($self->{_MODIFIED}->{$uid}->[0] == $mail{MODSEQ} and !defined $self->{_MODIFIED}->{$uid}->[1]))) { my $flags = join ' ', sort(grep {lc $_ ne '\recent'} @{$mail{FLAGS}}) if defined $mail{FLAGS}; -- cgit v1.2.3 From 40864537f86e31e037a1232f015a06e9d73bf1e6 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 15 Sep 2015 18:24:43 +0200 Subject: Don't set SO_KEEPALIVE on the socket. This is most likely useless in our case since the TCP keepalive time is usually much higher than the IMAP timeout. --- lib/Net/IMAP/InterIMAP.pm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'lib/Net/IMAP/InterIMAP.pm') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index a761614..a0be91e 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -26,7 +26,7 @@ use IO::Select (); use Net::SSLeay (); use List::Util 'first'; use POSIX ':signal_h'; -use Socket qw/SOL_SOCKET SO_KEEPALIVE SOCK_STREAM IPPROTO_TCP AF_INET AF_INET6 SOCK_RAW :addrinfo/; +use Socket qw/SOCK_STREAM IPPROTO_TCP AF_INET AF_INET6 SOCK_RAW :addrinfo/; use Exporter 'import'; BEGIN { @@ -289,7 +289,6 @@ sub new($%) { } my $socket = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/}) : $self->_tcp_connect(@$self{qw/host port/}); - setsockopt($socket, SOL_SOCKET, SO_KEEPALIVE, 1) or $self->fail("Can't setsockopt SO_KEEPALIVE: $!"); $self->_start_ssl($socket) if $self->{type} eq 'imaps'; $self->{$_} = $socket for qw/STDOUT STDIN/; -- cgit v1.2.3 From 0e1e8e06debc4d7b00670eaa981ca5b382d90591 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Wed, 16 Sep 2015 16:49:00 +0200 Subject: Set X.509 certificate purpose to 'SSL Server' for SSL_verify=YES. --- lib/Net/IMAP/InterIMAP.pm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lib/Net/IMAP/InterIMAP.pm') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index a0be91e..53fddec 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1398,6 +1398,8 @@ sub _start_ssl($$) { or $self->_ssl_error("Can't load verify locations"); } Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER()); + Net::SSLeay::CTX_set_purpose($ctx, Net::SSLeay::X509_PURPOSE_SSL_SERVER()) + or $self->_ssl_error("Can't set purpose"); } else { Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_NONE()); -- cgit v1.2.3 From cad0e125728658e4e899201e7cedc86036908057 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Wed, 16 Sep 2015 18:05:29 +0200 Subject: Display the certificate chain, SSL protocol and cipher in debug mode. --- lib/Net/IMAP/InterIMAP.pm | 45 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) (limited to 'lib/Net/IMAP/InterIMAP.pm') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 53fddec..f54f239 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1364,6 +1364,35 @@ sub _proxify($$$$) { } +# $self->_ssl_verify($self, $preverify_ok, $x509_ctx) +# SSL verify callback function, see +# https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_verify.html +sub _ssl_verify($$$) { + my ($self, $ok, $x509_ctx) = @_; + return 0 unless $x509_ctx; # reject + + my $depth = Net::SSLeay::X509_STORE_CTX_get_error_depth($x509_ctx); + my $cert = Net::SSLeay::X509_STORE_CTX_get_current_cert($x509_ctx) + or $self->_ssl_error("Can't get current certificate"); + if ($self->{debug}) { + $self->log("[$depth] preverify=$ok"); + $self->log(' Issuer Name: ', Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_issuer_name($cert))); + $self->log(' Subject Name: ', Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert))); + } + + if ($depth == 0) { + if ($self->{debug}) { + my $algo = 'sha256'; + my $type = Net::SSLeay::EVP_get_digestbyname($algo) + or $self->_ssl_error("Can't find MD value for name '$algo'"); + $self->log('Peer certificate fingerprint: ' + .$algo.'$'.unpack('H*', Net::SSLeay::X509_digest($cert, $type))); + } + } + return $ok; # 1=accept cert, 0=reject +} + + # $self->_start_ssl($socket) # Upgrade the $socket to SSL/TLS. sub _start_ssl($$) { @@ -1397,7 +1426,7 @@ sub _start_ssl($$) { Net::SSLeay::CTX_load_verify_locations($ctx, $file, $path) or $self->_ssl_error("Can't load verify locations"); } - Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER()); + Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER(), sub($$) {$self->_ssl_verify(@_)}); Net::SSLeay::CTX_set_purpose($ctx, Net::SSLeay::X509_PURPOSE_SSL_SERVER()) or $self->_ssl_error("Can't set purpose"); } @@ -1409,6 +1438,20 @@ sub _start_ssl($$) { Net::SSLeay::set_fd($ssl, fileno $socket) or $self->fail("SSL filehandle association failed"); $self->_ssl_error("Can't initiate TLS/SSL handshake") unless Net::SSLeay::connect($ssl) == 1; + if ($self->{debug}) { + my $v = Net::SSLeay::version($ssl); + $self->log(sprintf('SSL protocol: %s (0x%x)', ($v == 0x0002 ? 'SSLv2' : + $v == 0x0300 ? 'SSLv3' : + $v == 0x0301 ? 'TLSv1' : + $v == 0x0302 ? 'TLSv1.1' : + $v == 0x0303 ? 'TLSv1.2' : + '??'), + $v)); + $self->log(sprintf('SSL cipher: %s (%d bits)' + , Net::SSLeay::get_cipher($ssl) + , Net::SSLeay::get_cipher_bits($ssl))); + } + if (defined (my $fpr = $self->{SSL_fingerprint})) { # ensure we're talking to the right server (my $algo, $fpr) = $fpr =~ /^([^\$]+)\$(.*)/ ? ($1, $2) : ('sha256', $fpr); -- cgit v1.2.3 From 683a3973a32ee3618824d08ed7ee6cfc7ee9ab02 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Wed, 16 Sep 2015 18:28:10 +0200 Subject: Move SSL fingerprint verification to the the verify callback. --- lib/Net/IMAP/InterIMAP.pm | 43 ++++++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 21 deletions(-) (limited to 'lib/Net/IMAP/InterIMAP.pm') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index f54f239..bf33294 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1380,7 +1380,8 @@ sub _ssl_verify($$$) { $self->log(' Subject Name: ', Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert))); } - if ($depth == 0) { + $ok = 1 unless $self->{SSL_verify} // 1; + if ($depth == 0 and !exists $self->{_SSL_PEER_VERIFIED}) { if ($self->{debug}) { my $algo = 'sha256'; my $type = Net::SSLeay::EVP_get_digestbyname($algo) @@ -1388,6 +1389,21 @@ sub _ssl_verify($$$) { $self->log('Peer certificate fingerprint: ' .$algo.'$'.unpack('H*', Net::SSLeay::X509_digest($cert, $type))); } + + if (defined (my $fpr = $self->{SSL_fingerprint})) { + (my $algo, $fpr) = $fpr =~ /^([^\$]+)\$(.*)/ ? ($1, $2) : ('sha256', $fpr); + my $digest = pack 'H*', ($fpr =~ tr/://rd); + + my $type = Net::SSLeay::EVP_get_digestbyname($algo) + or $self->_ssl_error("Can't find MD value for name '$algo'"); + + if (Net::SSLeay::X509_digest($cert, $type) ne $digest and + Net::SSLeay::X509_pubkey_digest($cert, $type) ne $digest) { + $self->warn("Fingerprint doesn't match! MiTM in action?"); + $ok = 0; + } + } + $self->{_SSL_PEER_VERIFIED} = $ok; } return $ok; # 1=accept cert, 0=reject } @@ -1426,17 +1442,18 @@ sub _start_ssl($$) { Net::SSLeay::CTX_load_verify_locations($ctx, $file, $path) or $self->_ssl_error("Can't load verify locations"); } - Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER(), sub($$) {$self->_ssl_verify(@_)}); - Net::SSLeay::CTX_set_purpose($ctx, Net::SSLeay::X509_PURPOSE_SSL_SERVER()) - or $self->_ssl_error("Can't set purpose"); } else { - Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_NONE()); + Net::SSLeay::CTX_set_verify_depth($ctx, 0); } + Net::SSLeay::CTX_set_purpose($ctx, Net::SSLeay::X509_PURPOSE_SSL_SERVER()) + or $self->_ssl_error("Can't set purpose"); + Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER(), sub($$) {$self->_ssl_verify(@_)}); my $ssl = Net::SSLeay::new($ctx) or $self->fail("Can't create new SSL structure"); Net::SSLeay::set_fd($ssl, fileno $socket) or $self->fail("SSL filehandle association failed"); $self->_ssl_error("Can't initiate TLS/SSL handshake") unless Net::SSLeay::connect($ssl) == 1; + $self->panic("Couldn't verify") unless $self->{_SSL_PEER_VERIFIED}; # sanity check if ($self->{debug}) { my $v = Net::SSLeay::version($ssl); @@ -1452,22 +1469,6 @@ sub _start_ssl($$) { , Net::SSLeay::get_cipher_bits($ssl))); } - if (defined (my $fpr = $self->{SSL_fingerprint})) { - # ensure we're talking to the right server - (my $algo, $fpr) = $fpr =~ /^([^\$]+)\$(.*)/ ? ($1, $2) : ('sha256', $fpr); - my $digest = pack 'H*', ($fpr =~ tr/://rd); - - my $type = Net::SSLeay::EVP_get_digestbyname($algo) - or $self->_ssl_error("Can't find MD value for name '$algo'"); - - my $cert = Net::SSLeay::get_peer_certificate($ssl) - or $self->_ssl_error("Can't get peer certificate"); - - $self->fail("Fingerprint doesn't match! MiTM in action?") - if Net::SSLeay::X509_digest($cert, $type) ne $digest and - Net::SSLeay::X509_pubkey_digest($cert, $type) ne $digest; - } - @$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx); } -- cgit v1.2.3 From 612b9e2102e1907709dde325f91d5fdf70ed2534 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 17 Sep 2015 22:05:09 +0200 Subject: Use TCP keepalive to detect dead peers. --- lib/Net/IMAP/InterIMAP.pm | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) (limited to 'lib/Net/IMAP/InterIMAP.pm') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index bf33294..d6c46a8 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -228,6 +228,9 @@ our $IMAP_text; # # - 'logger-fd': An optional filehandle to use for debug output. # +# - 'keepalive': Whether to enable sending of keep-alive messages. +# (type=imap or type=imaps). +# sub new($%) { my $class = shift; my $self = { @_ }; @@ -289,6 +292,23 @@ sub new($%) { } my $socket = defined $self->{proxy} ? $self->_proxify(@$self{qw/proxy host port/}) : $self->_tcp_connect(@$self{qw/host port/}); + my ($cnt, $intvl) = (3, 5); + if (defined $self->{keepalive}) { + # detect dead peers and drop the connection after 60 secs + $cnt*$intvl + setsockopt($socket, Socket::SOL_SOCKET, Socket::SO_KEEPALIVE, 1) + or $self->fail("Can't setsockopt SO_KEEPALIVE: $!"); + setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPIDLE, 60) + or $self->fail("Can't setsockopt TCP_KEEPIDLE: $!"); + setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPCNT, $cnt) + or $self->fail("Can't setsockopt TCP_KEEPCNT: $!"); + setsockopt($socket, Socket::IPPROTO_TCP, Socket::TCP_KEEPINTVL, $intvl) + or $self->fail("Can't setsockopt TCP_KEEPINTVL: $!"); + } + # Abort after 15secs if write(2) isn't acknowledged + # XXX Socket::TCP_USER_TIMEOUT isn't defined. + # `grep TCP_USER_TIMEOUT /usr/include/linux/tcp.h` gives 18 + setsockopt($socket, Socket::IPPROTO_TCP, 18, 1000 * $cnt * $intvl) + or $self->fail("Can't setsockopt TCP_USER_TIMEOUT: $!"); $self->_start_ssl($socket) if $self->{type} eq 'imaps'; $self->{$_} = $socket for qw/STDOUT STDIN/; -- cgit v1.2.3