Add support for the IMAP COMPRESS extension [RFC4978].

Also, add traffic statistics after closing the connection to the IMAP
server.

1 files changed, 194 insertions, 30 deletions

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 {