aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm140
1 files changed, 94 insertions, 46 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 6f44879..d6c46a8 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 {
@@ -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,7 +292,23 @@ 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: $!");
+ 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/;
@@ -772,9 +791,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 +818,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 +1089,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
@@ -1371,6 +1384,51 @@ 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)));
+ }
+
+ $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)
+ 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)));
+ }
+
+ 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
+}
+
+
# $self->_start_ssl($socket)
# Upgrade the $socket to SSL/TLS.
sub _start_ssl($$) {
@@ -1404,30 +1462,31 @@ 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());
}
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 (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;
+ 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)));
}
@$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx);
@@ -1582,20 +1641,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 +2142,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 +2151,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};