From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on dcvr.yhbt.net X-Spam-Level: X-Spam-Status: No, score=-4.0 required=3.0 tests=ALL_TRUSTED,BAYES_00 shortcircuit=no autolearn=ham autolearn_force=no version=3.4.2 Received: from localhost (dcvr.yhbt.net [127.0.0.1]) by dcvr.yhbt.net (Postfix) with ESMTP id E9AA31FBD5 for ; Wed, 10 Jun 2020 07:06:25 +0000 (UTC) From: Eric Wong To: meta@public-inbox.org Subject: [PATCH 36/82] imapclient: wrapper for Mail::IMAPClient Date: Wed, 10 Jun 2020 07:04:33 +0000 Message-Id: <20200610070519.18252-37-e@yhbt.net> In-Reply-To: <20200610070519.18252-1-e@yhbt.net> References: <20200610070519.18252-1-e@yhbt.net> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit List-Id: We'll be using this wrapper class to workaround some upstream bugs in Mail::IMAPClient. There may also be experiments with new APIs for more performance. --- MANIFEST | 1 + lib/PublicInbox/IMAPClient.pm | 119 ++++++++++++++++++++++++++++++++++ t/imapd-tls.t | 37 +++++------ t/imapd.t | 35 +++++----- 4 files changed, 155 insertions(+), 37 deletions(-) create mode 100644 lib/PublicInbox/IMAPClient.pm diff --git a/MANIFEST b/MANIFEST index f74852b6e90..6744a519efc 100644 --- a/MANIFEST +++ b/MANIFEST @@ -128,6 +128,7 @@ lib/PublicInbox/HTTPD/Async.pm lib/PublicInbox/HlMod.pm lib/PublicInbox/Hval.pm lib/PublicInbox/IMAP.pm +lib/PublicInbox/IMAPClient.pm lib/PublicInbox/IMAPD.pm lib/PublicInbox/IMAPdeflate.pm lib/PublicInbox/Import.pm diff --git a/lib/PublicInbox/IMAPClient.pm b/lib/PublicInbox/IMAPClient.pm new file mode 100644 index 00000000000..33deee9eb3d --- /dev/null +++ b/lib/PublicInbox/IMAPClient.pm @@ -0,0 +1,119 @@ +# This library is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself, either Perl version 5.8.0 or, at +# your option, any later version of Perl 5 you may have available. +# +# The license for this file differs from the rest of public-inbox. +# +# Workaround some bugs in upstream Mail::IMAPClient when +# compression is enabled: +# - reference cycle: https://rt.cpan.org/Ticket/Display.html?id=132654 +# - read starvation: https://rt.cpan.org/Ticket/Display.html?id=132720 +package PublicInbox::IMAPClient; +use strict; +use parent 'Mail::IMAPClient'; +use Errno qw(EAGAIN); + +# RFC4978 COMPRESS +sub compress { + my ($self) = @_; + + # BUG? strict check on capability commented out for now... + #my $can = $self->has_capability("COMPRESS") + #return undef unless $can and $can eq "DEFLATE"; + + $self->_imap_command("COMPRESS DEFLATE") or return undef; + + my $zcl = $self->_load_module("Compress-Zlib") or return undef; + + # give caller control of args if desired + $self->Compress( + [ + -WindowBits => -$zcl->MAX_WBITS(), + -Level => $zcl->Z_BEST_SPEED() + ] + ) unless ( $self->Compress and ref( $self->Compress ) eq "ARRAY" ); + + my ( $rc, $do, $io ); + + ( $do, $rc ) = Compress::Zlib::deflateInit( @{ $self->Compress } ); + unless ( $rc == $zcl->Z_OK ) { + $self->LastError("deflateInit failed (rc=$rc)"); + return undef; + } + + ( $io, $rc ) = + Compress::Zlib::inflateInit( -WindowBits => -$zcl->MAX_WBITS() ); + unless ( $rc == $zcl->Z_OK ) { + $self->LastError("inflateInit failed (rc=$rc)"); + return undef; + } + + $self->{Prewritemethod} = sub { + my ( $self, $string ) = @_; + + my ( $rc, $out1, $out2 ); + ( $out1, $rc ) = $do->deflate($string); + ( $out2, $rc ) = $do->flush( $zcl->Z_PARTIAL_FLUSH() ) + unless ( $rc != $zcl->Z_OK ); + + unless ( $rc == $zcl->Z_OK ) { + $self->LastError("deflate/flush failed (rc=$rc)"); + return undef; + } + + return $out1 . $out2; + }; + + # need to retain some state for Readmoremethod/Readmethod calls + my ( $Zbuf, $Ibuf ) = ( "", "" ); + + $self->{Readmoremethod} = sub { + my $self = shift; + return 1 if ( length($Zbuf) || length($Ibuf) ); + $self->__read_more(@_); + }; + + $self->{Readmethod} = sub { + my ( $self, $fh, $buf, $len, $off ) = @_; + + # get more data, but empty $Ibuf first if any data is left + my ( $lz, $li ) = ( length $Zbuf, length $Ibuf ); + if ( $lz || !$li ) { + my $readlen = $self->Buffer || 4096; + my $ret = sysread( $fh, $Zbuf, $readlen, length $Zbuf ); + $lz = length $Zbuf; + return $ret if ( !$ret && !$lz ); # $ret is undef or 0 + } + + # accumulate inflated data in $Ibuf + if ($lz) { + my ( $tbuf, $rc ) = $io->inflate( \$Zbuf ); + unless ( $rc == $zcl->Z_OK ) { + $self->LastError("inflate failed (rc=$rc)"); + return undef; + } + $Ibuf .= $tbuf; + $li = length $Ibuf; + } + + if ( !$li ) { + # note: faking EAGAIN here is only safe with level-triggered + # I/O readiness notifications (select, poll). Refactoring + # callers will be needed in the unlikely case somebody wants + # to use edge-triggered notifications (EV_CLEAR, EPOLLET). + $! = EAGAIN; + return undef; + } + + # pull desired length of data from $Ibuf + my $tbuf = substr( $Ibuf, 0, $len ); + substr( $Ibuf, 0, $len ) = ""; + substr( $$buf, $off ) = $tbuf; + + return length $tbuf; + }; + + return $self; +} + +1; diff --git a/t/imapd-tls.t b/t/imapd-tls.t index 9f5abfe048e..5352d100e4b 100644 --- a/t/imapd-tls.t +++ b/t/imapd-tls.t @@ -7,8 +7,15 @@ use Socket qw(IPPROTO_TCP SOL_SOCKET); use PublicInbox::TestCommon; # IO::Poll is part of the standard library, but distros may split it off... require_mods(qw(DBD::SQLite IO::Socket::SSL Mail::IMAPClient IO::Poll)); -Mail::IMAPClient->can('starttls') or +my $imap_client = 'Mail::IMAPClient'; +$imap_client->can('starttls') or plan skip_all => 'Mail::IMAPClient does not support TLS'; +my $can_compress = $imap_client->can('compress'); +if ($can_compress) { # hope this gets fixed upstream, soon + require PublicInbox::IMAPClient; + $imap_client = 'PublicInbox::IMAPClient'; +} + my $cert = 'certs/server-cert.pem'; my $key = 'certs/server-key.pem'; unless (-r $key && -r $cert) { @@ -67,18 +74,6 @@ my $starttls_addr = $starttls->sockhost . ':' . $starttls->sockport; my $env = { PI_CONFIG => $pi_config }; my $td; -# Mail::IMAPClient ->compress creates cyclic reference: -# https://rt.cpan.org/Ticket/Display.html?id=132654 -my $compress_logout = sub { - my ($c) = @_; - ok($c->logout, 'logout ok after ->compress'); - # all documented in Mail::IMAPClient manpage: - for (qw(Readmoremethod Readmethod Prewritemethod)) { - $c->$_(undef); - } -}; - - for my $args ( [ "--cert=$cert", "--key=$key", "-limaps://$imaps_addr", @@ -112,7 +107,7 @@ for my $args ( Server => $imaps->sockhost, Port => $imaps->sockport); # IMAPS - my $c = Mail::IMAPClient->new(%imaps_opt, Ssl => [ %o ]); + my $c = $imap_client->new(%imaps_opt, Ssl => [ %o ]); ok($c && $c->IsAuthenticated, 'authenticated'); ok($c->select($group), 'SELECT works'); ok(!(scalar $c->has_capability('STARTTLS')), @@ -122,12 +117,12 @@ for my $args ( ok($c->compress, 'compression enabled with IMAPS'); ok(!$c->starttls, 'starttls still fails'); ok($c->noop, 'noop succeeds'); - $compress_logout->($c); + ok($c->logout, 'logout succeeds'); # STARTTLS my %imap_opt = (Server => $starttls->sockhost, Port => $starttls->sockport); - $c = Mail::IMAPClient->new(%imap_opt); + $c = $imap_client->new(%imap_opt); ok(scalar $c->has_capability('STARTTLS'), 'starttls advertised'); ok($c->Starttls([ %o ]), 'set starttls options'); @@ -141,25 +136,25 @@ for my $args ( ok($c->noop, 'NOOP works'); ok($c->compress, 'compression enabled with IMAPS'); ok($c->noop, 'NOOP works after compress'); - $compress_logout->($c); + ok($c->logout, 'logout succeeds after compress'); # STARTTLS with bad hostname $o{SSL_hostname} = $o{SSL_verifycn_name} = 'server.invalid'; - $c = Mail::IMAPClient->new(%imap_opt); + $c = $imap_client->new(%imap_opt); ok(scalar $c->has_capability('STARTTLS'), 'starttls advertised'); ok($c->Starttls([ %o ]), 'set starttls options'); ok(!$c->starttls, '->starttls fails with bad hostname'); - $c = Mail::IMAPClient->new(%imap_opt); + $c = $imap_client->new(%imap_opt); ok($c->noop, 'NOOP still works from plain IMAP'); # IMAPS with bad hostname - $c = Mail::IMAPClient->new(%imaps_opt, Ssl => [ %o ]); + $c = $imap_client->new(%imaps_opt, Ssl => [ %o ]); is($c, undef, 'IMAPS fails with bad hostname'); # make hostname valid $o{SSL_hostname} = $o{SSL_verifycn_name} = 'server.local'; - $c = Mail::IMAPClient->new(%imaps_opt, Ssl => [ %o ]); + $c = $imap_client->new(%imaps_opt, Ssl => [ %o ]); ok($c, 'IMAPS succeeds again with valid hostname'); # slow TLS connection did not block the other fast clients while diff --git a/t/imapd.t b/t/imapd.t index 7af14f1b150..3d0be340846 100644 --- a/t/imapd.t +++ b/t/imapd.t @@ -9,6 +9,12 @@ use PublicInbox::TestCommon; use PublicInbox::Config; use PublicInbox::Spawn qw(which); require_mods(qw(DBD::SQLite Mail::IMAPClient Mail::IMAPClient::BodyStructure)); +my $imap_client = 'Mail::IMAPClient'; +my $can_compress = $imap_client->can('compress'); +if ($can_compress) { # hope this gets fixed upstream, soon + require PublicInbox::IMAPClient; + $imap_client = 'PublicInbox::IMAPClient'; +} my $level = '-Lbasic'; SKIP: { @@ -57,7 +63,7 @@ my %mic_opt = ( Port => $sock->sockport, Uid => 1, ); -my $mic = Mail::IMAPClient->new(%mic_opt); +my $mic = $imap_client->new(%mic_opt); my $pre_login_capa = $mic->capability; is(grep(/\AAUTH=ANONYMOUS\z/, @$pre_login_capa), 1, 'AUTH=ANONYMOUS advertised pre-login'); @@ -71,7 +77,7 @@ ok(join("\n", @$pre_login_capa) ne join("\n", @$post_login_capa), $mic_opt{Authmechanism} = 'ANONYMOUS'; $mic_opt{Authcallback} = sub { '' }; -$mic = Mail::IMAPClient->new(%mic_opt); +$mic = $imap_client->new(%mic_opt); ok($mic && $mic->login && $mic->IsAuthenticated, 'AUTHENTICATE ANONYMOUS'); my $post_auth_anon_capa = $mic->capability; is_deeply($post_auth_anon_capa, $post_login_capa, @@ -175,20 +181,17 @@ for my $r ('1:*', '1') { is(lc($bs->bodyenc), '8bit', '->bodyenc'); } -# Mail::IMAPClient ->compress creates cyclic reference: -# https://rt.cpan.org/Ticket/Display.html?id=132654 -my $compress_logout = sub { - my ($c) = @_; - ok($c->logout, 'logout ok after ->compress'); - # all documented in Mail::IMAPClient manpage: - for (qw(Readmoremethod Readmethod Prewritemethod)) { - $c->$_(undef); - } -}; - is_deeply([$mic->has_capability('COMPRESS')], ['DEFLATE'], 'deflate cap'); -ok($mic->compress, 'compress enabled'); -$compress_logout->($mic); +SKIP: { + skip 'Mail::IMAPClient too old for ->compress', 2 if !$can_compress; + my $c = $imap_client->new(%mic_opt); + ok($c && $c->compress, 'compress enabled'); + ok($c->examine('inbox.i1'), 'EXAMINE succeeds after COMPRESS'); + $ret = $c->search('uid 1:*') or BAIL_OUT "SEARCH FAIL $@"; + is_deeply($ret, [ 1 ], 'search UID 1:* works after compression'); +} + +ok($mic->logout, 'logout works'); my $have_inotify = eval { require Linux::Inotify2; 1 }; @@ -198,7 +201,7 @@ $pi_config->each_inbox(sub { my $env = { ORIGINAL_RECIPIENT => $ibx->{-primary_address} }; my $name = $ibx->{name}; my $ng = $ibx->{newsgroup}; - my $mic = Mail::IMAPClient->new(%mic_opt); + my $mic = $imap_client->new(%mic_opt); ok($mic && $mic->login && $mic->IsAuthenticated, "authed $name"); my $uidnext = $mic->uidnext($ng); # we'll fetch BODYSTRUCTURE on this ok($uidnext, 'got uidnext for later fetch');