From 5e127a1b56879ee24bcdf56c9c1eeb4f7dac4bc4 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 10 Sep 2015 03:38:40 +0200 Subject: wibble --- lib/Net/IMAP/InterIMAP.pm | 29 ++++++++--------------------- 1 file changed, 8 insertions(+), 21 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 3b9e10e..ee8677a 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 (); @@ -425,16 +425,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"); @@ -1254,9 +1249,7 @@ sub _getline($;$) { $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 +1338,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()) ); } @@ -1393,11 +1384,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; } } -- cgit v1.2.3 From 705ea1c708c676587ae4833fc1fca5caafe1dd7f Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 10 Sep 2015 20:19:36 +0200 Subject: Don't warn that no compression is enabled if the server doesn't support it. --- lib/Net/IMAP/InterIMAP.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index ee8677a..076ec19 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -371,7 +371,7 @@ sub new($%) { @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 +411,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 (uc ($self->{compress} // 'NO') eq 'YES' 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."); -- cgit v1.2.3 From ea086d30d021f7c018e4d307223162cf051de336 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Thu, 10 Sep 2015 20:39:50 +0200 Subject: Print IMAP traffic stats when receiving a SIGHUP. --- lib/Net/IMAP/InterIMAP.pm | 42 ++++++++++++++++++++++++++++++++---------- 1 file changed, 32 insertions(+), 10 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 076ec19..4222c78 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -453,6 +453,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; @@ -462,16 +478,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}; } @@ -1542,6 +1549,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 -- cgit v1.2.3 From fba1c36f3710badb61f45a406cd57425669ed2ed Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Fri, 11 Sep 2015 00:20:10 +0200 Subject: 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. --- lib/Net/IMAP/InterIMAP.pm | 101 +++++++++++++++++++++++----------------------- 1 file changed, 50 insertions(+), 51 deletions(-) (limited to 'lib/Net') 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; -- cgit v1.2.3 From cd7d385b4a27d028a7c7f92e1cd781b65b8ca5eb Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Fri, 11 Sep 2015 00:30:23 +0200 Subject: Use 0/1 internally for 'NO'/'YES'. --- lib/Net/IMAP/InterIMAP.pm | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) (limited to 'lib/Net') diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 0876682..65a0c10 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -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: $!"); } @@ -332,7 +341,7 @@ 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; $self->_start_ssl($self->{STDIN}) if $self->{type} eq 'imaps'; @@ -382,7 +391,7 @@ 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' and + 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 $algo = first { my $x = $_; grep {$_ eq $x} @algos } @supported; @@ -1210,8 +1219,7 @@ sub _start_ssl($$) { 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{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) @@ -1375,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}; -- cgit v1.2.3