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