imap: support LIST command

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

3 files changed, 98 insertions, 0 deletions

diff --git a/lib/PublicInbox/IMAP.pm b/lib/PublicInbox/IMAP.pm
index 7745d9f9..ca9a0ea7 100644
--- 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 05aa30e4..a3a25986 100644
--- 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 7512bb90..a377c02a 100644
--- 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 $@";