diff options
Diffstat (limited to 'lib/Net/IMAP')
| -rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 224 |
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 { |