aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP/InterIMAP.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net/IMAP/InterIMAP.pm')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm172
1 files changed, 101 insertions, 71 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index fff1570..0c4fc89 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -1,6 +1,6 @@
#----------------------------------------------------------------------
# A minimal IMAP4 client for QRESYNC-capable servers
-# Copyright © 2015-2019 Guilhem Moulin <guilhem@fripost.org>
+# Copyright © 2015-2020 Guilhem Moulin <guilhem@fripost.org>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -16,7 +16,7 @@
# along with this program. If not, see <https://www.gnu.org/licenses/>.
#----------------------------------------------------------------------
-package Net::IMAP::InterIMAP v0.0.5;
+package Net::IMAP::InterIMAP v0.5.5;
use v5.20.0;
use warnings;
use strict;
@@ -62,9 +62,12 @@ my %OPTIONS = (
command => qr/\A(\P{Control}+)\z/,
'null-stderr' => qr/\A(YES|NO)\z/i,
compress => qr/\A(YES|NO)\z/i,
- SSL_protocols => qr/\A(!?$RE_SSL_PROTO(?: !?$RE_SSL_PROTO)*)\z/,
+ SSL_protocols => qr/\A(!?$RE_SSL_PROTO(?: !?$RE_SSL_PROTO)*)\z/, # TODO deprecated, remove in 0.6
+ SSL_protocol_min => qr/\A(\P{Control}+)\z/,
+ SSL_protocol_max => qr/\A(\P{Control}+)\z/,
SSL_fingerprint => qr/\A((?:[A-Za-z0-9]+\$)?\p{AHex}+(?: (?:[A-Za-z0-9]+\$)?\p{AHex}+)*)\z/,
SSL_cipherlist => qr/\A(\P{Control}+)\z/,
+ SSL_ciphersuites => qr/\A(\P{Control}*)\z/, # "an empty list is permissible"
SSL_hostname => qr/\A(\P{Control}*)\z/,
SSL_verify => qr/\A(YES|NO)\z/i,
SSL_CApath => qr/\A(\P{Control}+)\z/,
@@ -325,19 +328,19 @@ sub new($%) {
my $pid = fork // $self->panic("fork: $!");
unless ($pid) {
# children
- close($self->{S}) or $self->panic("Can't close: $!");
- open STDIN, '<&', $s or $self->panic("Can't dup: $!");
- open STDOUT, '>&', $s or $self->panic("Can't dup: $!");
+ close($self->{S}) or $self->panic("close: $!");
+ open STDIN, '<&', $s or $self->panic("dup: $!");
+ open STDOUT, '>&', $s or $self->panic("dup: $!");
my $stderr2;
if (($self->{'null-stderr'} // 0) and !($self->{debug} // 0)) {
open $stderr2, '>&', *STDERR;
- open STDERR, '>', '/dev/null' or $self->panic("Can't open /dev/null: $!");
+ open STDERR, '>', '/dev/null' or $self->panic("open(/dev/null): $!");
}
my $sigset = POSIX::SigSet::->new(SIGINT);
my $oldsigset = POSIX::SigSet::->new();
- sigprocmask(SIG_BLOCK, $sigset, $oldsigset) // $self->panic("Can't block SIGINT: $!");
+ sigprocmask(SIG_BLOCK, $sigset, $oldsigset) // $self->panic("sigprocmask: $!");
unless (exec $command) {
my $err = $!;
@@ -345,12 +348,12 @@ sub new($%) {
close STDERR;
open STDERR, '>&', $stderr2;
}
- $self->panic("Can't exec: $err");
+ $self->panic("exec: $err");
}
}
# parent
- close($s) or $self->panic("Can't close: $!");
+ close($s) or $self->panic("close: $!");
}
else {
foreach (qw/host port/) {
@@ -360,9 +363,9 @@ sub new($%) {
: $self->_tcp_connect(@$self{qw/host port/});
if (defined $self->{keepalive}) {
setsockopt($self->{S}, Socket::SOL_SOCKET, Socket::SO_KEEPALIVE, 1)
- or $self->fail("Can't setsockopt SO_KEEPALIVE: $!");
+ or $self->fail("setsockopt SO_KEEPALIVE: $!");
setsockopt($self->{S}, Socket::IPPROTO_TCP, Socket::TCP_KEEPIDLE, 60)
- or $self->fail("Can't setsockopt TCP_KEEPIDLE: $!");
+ or $self->fail("setsockopt TCP_KEEPIDLE: $!");
}
}
@@ -1368,7 +1371,7 @@ sub push_flag_updates($$@) {
$modified->{$uid} //= [ 0, undef ];
} elsif (defined (my $m = $modified->{$uid})) {
# received an untagged FETCH response, remove from the list of pending changes
- # if the flag list was up to date (either implicitely or explicitely)
+ # if the flag list was up to date (either implicitely or explicitly)
if (!defined $m->[1] or $m->[1] eq $flags) {
delete $modified->{$uid};
push @ok, $uid;
@@ -1490,9 +1493,9 @@ sub _tcp_connect($$$) {
# https://stackoverflow.com/questions/8284243/how-do-i-set-so-rcvtimeo-on-a-socket-in-perl
my $timeout = pack('l!l!', 30, 0);
setsockopt($s, Socket::SOL_SOCKET, Socket::SO_RCVTIMEO, $timeout)
- or $self->fail("Can't setsockopt SO_RCVTIMEO: $!");
+ or $self->fail("setsockopt SO_RCVTIMEO: $!");
setsockopt($s, Socket::SOL_SOCKET, Socket::SO_SNDTIMEO, $timeout)
- or $self->fail("Can't setsockopt SO_RCVTIMEO: $!");
+ or $self->fail("setsockopt SO_RCVTIMEO: $!");
until (connect($s, $ai->{addr})) {
next if $! == EINTR; # try again if connect(2) was interrupted by a signal
@@ -1509,7 +1512,7 @@ sub _xwrite($$$) {
while ($length > 0) {
my $n = syswrite($_[0], $_[1], $length, $offset);
- $self->fail("Can't write: $!") unless defined $n and $n > 0;
+ $self->fail("write: $!") unless defined $n and $n > 0;
$offset += $n;
$length -= $n;
}
@@ -1521,7 +1524,7 @@ sub _xread($$$) {
my $offset = 0;
my $buf;
while ($length > 0) {
- my $n = sysread($fh, $buf, $length, $offset) // $self->fail("Can't read: $!");
+ my $n = sysread($fh, $buf, $length, $offset) // $self->fail("read: $!");
$self->fail("0 bytes read (got EOF)") unless $n > 0; # EOF
$offset += $n;
$length -= $n;
@@ -1579,7 +1582,7 @@ sub _proxify($$$$) {
my ($err, $ipaddr) = getnameinfo($_->{addr}, NI_NUMERICHOST, NIx_NOSERV);
$err eq '' ? [$ipaddr,$_->{family}] : undef
} @res;
- $self->fail("Can't getnameinfo") unless defined $addr;
+ $self->fail("getnameinfo") unless defined $addr;
($hostip, $fam) = @$addr;
}
@@ -1624,7 +1627,7 @@ 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
+# https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_verify.html
sub _ssl_verify($$$) {
my ($self, $ok, $x509_ctx) = @_;
return 0 unless $x509_ctx; # reject
@@ -1638,7 +1641,7 @@ sub _ssl_verify($$$) {
$self->log(' Subject Name: ', Net::SSLeay::X509_NAME_oneline(Net::SSLeay::X509_get_subject_name($cert)));
}
- $ok = 1 unless $self->{SSL_verify} // 1;
+ $ok = 1 unless $self->{SSL_verify} // die; # safety check, always set
if ($depth == 0 and !exists $self->{_SSL_PEER_VERIFIED}) {
if ($self->{debug}) {
my $algo = 'sha256';
@@ -1675,7 +1678,7 @@ sub _ssl_verify($$$) {
}
my %SSL_proto;
-BEGIN {
+BEGIN { # TODO deprecated, remove in 0.6
sub _append_ssl_proto($$) {
my ($k, $v) = @_;
$SSL_proto{$k} = $v if defined $v;
@@ -1688,51 +1691,84 @@ BEGIN {
_append_ssl_proto( "TLSv1.3", eval { Net::SSLeay::OP_NO_TLSv1_3() } );
}
+# see ssl/ssl_conf.c:protocol_from_string() in the OpenSSL source tree
+my %SSL_protocol_versions = (
+ "SSLv3" => eval { Net::SSLeay::SSL3_VERSION() }
+ , "TLSv1" => eval { Net::SSLeay::TLS1_VERSION() }
+ , "TLSv1.1" => eval { Net::SSLeay::TLS1_1_VERSION() }
+ , "TLSv1.2" => eval { Net::SSLeay::TLS1_2_VERSION() }
+ , "TLSv1.3" => eval { Net::SSLeay::TLS1_3_VERSION() }
+);
+
# $self->_start_ssl($socket)
# Upgrade the $socket to SSL/TLS.
sub _start_ssl($$) {
my ($self, $socket) = @_;
- my $openssl_version = Net::SSLeay::OPENSSL_VERSION_NUMBER();
- my $ctx = Net::SSLeay::CTX_new() or $self->panic("Failed to create SSL_CTX $!");
- my $ssl_options = Net::SSLeay::OP_SINGLE_DH_USE() | Net::SSLeay::OP_SINGLE_ECDH_USE();
+ # need OpenSSL 1.1.0 or later for SSL_CTX_set_min_proto_version(3ssl), see
+ # https://www.openssl.org/docs/man1.1.0/man3/SSL_CTX_set_min_proto_version.html
+ $self->panic("SSL/TLS functions require OpenSSL 1.1.0 or later")
+ if Net::SSLeay::OPENSSL_VERSION_NUMBER() < 0x1010000f;
+
+ my $ctx = Net::SSLeay::CTX_new() or $self->panic("SSL_CTX_new(): $!");
+ $self->{SSL_verify} //= 1; # default is to perform certificate verification
if (defined $self->{_OUTBUF} and $self->{_OUTBUF} ne '') {
$self->warn("Truncating non-empty output buffer (unauthenticated response injection?)");
undef $self->{_OUTBUF};
}
- $self->{SSL_protocols} //= q{!SSLv2 !SSLv3 !TLSv1 !TLSv1.1};
- my ($proto_include, $proto_exclude) = (0, 0);
- foreach (split /\s+/, $self->{SSL_protocols}) {
- my $neg = s/^!// ? 1 : 0;
- s/\.0$//;
- ($neg ? $proto_exclude : $proto_include) |= $SSL_proto{$_} // $self->panic("Unknown SSL protocol: $_");
- }
- if ($proto_include != 0) {
- # exclude all protocols except those explictly included
- my $x = 0;
- $x |= $_ foreach values %SSL_proto;
- $x &= ~ $proto_include;
- $proto_exclude |= $x;
- }
- my @proto_exclude = grep { ($proto_exclude & $SSL_proto{$_}) != 0 } keys %SSL_proto;
- $self->log("Disabling SSL protocols: ".join(', ', sort @proto_exclude)) if $self->{debug};
- $ssl_options |= $SSL_proto{$_} foreach @proto_exclude;
+ my $ssl_options = Net::SSLeay::OP_SINGLE_DH_USE() | Net::SSLeay::OP_SINGLE_ECDH_USE();
$ssl_options |= Net::SSLeay::OP_NO_COMPRESSION();
- # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_options.html
+ if (defined $self->{SSL_protocol_min} or defined $self->{SSL_protocol_max}) {
+ my ($min, $max) = @$self{qw/SSL_protocol_min SSL_protocol_max/};
+ if (defined $min) {
+ my $v = $SSL_protocol_versions{$min} // $self->panic("Unknown protocol version: $min");
+ $self->_ssl_error("CTX_set_min_proto_version()") unless Net::SSLeay::CTX_set_min_proto_version($ctx, $v) == 1;
+ $self->log("Minimum SSL/TLS protocol version: ", $min) if $self->{debug};
+ }
+ if (defined $max) {
+ my $v = $SSL_protocol_versions{$max} // $self->panic("Unknown protocol version: $max");
+ $self->_ssl_error("CTX_set_max_proto_version()") unless Net::SSLeay::CTX_set_max_proto_version($ctx, $v) == 1;
+ $self->log("Maximum SSL/TLS protocol version: ", $max) if $self->{debug};
+ }
+ } elsif (defined (my $protos = $self->{SSL_protocols})) { # TODO deprecated, remove in 0.6
+ $self->warn("SSL_protocols is deprecated and will be removed in a future release! " .
+ "Use SSL_protocol_{min,max} instead.");
+ my ($proto_include, $proto_exclude) = (0, 0);
+ foreach (split /\s+/, $protos) {
+ my $neg = s/^!// ? 1 : 0;
+ s/\.0$//;
+ ($neg ? $proto_exclude : $proto_include) |= $SSL_proto{$_} // $self->panic("Unknown SSL protocol: $_");
+ }
+ if ($proto_include != 0) {
+ # exclude all protocols except those explictly included
+ my $x = 0;
+ $x |= $_ foreach values %SSL_proto;
+ $x &= ~ $proto_include;
+ $proto_exclude |= $x;
+ }
+ my @proto_exclude = grep { ($proto_exclude & $SSL_proto{$_}) != 0 } keys %SSL_proto;
+ $self->log("Disabling SSL protocols: ".join(', ', sort @proto_exclude)) if $self->{debug};
+ $ssl_options |= $SSL_proto{$_} foreach @proto_exclude;
+ }
+
+ # https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_options.html
+ # TODO 0.6: move SSL_CTX_set_options() and SSL_CTX_set_mode() before SSL_CTX_set_{min,max}_proto_version()
Net::SSLeay::CTX_set_options($ctx, $ssl_options);
- # https://www.openssl.org/docs/manmaster/ssl/SSL_CTX_set_mode.html
+ # https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_mode.html
Net::SSLeay::CTX_set_mode($ctx,
Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE() |
Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER() |
Net::SSLeay::MODE_AUTO_RETRY() | # don't fail SSL_read on renegotiation
Net::SSLeay::MODE_RELEASE_BUFFERS() );
- if (defined (my $ciphers = $self->{SSL_cipherlist})) {
- Net::SSLeay::CTX_set_cipher_list($ctx, $ciphers)
- or $self->_ssl_error("Can't set cipher list");
+ if (defined (my $str = $self->{SSL_cipherlist})) {
+ $self->_ssl_error("SSL_CTX_set_cipher_list()") unless Net::SSLeay::CTX_set_cipher_list($ctx, $str) == 1;
+ }
+ if (defined (my $str = $self->{SSL_ciphersuites})) {
+ $self->_ssl_error("SSL_CTX_set_ciphersuites()") unless Net::SSLeay::CTX_set_ciphersuites($ctx, $str) == 1;
}
my $vpm = Net::SSLeay::X509_VERIFY_PARAM_new() or $self->_ssl_error("X509_VERIFY_PARAM_new()");
@@ -1742,15 +1778,16 @@ sub _start_ssl($$) {
my $host = $self->{host} // $self->panic();
my ($hostip, $hostipfam) = _parse_hostip($host);
- if ($self->{SSL_verify} // 1) {
- # for X509_VERIFY_PARAM_set1_{ip,host}()
- $self->panic("Failed requirement libssl >=1.0.2") if $openssl_version < 0x1000200f;
-
+ if ($self->{SSL_verify}) {
# verify certificate chain
- my ($file, $path) = ($self->{SSL_CAfile} // '', $self->{SSL_CApath} // '');
- if ($file ne '' or $path ne '') {
- Net::SSLeay::CTX_load_verify_locations($ctx, $file, $path)
- or $self->_ssl_error("Can't load verify locations");
+ if (defined $self->{SSL_CAfile} or defined $self->{SSL_CApath}) {
+ $self->_ssl_error("SSL_CTX_load_verify_locations()")
+ unless Net::SSLeay::CTX_load_verify_locations($ctx,
+ $self->{SSL_CAfile} // '', $self->{SSL_CApath} // '') == 1;
+ } else {
+ $self->log("Using default locations for trusted CA certificates") if $self->{debug};
+ $self->_ssl_error("SSL_CTX_set_default_verify_paths()")
+ unless Net::SSLeay::CTX_set_default_verify_paths($ctx) == 1;
}
# verify DNS hostname or IP literal
@@ -1769,33 +1806,26 @@ sub _start_ssl($$) {
Net::SSLeay::CTX_set_verify($ctx, Net::SSLeay::VERIFY_PEER(), sub($$) {$self->_ssl_verify(@_)});
$self->_ssl_error("CTX_SSL_set1_param()") unless Net::SSLeay::CTX_set1_param($ctx, $vpm) == 1;
- 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");
+ my $ssl = Net::SSLeay::new($ctx) or $self->fail("SSL_new()");
+ $self->fail("SSL_set_fd()") unless Net::SSLeay::set_fd($ssl, fileno($socket)) == 1;
- # always use 'SSL_hostname' when set, otherwise use 'host' (unless it's an IP) on OpenSSL >=0.9.8f
+ # always use 'SSL_hostname' when set, otherwise use 'host' (unless it's an IP)
my $servername = $self->{SSL_hostname} // (defined $hostipfam ? "" : $host);
if ($servername ne "") {
- $self->panic("Failed requirement libssl >=0.9.8f") if $openssl_version < 0x00908070;
- $self->_ssl_error("Can't set TLS servername extension (value $servername)")
+ $self->_ssl_error("SSL_set_tlsext_host_name($servername)")
unless Net::SSLeay::set_tlsext_host_name($ssl, $servername) == 1;
$self->log("Using SNI with name $servername") if $self->{debug};
}
$self->_ssl_error("Can't initiate TLS/SSL handshake") unless Net::SSLeay::connect($ssl) == 1;
$self->panic() unless $self->{_SSL_PEER_VERIFIED}; # sanity check
- $self->panic() if ($self->{SSL_verify} // 1) and Net::SSLeay::get_verify_result($ssl) != Net::SSLeay::X509_V_OK();
+ $self->panic() if $self->{SSL_verify} and Net::SSLeay::get_verify_result($ssl) != Net::SSLeay::X509_V_OK();
Net::SSLeay::X509_VERIFY_PARAM_free($vpm);
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 == 0x0304 ? 'TLSv1.3' :
- '??'),
- $v));
+ $self->log(sprintf('SSL protocol: %s (0x%x)',
+ , Net::SSLeay::get_version($ssl)
+ , Net::SSLeay::version($ssl)));
$self->log(sprintf('SSL cipher: %s (%d bits)'
, Net::SSLeay::get_cipher($ssl)
, Net::SSLeay::get_cipher_bits($ssl)));
@@ -1830,7 +1860,7 @@ sub _getline($;$) {
$n = sysread($stdout, $buf, $BUFSIZE, 0);
}
- $self->_ssl_error("Can't read: $!") unless defined $n;
+ $self->_ssl_error("read: $!") unless defined $n;
$self->_ssl_error("0 bytes read (got EOF)") unless $n > 0; # EOF
$self->{_OUTRAWCOUNT} += $n;
@@ -2043,7 +2073,7 @@ sub _cmd_flush($;$$) {
my $written = defined $ssl ?
Net::SSLeay::write_partial($ssl, $offset, $length, $self->{_INBUF}) :
syswrite($stdin, $self->{_INBUF}, $length, $offset);
- $self->_ssl_error("Can't write: $!") unless defined $written and $written > 0;
+ $self->_ssl_error("write: $!") unless defined $written and $written > 0;
$offset += $written;
$length -= $written;
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-25 09:12:13 +0000