]> Sergey Matveev's repositories - public-inbox.git/blob - lib/PublicInbox/IMAP.pm
2aa7ab346c1fb1462cdc3391906d513047e84796
[public-inbox.git] / lib / PublicInbox / IMAP.pm
1 # Copyright (C) 2020 all contributors <meta@public-inbox.org>
2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
3 #
4 # Each instance of this represents an IMAP client connected to
5 # public-inbox-imapd.  Much of this was taken from NNTP, but
6 # further refined while experimenting on future ideas to handle
7 # slow storage.
8 #
9 # data notes:
10 # * NNTP article numbers are UIDs and message sequence numbers (MSNs)
11 # * Message sequence numbers (MSNs) can be stable since we're read-only.
12 #   Most IMAP clients use UIDs (I hope), and we can return a dummy
13 #   message if a client requests a non-existent MSN.
14
15 package PublicInbox::IMAP;
16 use strict;
17 use base qw(PublicInbox::DS);
18 use fields qw(imapd logged_in ibx long_cb -login_tag
19         -idle_tag -idle_max);
20 use PublicInbox::Eml;
21 use PublicInbox::EmlContentFoo qw(parse_content_disposition);
22 use PublicInbox::DS qw(now);
23 use PublicInbox::Syscall qw(EPOLLIN EPOLLONESHOT);
24 use Text::ParseWords qw(parse_line);
25 use Errno qw(EAGAIN);
26 my $Address;
27 for my $mod (qw(Email::Address::XS Mail::Address)) {
28         eval "require $mod" or next;
29         $Address = $mod and last;
30 }
31 die "neither Email::Address::XS nor Mail::Address loaded: $@" if !$Address;
32
33 sub LINE_MAX () { 512 } # does RFC 3501 have a limit like RFC 977?
34
35 my %FETCH_NEED_BLOB = ( # for future optimization
36         'BODY.PEEK[HEADER]' => 1,
37         'BODY.PEEK[TEXT]' => 1,
38         'BODY.PEEK[]' => 1,
39         'BODY[HEADER]' => 1,
40         'BODY[TEXT]' => 1,
41         'BODY[]' => 1,
42         'RFC822.HEADER' => 1,
43         'RFC822.SIZE' => 1, # needs CRLF conversion :<
44         'RFC822.TEXT' => 1,
45         BODY => 1,
46         BODYSTRUCTURE => 1,
47         ENVELOPE => 1,
48         FLAGS => 0,
49         INTERNALDATE => 0,
50         RFC822 => 1,
51         UID => 0,
52 );
53 my %FETCH_ATT = map { $_ => [ $_ ] } keys %FETCH_NEED_BLOB;
54
55 # aliases (RFC 3501 section 6.4.5)
56 $FETCH_ATT{FAST} = [ qw(FLAGS INTERNALDATE RFC822.SIZE) ];
57 $FETCH_ATT{ALL} = [ @{$FETCH_ATT{FAST}}, 'ENVELOPE' ];
58 $FETCH_ATT{FULL} = [ @{$FETCH_ATT{ALL}}, 'BODY' ];
59
60 for my $att (keys %FETCH_ATT) {
61         my %h = map { $_ => 1 } @{$FETCH_ATT{$att}};
62         $FETCH_ATT{$att} = \%h;
63 }
64
65 sub greet ($) {
66         my ($self) = @_;
67         my $capa = capa($self);
68         $self->write(\"* OK [$capa] public-inbox-imapd ready\r\n");
69 }
70
71 sub new ($$$) {
72         my ($class, $sock, $imapd) = @_;
73         my $self = fields::new($class);
74         my $ev = EPOLLIN;
75         my $wbuf;
76         if ($sock->can('accept_SSL') && !$sock->accept_SSL) {
77                 return CORE::close($sock) if $! != EAGAIN;
78                 $ev = PublicInbox::TLS::epollbit();
79                 $wbuf = [ \&PublicInbox::DS::accept_tls_step, \&greet ];
80         }
81         $self->SUPER::new($sock, $ev | EPOLLONESHOT);
82         $self->{imapd} = $imapd;
83         if ($wbuf) {
84                 $self->{wbuf} = $wbuf;
85         } else {
86                 greet($self);
87         }
88         $self->update_idle_time;
89         $self;
90 }
91
92 sub capa ($) {
93         my ($self) = @_;
94
95         # dovecot advertises IDLE pre-login; perhaps because some clients
96         # depend on it, so we'll do the same
97         my $capa = 'CAPABILITY IMAP4rev1 IDLE';
98         if ($self->{logged_in}) {
99                 $capa .= ' COMPRESS=DEFLATE';
100         } else {
101                 if (!($self->{sock} // $self)->can('accept_SSL') &&
102                         $self->{imapd}->{accept_tls}) {
103                         $capa .= ' STARTTLS';
104                 }
105                 $capa .= ' AUTH=ANONYMOUS';
106         }
107 }
108
109 sub login_success ($$) {
110         my ($self, $tag) = @_;
111         $self->{logged_in} = 1;
112         my $capa = capa($self);
113         "$tag OK [$capa] Logged in\r\n";
114 }
115
116 sub auth_challenge_ok ($) {
117         my ($self) = @_;
118         my $tag = delete($self->{-login_tag}) or return;
119         login_success($self, $tag);
120 }
121
122 sub cmd_login ($$$$) {
123         my ($self, $tag) = @_; # ignore ($user, $password) = ($_[2], $_[3])
124         login_success($self, $tag);
125 }
126
127 sub cmd_logout ($$) {
128         my ($self, $tag) = @_;
129         delete $self->{logged_in};
130         $self->write(\"* BYE logging out\r\n$tag OK Logout done\r\n");
131         $self->shutdn; # PublicInbox::DS::shutdn
132         undef;
133 }
134
135 sub cmd_authenticate ($$$) {
136         my ($self, $tag) = @_; # $method = $_[2], should be "ANONYMOUS"
137         $self->{-login_tag} = $tag;
138         "+\r\n"; # challenge
139 }
140
141 sub cmd_capability ($$) {
142         my ($self, $tag) = @_;
143         '* '.capa($self)."\r\n$tag OK Capability done\r\n";
144 }
145
146 sub cmd_noop ($$) { "$_[1] OK Noop done\r\n" }
147
148 # called by PublicInbox::InboxIdle
149 sub on_inbox_unlock {
150         my ($self, $ibx) = @_;
151         my $new = $ibx->mm->max;
152         defined(my $old = $self->{-idle_max}) or die 'BUG: -idle_max unset';
153         if ($new > $old) {
154                 $self->{-idle_max} = $new;
155                 $self->msg_more("* $_ EXISTS\r\n") for (($old + 1)..($new - 1));
156                 $self->write(\"* $new EXISTS\r\n");
157         }
158 }
159
160 sub cmd_idle ($$) {
161         my ($self, $tag) = @_;
162         # IDLE seems allowed by dovecot w/o a mailbox selected *shrug*
163         my $ibx = $self->{ibx} or return "$tag BAD no mailbox selected\r\n";
164         $ibx->subscribe_unlock(fileno($self->{sock}), $self);
165         $self->{imapd}->idler_start;
166         $self->{-idle_tag} = $tag;
167         $self->{-idle_max} = $ibx->mm->max // 0;
168         "+ idling\r\n"
169 }
170
171 sub cmd_done ($$) {
172         my ($self, $tag) = @_; # $tag is "DONE" (case-insensitive)
173         defined(my $idle_tag = delete $self->{-idle_tag}) or
174                 return "$tag BAD not idle\r\n";
175         my $ibx = $self->{ibx} or do {
176                 warn "BUG: idle_tag set w/o inbox";
177                 return "$tag BAD internal bug\r\n";
178         };
179         $ibx->unsubscribe_unlock(fileno($self->{sock}));
180         "$idle_tag OK Idle done\r\n";
181 }
182
183 sub cmd_examine ($$$) {
184         my ($self, $tag, $mailbox) = @_;
185         my $ibx = $self->{imapd}->{groups}->{$mailbox} or
186                 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
187         my $mm = $ibx->mm;
188         my $max = $mm->max // 0;
189         # RFC 3501 2.3.1.1 -  "A good UIDVALIDITY value to use in
190         # this case is a 32-bit representation of the creation
191         # date/time of the mailbox"
192         my $uidvalidity = $mm->created_at or return "$tag BAD UIDVALIDITY\r\n";
193         my $uidnext = $max + 1;
194
195         # XXX: do we need this? RFC 5162/7162
196         my $ret = $self->{ibx} ? "* OK [CLOSED] previous closed\r\n" : '';
197         $self->{ibx} = $ibx;
198         $ret .= <<EOF;
199 * $max EXISTS\r
200 * $max RECENT\r
201 * FLAGS (\\Seen)\r
202 * OK [PERMANENTFLAGS ()] Read-only mailbox\r
203 EOF
204         $ret .= "* OK [UNSEEN $max]\r\n" if $max;
205         $ret .= "* OK [UIDNEXT $uidnext]\r\n" if defined $uidnext;
206         $ret .= "* OK [UIDVALIDITY $uidvalidity]\r\n" if defined $uidvalidity;
207         $ret .= "$tag OK [READ-ONLY] EXAMINE/SELECT done\r\n";
208 }
209
210 sub _esc ($) {
211         my ($v) = @_;
212         if (!defined($v)) {
213                 'NIL';
214         } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string
215                 '{' . length($v) . "}\r\n" . $v;
216         } else { # quoted string
217                 qq{"$v"}
218         }
219 }
220
221 sub addr_envelope ($$;$) {
222         my ($eml, $x, $y) = @_;
223         my $v = $eml->header_raw($x) //
224                 ($y ? $eml->header_raw($y) : undef) // return 'NIL';
225
226         my @x = $Address->parse($v) or return 'NIL';
227         '(' . join('',
228                 map { '(' . join(' ',
229                                 _esc($_->name), 'NIL',
230                                 _esc($_->user), _esc($_->host)
231                         ) . ')'
232                 } @x) .
233         ')';
234 }
235
236 sub eml_envelope ($) {
237         my ($eml) = @_;
238         '(' . join(' ',
239                 _esc($eml->header_raw('Date')),
240                 _esc($eml->header_raw('Subject')),
241                 addr_envelope($eml, 'From'),
242                 addr_envelope($eml, 'Sender', 'From'),
243                 addr_envelope($eml, 'Reply-To', 'From'),
244                 addr_envelope($eml, 'To'),
245                 addr_envelope($eml, 'Cc'),
246                 addr_envelope($eml, 'Bcc'),
247                 _esc($eml->header_raw('In-Reply-To')),
248                 _esc($eml->header_raw('Message-ID')),
249         ) . ')';
250 }
251
252 sub _esc_hash ($) {
253         my ($hash) = @_;
254         if ($hash && scalar keys %$hash) {
255                 $hash = [ %$hash ]; # flatten hash into 1-dimensional array
256                 '(' . join(' ', map { _esc($_) } @$hash) . ')';
257         } else {
258                 'NIL';
259         }
260 }
261
262 sub body_disposition ($) {
263         my ($eml) = @_;
264         my $cd = $eml->header_raw('Content-Disposition') or return 'NIL';
265         $cd = parse_content_disposition($cd);
266         my $buf = '('._esc($cd->{type});
267         $buf .= ' ' . _esc_hash(delete $cd->{attributes});
268         $buf .= ')';
269 }
270
271 sub body_leaf ($$;$) {
272         my ($eml, $structure, $hold) = @_;
273         my $buf = '';
274         $eml->{is_submsg} and # parent was a message/(rfc822|news|global)
275                 $buf .= eml_envelope($eml). ' ';
276         my $ct = $eml->ct;
277         $buf .= '('._esc($ct->{type}).' ';
278         $buf .= _esc($ct->{subtype});
279         $buf .= ' ' . _esc_hash(delete $ct->{attributes});
280         $buf .= ' ' . _esc($eml->header_raw('Content-ID'));
281         $buf .= ' ' . _esc($eml->header_raw('Content-Description'));
282         my $cte = $eml->header_raw('Content-Transfer-Encoding') // '7bit';
283         $buf .= ' ' . _esc($cte);
284         $buf .= ' ' . $eml->{imap_body_len};
285         $buf .= ' '.($eml->body_raw =~ tr/\n/\n/) if lc($ct->{type}) eq 'text';
286
287         # for message/(rfc822|global|news), $hold[0] should have envelope
288         $buf .= ' ' . (@$hold ? join('', @$hold) : 'NIL') if $hold;
289
290         if ($structure) {
291                 $buf .= ' '._esc($eml->header_raw('Content-MD5'));
292                 $buf .= ' '. body_disposition($eml);
293                 $buf .= ' '._esc($eml->header_raw('Content-Language'));
294                 $buf .= ' '._esc($eml->header_raw('Content-Location'));
295         }
296         $buf .= ')';
297 }
298
299 sub body_parent ($$$) {
300         my ($eml, $structure, $hold) = @_;
301         my $ct = $eml->ct;
302         my $type = lc($ct->{type});
303         if ($type eq 'multipart') {
304                 my $buf = '(';
305                 $buf .= @$hold ? join('', @$hold) : 'NIL';
306                 $buf .= ' '._esc($ct->{subtype});
307                 if ($structure) {
308                         $buf .= ' '._esc_hash(delete $ct->{attributes});
309                         $buf .= ' '.body_disposition($eml);
310                         $buf .= ' '._esc($eml->header_raw('Content-Language'));
311                         $buf .= ' '._esc($eml->header_raw('Content-Location'));
312                 }
313                 $buf .= ')';
314                 @$hold = ($buf);
315         } else { # message/(rfc822|global|news)
316                 @$hold = (body_leaf($eml, $structure, $hold));
317         }
318 }
319
320 # this is gross, but we need to process the parent part AFTER
321 # the child parts are done
322 sub bodystructure_prep {
323         my ($p, $q) = @_;
324         my ($eml, $depth) = @$p; # ignore idx
325         # set length here, as $eml->{bdy} gets deleted for message/rfc822
326         $eml->{imap_body_len} = length($eml->body_raw);
327         push @$q, $eml, $depth;
328 }
329
330 # for FETCH BODY and FETCH BODYSTRUCTURE
331 sub fetch_body ($;$) {
332         my ($eml, $structure) = @_;
333         my @q;
334         $eml->each_part(\&bodystructure_prep, \@q, 0, 1);
335         my $cur_depth = 0;
336         my @hold;
337         do {
338                 my ($part, $depth) = splice(@q, -2);
339                 my $is_mp_parent = $depth == ($cur_depth - 1);
340                 $cur_depth = $depth;
341
342                 if ($is_mp_parent) {
343                         body_parent($part, $structure, \@hold);
344                 } else {
345                         unshift @hold, body_leaf($part, $structure);
346                 }
347         } while (@q);
348         join('', @hold);
349 }
350
351 sub dummy_message ($$) {
352         my ($seqno, $ibx) = @_;
353         my $ret = <<EOF;
354 From: nobody\@localhost\r
355 To: nobody\@localhost\r
356 Date: Thu, 01 Jan 1970 00:00:00 +0000\r
357 Message-ID: <dummy-$seqno\@$ibx->{newsgroup}>\r
358 Subject: dummy message #$seqno\r
359 \r
360 You're seeing this message because your IMAP client didn't use UIDs.\r
361 The message which used to use this sequence number was likely spam\r
362 and removed by the administrator.\r
363 EOF
364         \$ret;
365 }
366
367 sub uid_fetch_cb { # called by git->cat_async
368         my ($bref, $oid, $type, $size, $fetch_m_arg) = @_;
369         my ($self, undef, $ibx, undef, undef, $msgs, $want) = @$fetch_m_arg;
370         my $smsg = shift @$msgs or die 'BUG: no smsg';
371         if (!defined($oid)) {
372                 # it's possible to have TOCTOU if an admin runs
373                 # public-inbox-(edit|purge), just move onto the next message
374                 return unless defined $want->{-seqno};
375                 $bref = dummy_message($smsg->{num}, $ibx);
376         } else {
377                 $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid";
378         }
379         $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
380
381         # fixup old bug from import (pre-a0c07cba0e5d8b6a)
382         $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
383
384         $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
385
386         $want->{'RFC822.SIZE'} and
387                 $self->msg_more(' RFC822.SIZE '.length($$bref));
388         $want->{INTERNALDATE} and
389                 $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
390         $want->{FLAGS} and $self->msg_more(' FLAGS ()');
391         for ('RFC822', 'BODY[]', 'BODY.PEEK[]') {
392                 next unless $want->{$_};
393                 $self->msg_more(" $_ {".length($$bref)."}\r\n");
394                 $self->msg_more($$bref);
395         }
396
397         my $eml = PublicInbox::Eml->new($bref);
398
399         $want->{ENVELOPE} and
400                 $self->msg_more(' ENVELOPE '.eml_envelope($eml));
401
402         for my $f ('RFC822.HEADER', 'BODY[HEADER]', 'BODY.PEEK[HEADER]') {
403                 next unless $want->{$f};
404                 $self->msg_more(" $f {".length(${$eml->{hdr}})."}\r\n");
405                 $self->msg_more(${$eml->{hdr}});
406         }
407         for my $f ('RFC822.TEXT', 'BODY[TEXT]') {
408                 next unless $want->{$f};
409                 $self->msg_more(" $f {".length($$bref)."}\r\n");
410                 $self->msg_more($$bref);
411         }
412         $want->{BODYSTRUCTURE} and
413                 $self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
414         $want->{BODY} and
415                 $self->msg_more(' BODY '.fetch_body($eml));
416         if (my $partial = $want->{-partial}) {
417                 partial_emit($self, $partial, $eml);
418         }
419         $self->msg_more(")\r\n");
420 }
421
422 sub uid_fetch_m { # long_response
423         my ($self, $tag, $ibx, $beg, $end, $msgs, $want) = @_;
424         if (!@$msgs) { # refill
425                 @$msgs = @{$ibx->over->query_xover($$beg, $end)};
426                 if (!@$msgs) {
427                         $self->write(\"$tag OK Fetch done\r\n");
428                         return;
429                 }
430                 $$beg = $msgs->[-1]->{num} + 1;
431         }
432         my $git = $ibx->git;
433         $git->cat_async_begin; # TODO: actually make async
434         $git->cat_async($msgs->[0]->{blob}, \&uid_fetch_cb, \@_);
435         $git->cat_async_wait;
436         1;
437 }
438
439 sub cmd_status ($$$;@) {
440         my ($self, $tag, $mailbox, @items) = @_;
441         my $ibx = $self->{imapd}->{groups}->{$mailbox} or
442                 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
443         return "$tag BAD no items\r\n" if !scalar(@items);
444         ($items[0] !~ s/\A\(//s || $items[-1] !~ s/\)\z//s) and
445                 return "$tag BAD invalid args\r\n";
446
447         my $mm = $ibx->mm;
448         my ($max, @it);
449         for my $it (@items) {
450                 $it = uc($it);
451                 push @it, $it;
452                 if ($it =~ /\A(?:MESSAGES|UNSEEN|RECENT)\z/) {
453                         push(@it, ($max //= $mm->max // 0));
454                 } elsif ($it eq 'UIDNEXT') {
455                         push(@it, ($max //= $mm->max // 0) + 1);
456                 } elsif ($it eq 'UIDVALIDITY') {
457                         push(@it, $mm->created_at //
458                                 return("$tag BAD UIDVALIDITY\r\n"));
459                 } else {
460                         return "$tag BAD invalid item\r\n";
461                 }
462         }
463         return "$tag BAD no items\r\n" if !@it;
464         "* STATUS $mailbox (".join(' ', @it).")\r\n" .
465         "$tag OK Status done\r\n";
466 }
467
468 my %patmap = ('*' => '.*', '%' => '[^\.]*');
469 sub cmd_list ($$$$) {
470         my ($self, $tag, $refname, $wildcard) = @_;
471         my $l = $self->{imapd}->{inboxlist};
472         if ($refname eq '' && $wildcard eq '') {
473                 # request for hierarchy delimiter
474                 $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
475         } elsif ($refname ne '' || $wildcard ne '*') {
476                 $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eig;
477                 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
478         }
479         \(join('', @$l, "$tag OK List done\r\n"));
480 }
481
482 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
483         my ($p, $all) = @_;
484         my ($eml, undef, $idx) = @$p;
485         if ($idx && lc($eml->ct->{type}) eq 'multipart') {
486                 $eml->{imap_bdy} = $eml->{bdy} // \'';
487         }
488         $all->{$idx} = $eml; # $idx => Eml
489 }
490
491 # prepares an index for BODY[$SECTION_IDX] fetches
492 sub eml_body_idx ($$) {
493         my ($eml, $section_idx) = @_;
494         my $idx = $eml->{imap_all_parts} //= do {
495                 my $all = {};
496                 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
497                 # top-level of multipart, BODY[0] not allowed (nz-number)
498                 delete $all->{0};
499                 $all;
500         };
501         $idx->{$section_idx};
502 }
503
504 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
505 sub partial_body {
506         my ($eml, $section_idx, $section_name) = @_;
507         if (defined $section_idx) {
508                 $eml = eml_body_idx($eml, $section_idx) or return;
509         }
510         if (defined $section_name) {
511                 if ($section_name eq 'MIME') {
512                         # RFC 3501 6.4.5 states:
513                         #       The MIME part specifier MUST be prefixed
514                         #       by one or more numeric part specifiers
515                         return unless defined $section_idx;
516                         return $eml->header_obj->as_string . "\r\n";
517                 }
518                 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
519                 $eml = PublicInbox::Eml->new($$bdy);
520                 if ($section_name eq 'TEXT') {
521                         return $eml->body_raw;
522                 } elsif ($section_name eq 'HEADER') {
523                         return $eml->header_obj->as_string . "\r\n";
524                 } else {
525                         die "BUG: bad section_name=$section_name";
526                 }
527         }
528         ${$eml->{bdy} // $eml->{imap_bdy} // \''};
529 }
530
531 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
532 # to avoid OOM with malicious users
533 sub hdrs_regexp ($) {
534         my ($hdrs) = @_;
535         my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
536         qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
537                 # continuation lines:
538                 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
539                 /ismx;
540 }
541
542 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
543 sub partial_hdr_not {
544         my ($eml, $section_idx, $hdrs) = @_;
545         if (defined $section_idx) {
546                 $eml = eml_body_idx($eml, $section_idx) or return;
547         }
548         my $str = $eml->header_obj->as_string;
549         my $re = hdrs_regexp($hdrs);
550         $str =~ s/$re//g;
551         $str .= "\r\n";
552 }
553
554 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
555 sub partial_hdr_get {
556         my ($eml, $section_idx, $hdrs) = @_;
557         if (defined $section_idx) {
558                 $eml = eml_body_idx($eml, $section_idx) or return;
559         }
560         my $str = $eml->header_obj->as_string;
561         my $re = hdrs_regexp($hdrs);
562         join('', ($str =~ m/($re)/g), "\r\n");
563 }
564
565 sub partial_prepare ($$$) {
566         my ($partial, $want, $att) = @_;
567
568         # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
569         # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
570         return unless $att =~ /\ABODY(?:\.PEEK)?\[/s;
571         until (rindex($att, ']') >= 0) {
572                 my $next = shift @$want or return;
573                 $att .= ' ' . uc($next);
574         }
575         if ($att =~ /\ABODY(?:\.PEEK)?\[
576                                 ([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
577                                 (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
578                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
579                 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
580         } elsif ($att =~ /\ABODY(?:\.PEEK)?\[
581                                 (?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
582                                 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
583                                 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
584                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
585                 $partial->{$att} = [ $2 ? \&partial_hdr_not
586                                         : \&partial_hdr_get,
587                                         $1, $3, $4, $5 ];
588         } else {
589                 undef;
590         }
591 }
592
593 sub partial_emit ($$$) {
594         my ($self, $partial, $eml) = @_;
595         for (@$partial) {
596                 my ($k, $cb, @args) = @$_;
597                 my ($offset, $len) = splice(@args, -2);
598                 # $cb is partial_body|partial_hdr_get|partial_hdr_not
599                 my $str = $cb->($eml, @args) // '';
600                 if (defined $offset) {
601                         if (defined $len) {
602                                 $str = substr($str, $offset, $len);
603                                 $k =~ s/\.$len>\z/>/ or warn
604 "BUG: unable to remove `.$len>' from `$k'";
605                         } else {
606                                 $str = substr($str, $offset);
607                                 $len = length($str);
608                         }
609                 } else {
610                         $len = length($str);
611                 }
612                 $self->msg_more(" $k {$len}\r\n");
613                 $self->msg_more($str);
614         }
615 }
616
617 sub fetch_common ($$$$) {
618         my ($self, $tag, $range, $want) = @_;
619         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
620         if ($want->[0] =~ s/\A\(//s) {
621                 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
622         }
623         my (%partial, %want);
624         while (defined(my $att = shift @$want)) {
625                 $att = uc($att);
626                 my $x = $FETCH_ATT{$att};
627                 if ($x) {
628                         %want = (%want, %$x);
629                 } elsif (!partial_prepare(\%partial, $want, $att)) {
630                         return "$tag BAD param: $att\r\n";
631                 }
632         }
633
634         # stabilize partial order for consistency and ease-of-debugging:
635         if (scalar keys %partial) {
636                 $want{-partial} = [ map {
637                         [ $_, @{$partial{$_}} ]
638                 } sort keys %partial ];
639         }
640
641         my ($beg, $end);
642         my $msgs = [];
643         if ($range =~ /\A([0-9]+):([0-9]+)\z/s) {
644                 ($beg, $end) = ($1, $2);
645         } elsif ($range =~ /\A([0-9]+):\*\z/s) {
646                 ($beg, $end) =  ($1, $ibx->mm->max // 0);
647         } elsif ($range =~ /\A[0-9]+\z/) {
648                 my $smsg = $ibx->over->get_art($range) or
649                         return "$tag OK Fetch done\r\n"; # really OK(!)
650                 push @$msgs, $smsg;
651                 ($beg, $end) = ($range, 0);
652         } else {
653                 return "$tag BAD fetch range\r\n";
654         }
655         [ $tag, $ibx, \$beg, $end, $msgs, \%want ];
656 }
657
658 sub cmd_uid_fetch ($$$;@) {
659         my ($self, $tag, $range, @want) = @_;
660         my $args = fetch_common($self, $tag, $range, \@want);
661         ref($args) eq 'ARRAY' ?
662                 long_response($self, \&uid_fetch_m, @$args) :
663                 $args; # error
664 }
665
666 sub seq_fetch_m { # long_response
667         my ($self, $tag, $ibx, $beg, $end, $msgs, $want) = @_;
668         if (!@$msgs) { # refill
669                 @$msgs = @{$ibx->over->query_xover($$beg, $end)};
670                 if (!@$msgs) {
671                         $self->write(\"$tag OK Fetch done\r\n");
672                         return;
673                 }
674                 $$beg = $msgs->[-1]->{num} + 1;
675         }
676         my $seq = $want->{-seqno}++;
677         my $cur_num = $msgs->[0]->{num};
678         if ($cur_num == $seq) { # as expected
679                 my $git = $ibx->git;
680                 $git->cat_async_begin; # TODO: actually make async
681                 $git->cat_async($msgs->[0]->{blob}, \&uid_fetch_cb, \@_);
682                 $git->cat_async_wait;
683         } elsif ($cur_num > $seq) {
684                 # send dummy messages until $seq catches up to $cur_num
685                 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
686                 unshift @$msgs, $smsg;
687                 my $bref = dummy_message($seq, $ibx);
688                 uid_fetch_cb($bref, undef, undef, undef, \@_);
689         } else { # should not happen
690                 die "BUG: cur_num=$cur_num < seq=$seq";
691         }
692         1; # more messages on the way
693 }
694
695 sub cmd_fetch ($$$;@) {
696         my ($self, $tag, $range, @want) = @_;
697         my $args = fetch_common($self, $tag, $range, \@want);
698         ref($args) eq 'ARRAY' ? do {
699                 my $want = $args->[-1];
700                 $want->{-seqno} = ${$args->[2]}; # $$beg
701                 long_response($self, \&seq_fetch_m, @$args)
702         } : $args; # error
703 }
704
705 sub uid_search_all { # long_response
706         my ($self, $tag, $ibx, $num) = @_;
707         my $uids = $ibx->mm->ids_after($num);
708         if (scalar(@$uids)) {
709                 $self->msg_more(join(' ', '', @$uids));
710         } else {
711                 $self->write(\"\r\n$tag OK Search done\r\n");
712                 undef;
713         }
714 }
715
716 sub uid_search_uid_range { # long_response
717         my ($self, $tag, $ibx, $beg, $end) = @_;
718         my $uids = $ibx->mm->msg_range($beg, $end, 'num');
719         if (@$uids) {
720                 $self->msg_more(join('', map { " $_->[0]" } @$uids));
721         } else {
722                 $self->write(\"\r\n$tag OK Search done\r\n");
723                 undef;
724         }
725 }
726
727 sub cmd_uid_search ($$$;) {
728         my ($self, $tag, $arg, @rest) = @_;
729         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
730         $arg = uc($arg);
731         if ($arg eq 'ALL' && !@rest) {
732                 $self->msg_more('* SEARCH');
733                 my $num = 0;
734                 long_response($self, \&uid_search_all, $tag, $ibx, \$num);
735         } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
736                 if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
737                         my ($beg, $end) = ($1, $2);
738                         $end = $ibx->mm->max if $end eq '*';
739                         $self->msg_more('* SEARCH');
740                         long_response($self, \&uid_search_uid_range,
741                                         $tag, $ibx, \$beg, $end);
742                 } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
743                         my $uid = $rest[0];
744                         $uid = $ibx->over->get_art($uid) ? " $uid" : '';
745                         "* SEARCH$uid\r\n$tag OK Search done\r\n";
746                 } else {
747                         "$tag BAD Error\r\n";
748                 }
749         } else {
750                 "$tag BAD Error\r\n";
751         }
752 }
753
754 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
755         my ($cb, $argc) = @_;
756         my $tot = prototype $cb;
757         my ($nreq, undef) = split(';', $tot);
758         $nreq = ($nreq =~ tr/$//) - 1;
759         $tot = ($tot =~ tr/$//) - 1;
760         ($argc <= $tot && $argc >= $nreq);
761 }
762
763 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
764 sub process_line ($$) {
765         my ($self, $l) = @_;
766         my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
767         pop(@args) if (@args && !defined($args[-1]));
768         if (@args && uc($req) eq 'UID') {
769                 $req .= "_".(shift @args);
770         }
771         my $res = eval {
772                 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
773                         defined($self->{-idle_tag}) ?
774                                 "$self->{-idle_tag} BAD expected DONE\r\n" :
775                                 $cmd->($self, $tag, @args);
776                 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
777                         cmd_done($self, $tag);
778                 } else { # this is weird
779                         auth_challenge_ok($self) //
780                                 "$tag BAD Error in IMAP command $req: ".
781                                 "Unknown command\r\n";
782                 }
783         };
784         my $err = $@;
785         if ($err && $self->{sock}) {
786                 $l =~ s/\r?\n//s;
787                 err($self, 'error from: %s (%s)', $l, $err);
788                 $res = "$tag BAD program fault - command not performed\r\n";
789         }
790         return 0 unless defined $res;
791         $self->write($res);
792 }
793
794 sub long_step {
795         my ($self) = @_;
796         # wbuf is unset or empty, here; {long} may add to it
797         my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
798         my $more = eval { $cb->($self, @args) };
799         if ($@ || !$self->{sock}) { # something bad happened...
800                 delete $self->{long_cb};
801                 my $elapsed = now() - $t0;
802                 if ($@) {
803                         err($self,
804                             "%s during long response[$fd] - %0.6f",
805                             $@, $elapsed);
806                 }
807                 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
808                 $self->close;
809         } elsif ($more) { # $self->{wbuf}:
810                 $self->update_idle_time;
811
812                 # COMPRESS users all share the same DEFLATE context.
813                 # Flush it here to ensure clients don't see
814                 # each other's data
815                 $self->zflush;
816
817                 # no recursion, schedule another call ASAP, but only after
818                 # all pending writes are done.  autovivify wbuf:
819                 my $new_size = push(@{$self->{wbuf}}, \&long_step);
820
821                 # wbuf may be populated by $cb, no need to rearm if so:
822                 $self->requeue if $new_size == 1;
823         } else { # all done!
824                 delete $self->{long_cb};
825                 my $elapsed = now() - $t0;
826                 my $fd = fileno($self->{sock});
827                 out($self, " deferred[$fd] done - %0.6f", $elapsed);
828                 my $wbuf = $self->{wbuf}; # do NOT autovivify
829
830                 $self->requeue unless $wbuf && @$wbuf;
831         }
832 }
833
834 sub err ($$;@) {
835         my ($self, $fmt, @args) = @_;
836         printf { $self->{imapd}->{err} } $fmt."\n", @args;
837 }
838
839 sub out ($$;@) {
840         my ($self, $fmt, @args) = @_;
841         printf { $self->{imapd}->{out} } $fmt."\n", @args;
842 }
843
844 sub long_response ($$;@) {
845         my ($self, $cb, @args) = @_; # cb returns true if more, false if done
846
847         my $sock = $self->{sock} or return;
848         # make sure we disable reading during a long response,
849         # clients should not be sending us stuff and making us do more
850         # work while we are stream a response to them
851         $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
852         long_step($self); # kick off!
853         undef;
854 }
855
856 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
857 sub event_step {
858         my ($self) = @_;
859
860         return unless $self->flush_write && $self->{sock};
861
862         $self->update_idle_time;
863         # only read more requests if we've drained the write buffer,
864         # otherwise we can be buffering infinitely w/o backpressure
865
866         my $rbuf = $self->{rbuf} // (\(my $x = ''));
867         my $r = 1;
868
869         if (index($$rbuf, "\n") < 0) {
870                 my $off = length($$rbuf);
871                 $r = $self->do_read($rbuf, LINE_MAX, $off) or return;
872         }
873         while ($r > 0 && $$rbuf =~ s/\A[ \t]*([^\n]*?)\r?\n//) {
874                 my $line = $1;
875                 return $self->close if $line =~ /[[:cntrl:]]/s;
876                 my $t0 = now();
877                 my $fd = fileno($self->{sock});
878                 $r = eval { process_line($self, $line) };
879                 my $pending = $self->{wbuf} ? ' pending' : '';
880                 out($self, "[$fd] %s - %0.6f$pending", $line, now() - $t0);
881         }
882
883         return $self->close if $r < 0;
884         my $len = length($$rbuf);
885         return $self->close if ($len >= LINE_MAX);
886         $self->rbuf_idle($rbuf);
887         $self->update_idle_time;
888
889         # maybe there's more pipelined data, or we'll have
890         # to register it for socket-readiness notifications
891         $self->requeue unless $self->{wbuf};
892 }
893
894 sub compressed { undef }
895
896 sub zflush {} # overridden by IMAPdeflate
897
898 # RFC 4978
899 sub cmd_compress ($$$) {
900         my ($self, $tag, $alg) = @_;
901         return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
902         return "$tag BAD COMPRESS active\r\n" if $self->compressed;
903
904         # CRIME made TLS compression obsolete
905         # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
906
907         PublicInbox::IMAPdeflate->enable($self, $tag);
908         $self->requeue;
909         undef
910 }
911
912 sub cmd_starttls ($$) {
913         my ($self, $tag) = @_;
914         my $sock = $self->{sock} or return;
915         if ($sock->can('stop_SSL') || $self->compressed) {
916                 return "$tag BAD TLS or compression already enabled\r\n";
917         }
918         my $opt = $self->{imapd}->{accept_tls} or
919                 return "$tag BAD can not initiate TLS negotiation\r\n";
920         $self->write(\"$tag OK begin TLS negotiation now\r\n");
921         $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
922         $self->requeue if PublicInbox::DS::accept_tls_step($self);
923         undef;
924 }
925
926 # for graceful shutdown in PublicInbox::Daemon:
927 sub busy {
928         my ($self, $now) = @_;
929         ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
930 }
931
932 sub close {
933         my ($self) = @_;
934         if (my $ibx = delete $self->{ibx}) {
935                 if (my $sock = $self->{sock}) {;
936                         $ibx->unsubscribe_unlock(fileno($sock));
937                 }
938         }
939         $self->SUPER::close; # PublicInbox::DS::close
940 }
941
942 # we're read-only, so SELECT and EXAMINE do the same thing
943 no warnings 'once';
944 *cmd_select = \&cmd_examine;
945
946 1;