From 5104962fbe1d9c9b602cdd4e4d9fb4d19f4f9b8c Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Wed, 9 Sep 2015 23:32:41 +0200 Subject: Exit with return value 0 when receiving a TERM signal. --- Changelog | 1 + 1 file changed, 1 insertion(+) (limited to 'Changelog') diff --git a/Changelog b/Changelog index 5b010d2..a188c18 100644 --- a/Changelog +++ b/Changelog @@ -10,6 +10,7 @@ interimap (0.2) upstream default if both the local and remote servers advertize "BINARY". Can be disabled by adding 'use-binary=NO' to the default section in the configuration file. + * Exit with return value 0 when receiving a TERM signal. -- Guilhem Moulin Wed, 09 Sep 2015 00:44:35 +0200 -- 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. --- Changelog | 5 +++-- interimap | 5 +++-- lib/Net/IMAP/InterIMAP.pm | 42 ++++++++++++++++++++++++++++++++---------- 3 files changed, 38 insertions(+), 14 deletions(-) (limited to 'Changelog') diff --git a/Changelog b/Changelog index a188c18..4b43f94 100644 --- a/Changelog +++ b/Changelog @@ -1,4 +1,4 @@ -interimap (0.2) upstream +interimap (0.2) upstream; * Add support for the IMAP COMPRESS extension [RFC4978]. By default enabled for the remote server, and disabled for the local server. @@ -10,7 +10,8 @@ interimap (0.2) upstream default if both the local and remote servers advertize "BINARY". Can be disabled by adding 'use-binary=NO' to the default section in the configuration file. - * Exit with return value 0 when receiving a TERM signal. + * Exit with return value 0 when receiving a SIGTERM. + * Print IMAP traffic stats when receiving a SIGHUP. -- Guilhem Moulin Wed, 09 Sep 2015 00:44:35 +0200 diff --git a/interimap b/interimap index 2c72d56..4a8bde4 100755 --- a/interimap +++ b/interimap @@ -118,8 +118,9 @@ sub cleanup() { close $LOGGER_FD if defined $LOGGER_FD; $DBH->disconnect() if defined $DBH; } -$SIG{$_} = sub { msg(undef, $!); cleanup(); exit 1; } foreach qw/INT/; -$SIG{$_} = sub { cleanup(); exit 0; } foreach qw/HUP TERM/; +$SIG{INT} = sub { msg(undef, $!); cleanup(); exit 1; }; +$SIG{TERM} = sub { cleanup(); exit 0; }; +$SIG{HUP} = sub { $_->stats() foreach grep defined, ($lIMAP, $rIMAP); }; ############################################################################# 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. --- Changelog | 4 ++ lib/Net/IMAP/InterIMAP.pm | 101 +++++++++++++++++++++++----------------------- 2 files changed, 54 insertions(+), 51 deletions(-) (limited to 'Changelog') diff --git a/Changelog b/Changelog index 4b43f94..754e0fd 100644 --- a/Changelog +++ b/Changelog @@ -12,6 +12,10 @@ interimap (0.2) upstream; the configuration file. * Exit with return value 0 when receiving a SIGTERM. * Print IMAP traffic stats when receiving a SIGHUP. + * Add SSL options SINGLE_ECDH_USE, SINGLE_DH_USE, NO_SSLv2, NO_SSLv3 + and NO_COMPRESSION to the compiled-in CTX options. + * Use SSL_MODE_AUTO_RETRY to avoid SSL_read failures during a + handshake. -- Guilhem Moulin Wed, 09 Sep 2015 00:44:35 +0200 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