aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net/IMAP')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm195
1 files changed, 105 insertions, 90 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 3b9e10e..65a0c10 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -20,7 +20,7 @@ package Net::IMAP::InterIMAP v0.0.2;
use warnings;
use strict;
-use Compress::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
+use Compress::Zlib qw/Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
use Config::Tiny ();
use Errno 'EWOULDBLOCK';
use IO::Select ();
@@ -221,6 +221,15 @@ sub new($%) {
my $self = { @_ };
bless $self, $class;
+ foreach (keys %$self) {
+ next unless defined $self->{$_};
+ if (uc $self->{$_} eq 'YES') {
+ $self->{$_} = 1;
+ } elsif (uc $self->{$_} eq 'NO') {
+ $self->{$_} = 0;
+ }
+ }
+
# the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT'
# (cf RFC 3501 section 3)
$self->{_STATE} = '';
@@ -246,7 +255,7 @@ sub new($%) {
open STDOUT, '>&', $wd or $self->panic("Can't dup: $!");
my $stderr2;
- if (uc ($self->{'null-stderr'} // 'NO') eq 'YES') {
+ if ($self->{'null-stderr'} // 0) {
open $stderr2, '>&', *STDERR;
open STDERR, '>', '/dev/null' or $self->panic("Can't open /dev/null: $!");
}
@@ -271,28 +280,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/;
@@ -347,31 +341,17 @@ sub new($%) {
$self->{_STATE} = 'UNAUTH';
my @caps = $self->capabilities();
- if ($self->{type} eq 'imap' and uc $self->{STARTTLS} ne 'NO') { # RFC 2595 section 5.1
+ if ($self->{type} eq 'imap' and $self->{STARTTLS}) { # 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};
@caps = $self->capabilities();
}
- my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/ ? $1 : undef } @caps);
+ my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/i ? $1 : undef } @caps);
my $mech = (grep defined, map {my $m = $_; (grep {$m eq $_} @mechs) ? $m : undef}
split(/ /, $self->{auth}))[0];
$self->fail("Failed to choose an authentication mechanism") unless defined $mech;
@@ -411,9 +391,9 @@ sub new($%) {
$self->{_STATE} = 'AUTH';
# Don't send the COMPRESS command before STARTTLS or AUTH, as per RFC 4978
- if (uc ($self->{compress} // 'NO') eq 'YES') {
+ if ($self->{compress} // 1 and
+ my @algos = grep defined, map { /^COMPRESS=(.+)/i ? uc $1 : undef } @{$self->{_CAPABILITIES}}) {
my @supported = qw/DEFLATE/; # supported compression algorithms
- my @algos = grep defined, map { /^COMPRESS=(.+)/ ? uc $1 : undef } @{$self->{_CAPABILITIES}};
my $algo = first { my $x = $_; grep {$_ eq $x} @algos } @supported;
if (!defined $algo) {
$self->warn("Couldn't find a suitable compression algorithm. Not enabling compression.");
@@ -425,16 +405,11 @@ sub new($%) {
$self->panic($IMAP_text) unless $r eq 'OK';
if ($algo eq 'DEFLATE') {
- my ($status, $d, $i);
my %args = ( -WindowBits => 0 - MAX_WBITS );
- ($d, $status) = Compress::Zlib::deflateInit(%args);
- $self->panic("Can't create deflation stream: ", $d->msg())
- unless defined $d and $status == Z_OK;
-
- ($i, $status) = Compress::Zlib::inflateInit(%args);
- $self->panic("Can't create inflation stream: ", $i->msg())
- unless defined $i and $status == Z_OK;
- @$self{qw/_Z_DEFLATE _Z_INFLATE/} = ($d, $i);
+ $self->{_Z_DEFLATE} = Compress::Zlib::deflateInit(%args) //
+ $self->panic("Can't create deflation stream");
+ $self->{_Z_INFLATE} = Compress::Zlib::inflateInit(%args) //
+ $self->panic("Can't create inflation stream");
}
else {
$self->fail("Unsupported compression algorithm: $algo");
@@ -458,6 +433,22 @@ sub new($%) {
}
+# Print traffic statistics
+sub stats($) {
+ my $self = shift;
+ my $msg = 'IMAP traffic (bytes):';
+ $msg .= ' recv '._kibi($self->{_OUTCOUNT});
+ $msg .= ' (compr. '._kibi($self->{_OUTRAWCOUNT}).
+ ', factor '.sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).')'
+ if defined $self->{_Z_DEFLATE} and $self->{_OUTCOUNT} > 0;
+ $msg .= ' sent '._kibi($self->{_INCOUNT});
+ $msg .= ' (compr. '._kibi($self->{_INRAWCOUNT}).
+ ', factor '.sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).')'
+ if defined $self->{_Z_DEFLATE} and $self->{_INCOUNT} > 0;
+ $self->log($msg);
+}
+
+
# Log out when the Net::IMAP::InterIMAP object is destroyed.
sub DESTROY($) {
my $self = shift;
@@ -467,16 +458,7 @@ sub DESTROY($) {
$self->{$_}->close() if defined $self->{$_} and $self->{$_}->opened();
}
- unless ($self->{quiet}) {
- my $msg = "Connection closed";
- $msg .= " in=$self->{_INCOUNT}";
- $msg .= " (raw=$self->{_INRAWCOUNT}, ratio ".sprintf('%.2f', $self->{_INRAWCOUNT}/$self->{_INCOUNT}).")"
- if defined $self->{_INRAWCOUNT} and $self->{_INCOUNT} > 0 and $self->{_INCOUNT} != $self->{_INRAWCOUNT};
- $msg .= ", out=$self->{_OUTCOUNT}";
- $msg .= " (raw=$self->{_OUTRAWCOUNT}, ratio ".sprintf('%.2f', $self->{_OUTRAWCOUNT}/$self->{_OUTCOUNT}).")"
- if defined $self->{_OUTRAWCOUNT} and $self->{_OUTCOUNT} > 0 and $self->{_OUTCOUNT} != $self->{_OUTRAWCOUNT};
- $self->log($msg);
- }
+ $self->stats() unless $self->{quiet};
}
@@ -1208,17 +1190,51 @@ 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} = ($vrfy // 1) ? 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;
}
@@ -1242,21 +1258,12 @@ 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;
if (defined (my $i = $self->{_Z_INFLATE})) {
- my ($out, $status) = $i->inflate($buf);
- $self->panic("Inflation failed: ", $i->msg()) unless $status == Z_OK;
- $buf = $out;
+ $buf = $i->inflate($buf) // $self->panic("Inflation failed: ", $i->msg());
}
$self->{_OUTBUF} = $buf;
}
@@ -1345,9 +1352,7 @@ sub _write($@) {
sub _z_flush($;$) {
my ($self,$t) = @_;
my $d = $self->{_Z_DEFLATE} // return;
- my ($out, $status) = $d->flush($t);
- $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
- $self->_write($out);
+ $self->_write( $d->flush($t) // $self->panic("Can't flush deflation stream: ", $d->msg()) );
}
@@ -1378,9 +1383,8 @@ sub _send_cmd($) {
$line = substr($command, $offset, $idx-1-$offset);
$litlen = $litplus ? ($line =~ s/\{([0-9]+)\}\z/{$1+}/ ? $1 : $self->panic())
: ($line =~ /\{([0-9]+)\}\z/ ? $1 : $self->panic());
- $z_flush2 = ($litlen > 4096 and # large literal
- (uc ($self->{'use-binary'} // 'YES') eq 'NO'
- or $line =~ /~\{[0-9]+\}\z/) # literal8, RFC 3516 BINARY
+ $z_flush2 = ($litlen > 4096 and # large literal
+ ($self->{'use-binary'} // 1 or $line =~ /~\{[0-9]+\}\z/) # literal8, RFC 3516 BINARY
) ? 1 : 0;
}
$self->logger('C: ', ($offset == 0 ? "$tag " : '[...]'), $line) if $self->{debug};
@@ -1393,11 +1397,7 @@ sub _send_cmd($) {
else {
for (my $i = 0; $i <= $#data; $i++) {
$self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush;
-
- my ($out, $status) = $d->deflate($data[$i]);
- $self->panic("Deflation failed: ", $d->msg()) unless $status == Z_OK;
- $self->_write($out);
-
+ $self->_write( $d->deflate($data[$i]) // $self->panic("Deflation failed: ", $d->msg()) );
$self->_z_flush(Z_FULL_FLUSH) if $i == 0 and $z_flush;
}
}
@@ -1555,6 +1555,21 @@ sub _select_or_examine($$$;$$) {
}
+sub _kibi($) {
+ my $n = shift;
+ if ($n < 1024) {
+ $n;
+ } elsif ($n < 1048576) {
+ sprintf '%.2fK', $n / 1024.;
+ } elsif ($n < 1073741824) {
+ sprintf '%.2fM', $n / 1048576.;
+ } else {
+ sprintf '%.2fG', $n / 1073741824.;
+ }
+
+}
+
+
#############################################################################
# Parsing methods
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-03 21:58:09 +0000