aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2015-09-09 00:44:05 +0200
committerGuilhem Moulin <guilhem@fripost.org>2015-09-09 22:01:57 +0200
commit64dc8a1ed4e15ce456a699184a4fff263f2c902f (patch)
treed3e9f4c3a9167005b6b2d4035e7d348ed5043b2f
parent8c9328834e3340c1d3b20a5d9567fe8cd27f6d82 (diff)
Add support for the IMAP COMPRESS extension [RFC4978].
Also, add traffic statistics after closing the connection to the IMAP server.
-rw-r--r--Changelog9
-rw-r--r--INSTALL2
-rw-r--r--README7
-rwxr-xr-xinterimap12
-rw-r--r--interimap.17
-rw-r--r--interimap.sample1
-rw-r--r--lib/Net/IMAP/InterIMAP.pm224
7 files changed, 226 insertions, 36 deletions
diff --git a/Changelog b/Changelog
index acd02d2..0d56bac 100644
--- a/Changelog
+++ b/Changelog
@@ -1,3 +1,12 @@
+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.
+ * Add traffic statistics after closing the connection to the IMAP
+ server.
+
+ -- Guilhem Moulin <guilhem@guilhem.org> Wed, 09 Sep 2015 00:44:35 +0200
+
interimap (0.1) upstream;
* Initial public release. Development was started in July 2015.
diff --git a/INSTALL b/INSTALL
index 7bc3eef..b3f9ebc 100644
--- a/INSTALL
+++ b/INSTALL
@@ -1,8 +1,10 @@
InterIMAP depends on the following Perl modules:
+ - Compress::Raw::Zlib (core module)
- Config::Tiny
- DBI
- DBD::SQLite
+ - Errno (core module)
- Getopt::Long (core module)
- MIME::Base64 (core module) if authentication is required
- IO::Select (core module)
diff --git a/README b/README
index 44190f3..0e93fe9 100644
--- a/README
+++ b/README
@@ -71,6 +71,13 @@ type=imaps.
remote: ~user/.ssh/authorized_keys:
command="/usr/lib/dovecot/imap",no-agent-forwarding,no-port-forwarding,no-pty,no-user-rc,no-X11-forwarding ssh-... id-interimap
+However for long-lived connections (using the --watch command-line
+option), the TLS overhead becomes negligible hence the advantage offered
+by the OpenSSH ControlPersist feature is not obvious. Furthermore if
+the remote server supports the IMAP COMPRESS extension [RFC4978], adding
+compress=DEFLATE to the configuration can also greatly reduce bandwidth
+usage with regular INET sockets (type=imaps or type=imap).
+
#######################################################################
diff --git a/interimap b/interimap
index af8b7fd..af2c510 100755
--- a/interimap
+++ b/interimap
@@ -109,7 +109,9 @@ my ($DBFILE, $LOCKFILE, $LOGGER_FD);
my $DBH;
# Clean after us
+my ($IMAP, $lIMAP, $rIMAP);
sub cleanup() {
+ undef $_ foreach grep defined, ($IMAP, $lIMAP, $rIMAP);
logger(undef, "Cleaning up...") if $CONFIG{debug};
unlink $LOCKFILE if defined $LOCKFILE and -f $LOCKFILE;
close $LOGGER_FD if defined $LOGGER_FD;
@@ -239,13 +241,13 @@ $LIST .= $#ARGV == 0 ? Net::IMAP::InterIMAP::quote($ARGV[0])
: ('('.join(' ',map {Net::IMAP::InterIMAP::quote($_)} @ARGV).')') if @ARGV;
-my $IMAP;
foreach my $name (qw/local remote/) {
my %config = %{$CONF->{$name}};
$config{$_} = $CONFIG{$_} foreach grep {defined $CONFIG{$_}} qw/quiet debug/;
$config{enable} = 'QRESYNC';
$config{name} = $name;
$config{'logger-fd'} = $LOGGER_FD if defined $LOGGER_FD;
+ $config{'compress'} //= ($name eq 'local' ? 'NO' : 'YES');
$IMAP->{$name} = { client => Net::IMAP::InterIMAP::->new(%config) };
my $client = $IMAP->{$name}->{client};
@@ -268,6 +270,7 @@ foreach my $name (qw/local remote/) {
@{$IMAP->{$_}}{qw/mailboxes delims/} = $IMAP->{$_}->{client}->list($LIST, @LIST_PARAMS) for qw/local remote/;
+
##############################################################################
#
@@ -507,7 +510,7 @@ sub sync_mailbox_list() {
}
sync_mailbox_list();
-my ($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
+($lIMAP, $rIMAP) = map {$IMAP->{$_}->{client}} qw/local remote/;
#############################################################################
@@ -1215,7 +1218,4 @@ while(1) {
sync_mailbox_list();
}
-END {
- $_->logout() foreach grep defined, ($lIMAP, $rIMAP);
- cleanup();
-}
+END { cleanup(); }
diff --git a/interimap.1 b/interimap.1
index 44235fc..bb97cf4 100644
--- a/interimap.1
+++ b/interimap.1
@@ -311,6 +311,13 @@ rely on Certificate Authorities.
Directory containing the certificate(s) of the trusted Certificate
Authorities, used for server certificate verification.
+.TP
+.I compress
+Whether to use the IMAP COMPRESS extension [RFC4978] for servers
+advertizing it.
+(Default: \(lqNO\(rq for the \(lq[local]\(rq section, \(lqYES\(rq for
+the \(lq[remote]\(rq section.)
+
.SH KNOWN BUGS AND LIMITATIONS
.IP \[bu]
diff --git a/interimap.sample b/interimap.sample
index 296f766..e469c98 100644
--- a/interimap.sample
+++ b/interimap.sample
@@ -13,6 +13,7 @@ host = imap.guilhem.org
# port = 993
username = guilhem
password = xxxxxxxxxxxxxxxx
+#compress = YES
# SSL options
#SSL_cipher_list = EECDH+AES:EDH+AES:!MEDIUM:!LOW:!EXP:!aNULL:!eNULL:!SSLv2:!SSLv3:!TLSv1:!TLSv1.1
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm
index 97756f4..966b965 100644
--- a/lib/Net/IMAP/InterIMAP.pm
+++ b/lib/Net/IMAP/InterIMAP.pm
@@ -20,11 +20,13 @@ package Net::IMAP::InterIMAP v0.0.1;
use warnings;
use strict;
+use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/;
use Config::Tiny ();
+use Errno 'EWOULDBLOCK';
use IO::Select ();
use List::Util 'first';
-use Socket 'SO_KEEPALIVE';
use POSIX ':signal_h';
+use Socket 'SO_KEEPALIVE';
use Exporter 'import';
BEGIN {
@@ -47,6 +49,7 @@ my %OPTIONS = (
password => qr/\A([\x01-\x7F]+)\z/,
auth => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
command => qr/\A(\/\P{Control}+)\z/,
+ compress => qr/\A($RE_ATOM_CHAR+(?: $RE_ATOM_CHAR+)*)\z/,
SSL_fingerprint => qr/\A([A-Za-z0-9]+\$\p{AHex}+)\z/,
SSL_cipher_list => qr/\A(\P{Control}+)\z/,
SSL_verify_trusted_peer => qr/\A(YES|NO)\z/i,
@@ -225,6 +228,11 @@ sub new($%) {
# (cf RFC 3501 section 3)
$self->{_STATE} = '';
+ # in/out buffer counts and output stream
+ $self->{_INCOUNT} = $self->{_INRAWCOUNT} = 0;
+ $self->{_OUTCOUNT} = $self->{_OUTRAWCOUNT} = 0;
+ $self->{_OUTBUF} = '';
+
if ($self->{type} eq 'tunnel') {
my $command = $self->{command} // $self->fail("Missing tunnel command");
@@ -232,7 +240,6 @@ sub new($%) {
pipe my $rd, $self->{STDIN} or $self->panic("Can't pipe: $!");
my $pid = fork // $self->panic("Can't fork: $!");
-
unless ($pid) {
# children
foreach (\*STDIN, \*STDOUT, $self->{STDIN}, $self->{STDOUT}) {
@@ -243,7 +250,6 @@ sub new($%) {
my $sigset = POSIX::SigSet::->new(SIGINT);
my $oldsigset = POSIX::SigSet::->new();
-
sigprocmask(SIG_BLOCK, $sigset, $oldsigset) // $self->panic("Can't block SIGINT: $!");
exec $command or $self->panic("Can't exec: $!");
@@ -282,6 +288,7 @@ sub new($%) {
$self->{$_} = $socket for qw/STDOUT STDIN/;
}
$self->{STDIN}->autoflush(0) // $self->panic("Can't turn off autoflush: $!");
+ binmode $self->{$_} foreach qw/STDIN STDOUT/;
# command counter
$self->{_TAG} = 0;
@@ -391,8 +398,41 @@ sub new($%) {
$self->capabilities();
}
}
-
$self->{_STATE} = 'AUTH';
+
+ # Don't send the COMPRESS command before STARTTLS or AUTH, as per RFC 4978
+ if (uc ($self->{compress} // 'NO') eq 'YES') {
+ 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.");
+ }
+ else {
+ my ($d, $i);
+ my $r = $self->_send("COMPRESS $algo");
+ unless ($r eq 'NO' and $IMAP_text =~ /\ANO \[COMPRESSIONACTIVE\] /) {
+ $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::Raw::Zlib::Deflate::->new(%args);
+ $self->panic("Can't create deflation stream: ", $d->msg())
+ unless defined $d and $status == Z_OK;
+
+ ($i, $status) = Compress::Raw::Zlib::Inflate::->new(%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);
+ }
+ else {
+ $self->fail("Unsupported compression algorithm: $algo");
+ }
+ }
+ }
+ }
+
my @extensions = !defined $self->{enable} ? ()
: ref $self->{enable} eq 'ARRAY' ? @{$self->{enable}}
: ($self->{enable});
@@ -411,9 +451,22 @@ sub new($%) {
# Log out when the Net::IMAP::InterIMAP object is destroyed.
sub DESTROY($) {
my $self = shift;
+ $self->{_STATE} = 'LOGOUT';
+
foreach (qw/STDIN STDOUT/) {
$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);
+ }
}
@@ -1153,21 +1206,74 @@ sub _fingerprint_match($$$) {
}
-# $self->_getline([$msg])
-# Read a line from the handle and strip the trailing CRLF.
+# $self->_getline([$length])
+# Read a line from the handle and strip the trailing CRLF, optionally
+# after reading a literal of the given $length (default: 0).
+# In list context, return a pair ($literal, $line); otherwise only
+# return the $line.
# /!\ Don't use this method with non-blocking IO!
sub _getline($;$) {
my $self = shift;
- my $msg = shift // '';
+ my $len = shift // 0;
- if ($self->{STDOUT}->opened()) {
- my $x = $self->{STDOUT}->getline() // $self->panic("Can't read: $!");
- $x =~ s/\r\n\z// or $self->panic($x);
- $self->logger("S: $msg", $x) if $self->{debug};
- return $x;
- }
- else {
- undef $self;
+ my $stdout = $self->{STDOUT};
+ $self->fail("Lost connection") unless $stdout->opened();
+
+ my (@lit, @line);
+ while(1) {
+ if ($self->{_OUTBUF} eq '') {
+ # nothing cached: read some more
+ # (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->fail("0 bytes read (got EOF)") unless $n > 0; # EOF
+ $self->{_OUTRAWCOUNT} += $n;
+
+ if (defined (my $i = $self->{_Z_INFLATE})) {
+ my $status = $i->inflate($buf, my $data);
+ $self->panic("Inflation failed: ", $i->msg()) unless $status == Z_OK;
+ $buf = $data;
+ }
+ $self->{_OUTBUF} = $buf;
+ }
+ if ($len == 0) { # read a regular line: stop after the first \r\n
+ if ((my $idx = 1 + index($self->{_OUTBUF}, "\n")) > 0) {
+ # found the EOL, we're done
+ my $lit = join '', @lit;
+ my $line = join '', @line, substr($self->{_OUTBUF}, 0, $idx);
+ $self->{_OUTBUF} = substr($self->{_OUTBUF}, $idx);
+
+ $self->{_OUTCOUNT} += length($lit) + length($line);
+ $line =~ s/\r\n\z// or $self->panic($line);
+ $self->logger('S: '.(@lit ? '[...]' : ''), $line) if $self->{debug};
+
+ return (wantarray ? ($lit, $line) : $line);
+ }
+ else {
+ push @line, $self->{_OUTBUF};
+ $self->{_OUTBUF} = '';
+ }
+ }
+ elsif ($len > 0) { # $len bytes of literal bytes to read
+ if ($len <= length($self->{_OUTBUF})) {
+ push @lit, substr($self->{_OUTBUF}, 0, $len, '');
+ $len = 0;
+ }
+ else {
+ push @lit, $self->{_OUTBUF};
+ $len -= length($self->{_OUTBUF});
+ $self->{_OUTBUF} = '';
+ }
+ next;
+ }
}
}
@@ -1203,6 +1309,56 @@ sub _update_cache_for($$%) {
}
+# $self->_write(@data)
+# Send the given @data to the IMAP server and flush the buffer. If a
+# compression layer is active, flush the deflation stream first.
+# Update the interal raw byte count, but the regular byte count must
+# have been updated earlier.
+sub _write($@) {
+ my $self = shift;
+ my @data = @_;
+
+ if (defined (my $d = $self->{_Z_DEFLATE})) {
+ my $status = $d->flush(my $buf, Z_SYNC_FLUSH);
+ $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
+ push @data, $buf if $buf ne '';
+ }
+
+ my $data = join '', @data;
+ $self->{STDIN}->write($data) // $self->panic("Can't write: $!");
+ $self->{STDIN}->flush() // $self->panic("Can't flush: $!");
+ $self->{_INRAWCOUNT} += length($data);
+}
+
+
+# $self->_z_deflate(@data)
+# Add the given @data to the deflation stream, and return the
+# compressed data.
+# This method is a noop if no compression layer is active.
+sub _z_deflate($@) {
+ my $self = shift;
+ my $data = join '', @_;
+ $self->{_INCOUNT} += length($data);
+ my $d = $self->{_Z_DEFLATE} // return @_;
+
+ my $status = $d->deflate($data, my $buf);
+ $self->panic("Deflation failed: ", $d->msg()) unless $status == Z_OK;
+ return ($buf) if $buf ne '';
+}
+
+
+# $self->_z_flush([$type])
+# Flush the deflation stream, and return the compressed data.
+# This method is a noop if no compression layer is active.
+sub _z_flush($;$) {
+ my $self = shift;
+ my $d = $self->{_Z_DEFLATE} // return;
+ my $status = $d->flush(my $buf, @_);
+ $self->panic("Can't flush deflation stream: ", $d->msg()) unless $status == Z_OK;
+ return ($buf) if $buf ne '';
+}
+
+
# $self->_send($command, [$callback])
# Send the given $command to the server, then wait for the response.
# (The status condition and response text are respectively placed in
@@ -1222,31 +1378,40 @@ sub _send($$;&) {
# go, otherwise send literals one at a time
my $tag = sprintf '%06d', $self->{_TAG}++;
my $litplus;
- my @command = ("$tag ");
- my $dbg_cmd = "C: $command[0]";
+
+ my @command = $self->_z_deflate("$tag ");
+ my $dbg_cmd = "C: $tag ";
+
while ($command =~ s/\A(.*?)\{([0-9]+)\}\r\n//) {
my ($str, $len) = ($1, $2);
my $lit = substr $command, 0, $len, ''; # consume the literal
$litplus //= $self->_capable('LITERAL+') ? '+' : '';
- push @command, $str, "{$len$litplus}", "\r\n";
+ push @command, $self->_z_deflate($str, "{$len$litplus}", "\r\n");
+
$self->logger($dbg_cmd, $str, "{$len$litplus}") if $self->{debug};
$dbg_cmd = 'C: [...]';
unless ($litplus) {
- $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
- $self->{STDIN}->flush();
+ $self->_write(@command);
my $x = $self->_getline();
$x =~ /\A\+ / or $self->panic($x);
@command = ();
}
- push @command, $lit;
+ if ($len <= 4096) {
+ push @command, $self->_z_deflate($lit);
+ } else {
+ # send a Z_FULL_FLUSH at the start and end of large literals,
+ # as hinted at in RFC 4978 section 4
+ # TODO only do that for non-text literals
+ push @command, $self->_z_flush(Z_FULL_FLUSH);
+ push @command, $self->_z_deflate($lit);
+ push @command, $self->_z_flush(Z_FULL_FLUSH);
+ }
}
- push @command, $command, "\r\n";
+ push @command, $self->_z_deflate($command, "\r\n");
$self->logger($dbg_cmd, $command) if $self->{debug};
- $self->{STDIN}->write(join('',@command)) // $self->panic("Can't write: $!");
- $self->{STDIN}->flush();
-
+ $self->_write(@command);
my $r;
# wait for the answer
@@ -1443,9 +1608,7 @@ sub _string($$) {
}
elsif ($$stream =~ s/\A\{([0-9]+)\}\z//) {
# literal
- $self->{STDOUT}->read(my $lit, $1) // $self->panic("Can't read: $!");
- # read a the rest of the response
- $$stream = $self->_getline('[...]');
+ (my $lit, $$stream) = $self->_getline($1);
return $lit;
}
else {
@@ -1647,8 +1810,9 @@ sub _resp($$;$$$) {
if (defined $callback and $cmd eq 'AUTHENTICATE') {
my $x = $callback->($_);
$self->logger("C: ", $x) if $self->{debug};
- $self->{STDIN}->write($x."\r\n") // $self->panic("Can't write: $!");
- $self->{STDIN}->flush();
+ $x .= "\r\n";
+ $self->{_INCOUNT} += length($x);
+ $self->_write($x);
}
}
else {