imap: support LIST command

We'll optimize for the common case of: $TAG LIST "" *
and rely on the grep perlfunc to handle trickier cases.

diff --git a/lib/PublicInbox/IMAP.pm b/lib/PublicInbox/IMAP.pm
index 7745d9f96f788962c14603bb520101a601a93f8b..ca9a0ea7d420feb3dcaa562d84fb2f8f2efe72c7 100644 (file)
--- a/lib/PublicInbox/IMAP.pm
+++ b/lib/PublicInbox/IMAP.pm
@@ -336,6 +336,20 @@ sub cmd_status ($$$;@) {
        "$tag OK Status complete\r\n";
 }
 
+my %patmap = ('*' => '.*', '%' => '[^\.]*');
+sub cmd_list ($$$$) {
+       my ($self, $tag, $refname, $wildcard) = @_;
+       my $l = $self->{imapd}->{inboxlist};
+       if ($refname eq '' && $wildcard eq '') {
+               # request for hierarchy delimiter
+               $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
+       } elsif ($refname ne '' || $wildcard ne '*') {
+               $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eig;
+               $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
+       }
+       \(join('', @$l, "$tag OK List complete\r\n"));
+}
+
 sub cmd_uid_fetch ($$$;@) {
        my ($self, $tag, $range, @want) = @_;
        my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";

diff --git a/lib/PublicInbox/IMAPD.pm b/lib/PublicInbox/IMAPD.pm
index 05aa30e42a15acb30e288896016c3d1f5df3fa3d..a3a2598661bbf97d09b0c5ddb550f5c9faeca506 100644 (file)
--- a/lib/PublicInbox/IMAPD.pm
+++ b/lib/PublicInbox/IMAPD.pm
@@ -21,10 +21,35 @@ sub new {
        }, $class;
 }
 
+sub refresh_inboxlist ($) {
+       my ($self) = @_;
+       my @names = map { $_->{newsgroup} } @{delete $self->{grouplist}};
+       my %ns; # "\Noselect \HasChildren"
+       for (@names) {
+               my $up = $_;
+               while ($up =~ s/\.[^\.]+\z//) {
+                       $ns{$up} = '\\Noselect \\HasChildren';
+               }
+       }
+       @names = map {;
+               my $at = delete($ns{$_}) ? '\\HasChildren' : '\\HasNoChildren';
+               qq[* LIST ($at) "." $_\r\n]
+       } @names;
+       push(@names, map { qq[* LIST ($ns{$_}) "." $_\r\n] } keys %ns);
+       @names = sort {
+               my ($xa) = ($a =~ / (\S+)\r\n/g);
+               my ($xb) = ($b =~ / (\S+)\r\n/g);
+               length($xa) <=> length($xb);
+       } @names;
+       $self->{inboxlist} = \@names;
+}
+
 sub refresh_groups {
        my ($self) = @_;
        my $pi_config = $self->{pi_config} = PublicInbox::Config->new;
        $self->SUPER::refresh_groups($pi_config);
+       refresh_inboxlist($self);
+
        if (my $idler = $self->{idler}) {
                $idler->refresh($pi_config);
        }

diff --git a/t/imapd.t b/t/imapd.t
index 7512bb90050d03ed6ee198a4176ff00b3984dac0..a377c02ab43f76e07e8c0c23e793c0188402a794 100644 (file)
--- a/t/imapd.t
+++ b/t/imapd.t
@@ -87,6 +87,65 @@ like($raw[0], qr/\A\*\x20STATUS\x20inbox\.i1\x20
        \(MESSAGES\x20\d+\x20UIDNEXT\x20\d+\x20UIDVALIDITY\x20\d+\)\r\n/sx);
 like($raw[1], qr/\A\S+ OK /, 'finished status response');
 
+@raw = $mic->list;
+like($raw[0], qr/^\* LIST \(.*?\) "\." inbox/,
+       'got an inbox');
+like($raw[-1], qr/^\S+ OK /, 'response ended with OK');
+is(scalar(@raw), scalar(@V) + 2, 'default LIST response');
+@raw = $mic->list('', 'inbox.i1');
+is(scalar(@raw), 2, 'limited LIST response');
+like($raw[0], qr/^\* LIST \(.*?\) "\." inbox/,
+               'got an inbox.i1');
+like($raw[-1], qr/^\S+ OK /, 'response ended with OK');
+
+{ # make sure we get '%' globbing right
+       my @n = map { { newsgroup => $_ } } (qw(x.y.z x.z.y));
+       my $self = { imapd => { grouplist => \@n } };
+       PublicInbox::IMAPD::refresh_inboxlist($self->{imapd});
+       my $res = PublicInbox::IMAP::cmd_list($self, 'tag', 'x', '%');
+       is(scalar($$res =~ tr/\n/\n/), 2, 'only one result');
+       like($$res, qr/ x\r\ntag OK/, 'saw expected');
+       $res = PublicInbox::IMAP::cmd_list($self, 'tag', 'x.', '%');
+       is(scalar($$res =~ tr/\n/\n/), 3, 'only one result');
+       is(scalar(my @x = ($$res =~ m/ x\.[zy]\r\n/g)), 2, 'match expected');
+
+       $res = PublicInbox::IMAP::cmd_list($self, 't', 'x.(?{die "RCE"})', '%');
+       like($$res, qr/\At OK /, 'refname does not match attempted RCE');
+       $res = PublicInbox::IMAP::cmd_list($self, 't', '', '(?{die "RCE"})%');
+       like($$res, qr/\At OK /, 'wildcard does not match attempted RCE');
+}
+
+if ($ENV{TEST_BENCHMARK}) {
+       use Benchmark qw(:all);
+       my @n = map { { newsgroup => "inbox.comp.foo.bar.$_" } } (0..50000);
+       push @n, map { { newsgroup => "xobni.womp.foo.bar.$_" } } (0..50000);
+       my $self = { imapd => { grouplist => \@n } };
+       PublicInbox::IMAPD::refresh_inboxlist($self->{imapd});
+
+       my $n = scalar @n;
+       open my $null, '>', '/dev/null' or die;
+       my $ds = { sock => $null };
+       my $nr = 200;
+       diag "starting benchmark...";
+       my $t = timeit(1, sub {
+               for (0..$nr) {
+                       my $res = PublicInbox::IMAP::cmd_list($self, 'tag',
+                                                               '', '*');
+                       PublicInbox::DS::write($ds, $res);
+               }
+       });
+       diag timestr($t). "list all for $n inboxes $nr times";
+       $nr = 20;
+       $t = timeit(1, sub {
+               for (0..$nr) {
+                       my $res = PublicInbox::IMAP::cmd_list($self, 'tag',
+                                                               'inbox.', '%');
+                       PublicInbox::DS::write($ds, $res);
+               }
+       });
+       diag timestr($t). "list partial for $n inboxes $nr times";
+}
+
 my $ret = $mic->search('all') or BAIL_OUT "SEARCH FAIL $@";
 is_deeply($ret, [ 1 ], 'search all works');
 $ret = $mic->search('uid 1') or BAIL_OUT "SEARCH FAIL $@";