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_cat
 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
 404         $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
 405
 406         # fixup old bug from import (pre-a0c07cba0e5d8b6a)
 407         $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
 408
 409         $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
 410
 411         $want->{'RFC822.SIZE'} and
 412                 $self->msg_more(' RFC822.SIZE '.length($$bref));
 413         $want->{INTERNALDATE} and
 414                 $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
 415         $want->{FLAGS} and $self->msg_more(' FLAGS ()');
 416         for ('RFC822', 'BODY[]') {
 417                 $want->{$_} or next;
 418                 $self->msg_more(" $_ {".length($$bref)."}\r\n");
 419                 $self->msg_more($$bref);
 420         }
 421
 422         my $eml = PublicInbox::Eml->new($bref);
 423
 424         $want->{ENVELOPE} and
 425                 $self->msg_more(' ENVELOPE '.eml_envelope($eml));
 426
 427         for ('RFC822.HEADER', 'BODY[HEADER]') {
 428                 $want->{$_} or next;
 429                 $self->msg_more(" $_ {".length(${$eml->{hdr}})."}\r\n");
 430                 $self->msg_more(${$eml->{hdr}});
 431         }
 432         for ('RFC822.TEXT', 'BODY[TEXT]') {
 433                 $want->{$_} or next;
 434                 $self->msg_more(" $_ {".length($$bref)."}\r\n");
 435                 $self->msg_more($$bref);
 436         }
 437         $want->{BODYSTRUCTURE} and
 438                 $self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
 439         $want->{BODY} and
 440                 $self->msg_more(' BODY '.fetch_body($eml));
 441         if (my $partial = $want->{-partial}) {
 442                 partial_emit($self, $partial, $eml);
 443         }
 444         $self->msg_more(")\r\n");
 445         requeue_once($self);
 446 }
 447
 448 sub range_step ($$) {
 449         my ($ibx, $range_csv) = @_;
 450         my ($beg, $end, $range);
 451         if ($$range_csv =~ s/\A([^,]+),//) {
 452                 $range = $1;
 453         } else {
 454                 $range = $$range_csv;
 455                 $$range_csv = undef;
 456         }
 457         if ($range =~ /\A([0-9]+):([0-9]+)\z/) {
 458                 ($beg, $end) = ($1, $2);
 459         } elsif ($range =~ /\A([0-9]+):\*\z/) {
 460                 ($beg, $end) =  ($1, $ibx->mm->max // 0);
 461         } elsif ($range =~ /\A[0-9]+\z/) {
 462                 $beg = $end = $range;
 463         } else {
 464                 return 'BAD fetch range';
 465         }
 466         [ $beg, $end, $$range_csv ];
 467 }
 468
 469 sub refill_range ($$$) {
 470         my ($ibx, $msgs, $range_info) = @_;
 471         my ($beg, $end, $range_csv) = @$range_info;
 472         if (scalar(@$msgs = @{$ibx->over->query_xover($beg, $end)})) {
 473                 $range_info->[0] = $msgs->[-1]->{num} + 1;
 474                 return;
 475         }
 476         return 'OK Fetch done' if !$range_csv;
 477         my $next_range = range_step($ibx, \$range_csv);
 478         return $next_range if !ref($next_range); # error
 479         @$range_info = @$next_range;
 480         undef; # keep looping
 481 }
 482
 483 sub uid_fetch_m { # long_response
 484         my ($self, $tag, $ibx, $msgs, $range_info, $want) = @_;
 485         while (!@$msgs) { # rare
 486                 if (my $end = refill_range($ibx, $msgs, $range_info)) {
 487                         $self->write(\"$tag $end\r\n");
 488                         return;
 489                 }
 490         }
 491         git_async_cat($ibx->git, $msgs->[0]->{blob}, \&uid_fetch_cb, \@_);
 492 }
 493
 494 sub cmd_status ($$$;@) {
 495         my ($self, $tag, $mailbox, @items) = @_;
 496         my $ibx = $self->{imapd}->{groups}->{$mailbox} or
 497                 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
 498         return "$tag BAD no items\r\n" if !scalar(@items);
 499         ($items[0] !~ s/\A\(//s || $items[-1] !~ s/\)\z//s) and
 500                 return "$tag BAD invalid args\r\n";
 501
 502         my $mm = $ibx->mm;
 503         my ($max, @it);
 504         for my $it (@items) {
 505                 $it = uc($it);
 506                 push @it, $it;
 507                 if ($it =~ /\A(?:MESSAGES|UNSEEN|RECENT)\z/) {
 508                         push(@it, ($max //= $mm->max // 0));
 509                 } elsif ($it eq 'UIDNEXT') {
 510                         push(@it, ($max //= $mm->max // 0) + 1);
 511                 } elsif ($it eq 'UIDVALIDITY') {
 512                         push(@it, $mm->created_at //
 513                                 return("$tag BAD UIDVALIDITY\r\n"));
 514                 } else {
 515                         return "$tag BAD invalid item\r\n";
 516                 }
 517         }
 518         return "$tag BAD no items\r\n" if !@it;
 519         "* STATUS $mailbox (".join(' ', @it).")\r\n" .
 520         "$tag OK Status done\r\n";
 521 }
 522
 523 my %patmap = ('*' => '.*', '%' => '[^\.]*');
 524 sub cmd_list ($$$$) {
 525         my ($self, $tag, $refname, $wildcard) = @_;
 526         my $l = $self->{imapd}->{inboxlist};
 527         if ($refname eq '' && $wildcard eq '') {
 528                 # request for hierarchy delimiter
 529                 $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
 530         } elsif ($refname ne '' || $wildcard ne '*') {
 531                 $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eig;
 532                 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
 533         }
 534         \(join('', @$l, "$tag OK List done\r\n"));
 535 }
 536
 537 sub cmd_lsub ($$$$) {
 538         my (undef, $tag) = @_; # same args as cmd_list
 539         "$tag OK Lsub done\r\n";
 540 }
 541
 542 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
 543         my ($p, $all) = @_;
 544         my ($eml, undef, $idx) = @$p;
 545         if ($idx && lc($eml->ct->{type}) eq 'multipart') {
 546                 $eml->{imap_bdy} = $eml->{bdy} // \'';
 547         }
 548         $all->{$idx} = $eml; # $idx => Eml
 549 }
 550
 551 # prepares an index for BODY[$SECTION_IDX] fetches
 552 sub eml_body_idx ($$) {
 553         my ($eml, $section_idx) = @_;
 554         my $idx = $eml->{imap_all_parts} //= do {
 555                 my $all = {};
 556                 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
 557                 # top-level of multipart, BODY[0] not allowed (nz-number)
 558                 delete $all->{0};
 559                 $all;
 560         };
 561         $idx->{$section_idx};
 562 }
 563
 564 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
 565 sub partial_body {
 566         my ($eml, $section_idx, $section_name) = @_;
 567         if (defined $section_idx) {
 568                 $eml = eml_body_idx($eml, $section_idx) or return;
 569         }
 570         if (defined $section_name) {
 571                 if ($section_name eq 'MIME') {
 572                         # RFC 3501 6.4.5 states:
 573                         #       The MIME part specifier MUST be prefixed
 574                         #       by one or more numeric part specifiers
 575                         return unless defined $section_idx;
 576                         return $eml->header_obj->as_string . "\r\n";
 577                 }
 578                 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
 579                 $eml = PublicInbox::Eml->new($$bdy);
 580                 if ($section_name eq 'TEXT') {
 581                         return $eml->body_raw;
 582                 } elsif ($section_name eq 'HEADER') {
 583                         return $eml->header_obj->as_string . "\r\n";
 584                 } else {
 585                         die "BUG: bad section_name=$section_name";
 586                 }
 587         }
 588         ${$eml->{bdy} // $eml->{imap_bdy} // \''};
 589 }
 590
 591 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
 592 # to avoid OOM with malicious users
 593 sub hdrs_regexp ($) {
 594         my ($hdrs) = @_;
 595         my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
 596         qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
 597                 # continuation lines:
 598                 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
 599                 /ismx;
 600 }
 601
 602 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
 603 sub partial_hdr_not {
 604         my ($eml, $section_idx, $hdrs_re) = @_;
 605         if (defined $section_idx) {
 606                 $eml = eml_body_idx($eml, $section_idx) or return;
 607         }
 608         my $str = $eml->header_obj->as_string;
 609         $str =~ s/$hdrs_re//g;
 610         $str .= "\r\n";
 611 }
 612
 613 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
 614 sub partial_hdr_get {
 615         my ($eml, $section_idx, $hdrs_re) = @_;
 616         if (defined $section_idx) {
 617                 $eml = eml_body_idx($eml, $section_idx) or return;
 618         }
 619         my $str = $eml->header_obj->as_string;
 620         join('', ($str =~ m/($hdrs_re)/g), "\r\n");
 621 }
 622
 623 sub partial_prepare ($$$) {
 624         my ($partial, $want, $att) = @_;
 625
 626         # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
 627         # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
 628         return unless $att =~ /\ABODY\[/s;
 629         until (rindex($att, ']') >= 0) {
 630                 my $next = shift @$want or return;
 631                 $att .= ' ' . uc($next);
 632         }
 633         if ($att =~ /\ABODY\[([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
 634                         (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
 635                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
 636                 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
 637         } elsif ($att =~ /\ABODY\[(?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
 638                                 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
 639                                 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
 640                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
 641                 my $tmp = $partial->{$att} = [ $2 ? \&partial_hdr_not
 642                                                 : \&partial_hdr_get,
 643                                                 $1, undef, $4, $5 ];
 644                 $tmp->[2] = hdrs_regexp($3);
 645         } else {
 646                 undef;
 647         }
 648 }
 649
 650 sub partial_emit ($$$) {
 651         my ($self, $partial, $eml) = @_;
 652         for (@$partial) {
 653                 my ($k, $cb, @args) = @$_;
 654                 my ($offset, $len) = splice(@args, -2);
 655                 # $cb is partial_body|partial_hdr_get|partial_hdr_not
 656                 my $str = $cb->($eml, @args) // '';
 657                 if (defined $offset) {
 658                         if (defined $len) {
 659                                 $str = substr($str, $offset, $len);
 660                                 $k =~ s/\.$len>\z/>/ or warn
 661 "BUG: unable to remove `.$len>' from `$k'";
 662                         } else {
 663                                 $str = substr($str, $offset);
 664                                 $len = length($str);
 665                         }
 666                 } else {
 667                         $len = length($str);
 668                 }
 669                 $self->msg_more(" $k {$len}\r\n");
 670                 $self->msg_more($str);
 671         }
 672 }
 673
 674 sub fetch_common ($$$$) {
 675         my ($self, $tag, $range_csv, $want) = @_;
 676         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
 677         if ($want->[0] =~ s/\A\(//s) {
 678                 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
 679         }
 680         my (%partial, %want);
 681         while (defined(my $att = shift @$want)) {
 682                 $att = uc($att);
 683                 $att =~ s/\ABODY\.PEEK\[/BODY\[/; # we're read-only
 684                 my $x = $FETCH_ATT{$att};
 685                 if ($x) {
 686                         %want = (%want, %$x);
 687                 } elsif (!partial_prepare(\%partial, $want, $att)) {
 688                         return "$tag BAD param: $att\r\n";
 689                 }
 690         }
 691
 692         # stabilize partial order for consistency and ease-of-debugging:
 693         if (scalar keys %partial) {
 694                 $want{-partial} = [ map {;
 695                         [ $_, @{$partial{$_}} ]
 696                 } sort keys %partial ];
 697         }
 698         $range_csv = 'bad' if $range_csv !~ $valid_range;
 699         my $range_info = range_step($ibx, \$range_csv);
 700         return "$tag $range_info\r\n" if !ref($range_info);
 701         [ $tag, $ibx, [], $range_info, \%want ];
 702 }
 703
 704 sub cmd_uid_fetch ($$$;@) {
 705         my ($self, $tag, $range_csv, @want) = @_;
 706         my $args = fetch_common($self, $tag, $range_csv, \@want);
 707         ref($args) eq 'ARRAY' ?
 708                 long_response($self, \&uid_fetch_m, @$args) :
 709                 $args; # error
 710 }
 711
 712 sub seq_fetch_m { # long_response
 713         my ($self, $tag, $ibx, $msgs, $range_info, $want) = @_;
 714         while (!@$msgs) { # rare
 715                 if (my $end = refill_range($ibx, $msgs, $range_info)) {
 716                         $self->write(\"$tag $end\r\n");
 717                         return;
 718                 }
 719         }
 720         my $seq = $want->{-seqno}++;
 721         my $cur_num = $msgs->[0]->{num};
 722         if ($cur_num == $seq) { # as expected
 723                 git_async_cat($ibx->git, $msgs->[0]->{blob},
 724                                 \&uid_fetch_cb, \@_);
 725         } elsif ($cur_num > $seq) {
 726                 # send dummy messages until $seq catches up to $cur_num
 727                 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
 728                 unshift @$msgs, $smsg;
 729                 my $bref = dummy_message($seq, $ibx);
 730                 uid_fetch_cb($bref, undef, undef, undef, \@_);
 731                 $smsg; # blessed response since uid_fetch_cb requeues
 732         } else { # should not happen
 733                 die "BUG: cur_num=$cur_num < seq=$seq";
 734         }
 735 }
 736
 737 sub cmd_fetch ($$$;@) {
 738         my ($self, $tag, $range_csv, @want) = @_;
 739         my $args = fetch_common($self, $tag, $range_csv, \@want);
 740         ref($args) eq 'ARRAY' ? do {
 741                 my $want = $args->[-1];
 742                 $want->{-seqno} = $args->[3]->[0]; # $beg == $range_info->[0];
 743                 long_response($self, \&seq_fetch_m, @$args)
 744         } : $args; # error
 745 }
 746
 747 sub uid_search_all { # long_response
 748         my ($self, $tag, $ibx, $num) = @_;
 749         my $uids = $ibx->mm->ids_after($num);
 750         if (scalar(@$uids)) {
 751                 $self->msg_more(join(' ', '', @$uids));
 752         } else {
 753                 $self->write(\"\r\n$tag OK Search done\r\n");
 754                 undef;
 755         }
 756 }
 757
 758 sub uid_search_uid_range { # long_response
 759         my ($self, $tag, $ibx, $beg, $end) = @_;
 760         my $uids = $ibx->mm->msg_range($beg, $end, 'num');
 761         if (@$uids) {
 762                 $self->msg_more(join('', map { " $_->[0]" } @$uids));
 763         } else {
 764                 $self->write(\"\r\n$tag OK Search done\r\n");
 765                 undef;
 766         }
 767 }
 768
 769 sub cmd_uid_search ($$$;) {
 770         my ($self, $tag, $arg, @rest) = @_;
 771         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
 772         $arg = uc($arg);
 773         if ($arg eq 'ALL' && !@rest) {
 774                 $self->msg_more('* SEARCH');
 775                 my $num = 0;
 776                 long_response($self, \&uid_search_all, $tag, $ibx, \$num);
 777         } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
 778                 if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
 779                         my ($beg, $end) = ($1, $2);
 780                         $end = $ibx->mm->max if $end eq '*';
 781                         $self->msg_more('* SEARCH');
 782                         long_response($self, \&uid_search_uid_range,
 783                                         $tag, $ibx, \$beg, $end);
 784                 } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
 785                         my $uid = $rest[0];
 786                         $uid = $ibx->over->get_art($uid) ? " $uid" : '';
 787                         "* SEARCH$uid\r\n$tag OK Search done\r\n";
 788                 } else {
 789                         "$tag BAD Error\r\n";
 790                 }
 791         } else {
 792                 "$tag BAD Error\r\n";
 793         }
 794 }
 795
 796 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
 797         my ($cb, $argc) = @_;
 798         my $tot = prototype $cb;
 799         my ($nreq, undef) = split(';', $tot);
 800         $nreq = ($nreq =~ tr/$//) - 1;
 801         $tot = ($tot =~ tr/$//) - 1;
 802         ($argc <= $tot && $argc >= $nreq);
 803 }
 804
 805 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
 806 sub process_line ($$) {
 807         my ($self, $l) = @_;
 808         my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
 809         pop(@args) if (@args && !defined($args[-1]));
 810         if (@args && uc($req) eq 'UID') {
 811                 $req .= "_".(shift @args);
 812         }
 813         my $res = eval {
 814                 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
 815                         defined($self->{-idle_tag}) ?
 816                                 "$self->{-idle_tag} BAD expected DONE\r\n" :
 817                                 $cmd->($self, $tag, @args);
 818                 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
 819                         cmd_done($self, $tag);
 820                 } else { # this is weird
 821                         auth_challenge_ok($self) //
 822                                 "$tag BAD Error in IMAP command $req: ".
 823                                 "Unknown command\r\n";
 824                 }
 825         };
 826         my $err = $@;
 827         if ($err && $self->{sock}) {
 828                 $l =~ s/\r?\n//s;
 829                 err($self, 'error from: %s (%s)', $l, $err);
 830                 $res = "$tag BAD program fault - command not performed\r\n";
 831         }
 832         return 0 unless defined $res;
 833         $self->write($res);
 834 }
 835
 836 sub long_step {
 837         my ($self) = @_;
 838         # wbuf is unset or empty, here; {long} may add to it
 839         my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
 840         my $more = eval { $cb->($self, @args) };
 841         if ($@ || !$self->{sock}) { # something bad happened...
 842                 delete $self->{long_cb};
 843                 my $elapsed = now() - $t0;
 844                 if ($@) {
 845                         err($self,
 846                             "%s during long response[$fd] - %0.6f",
 847                             $@, $elapsed);
 848                 }
 849                 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
 850                 $self->close;
 851         } elsif ($more) { # $self->{wbuf}:
 852                 $self->update_idle_time;
 853
 854                 # control passed to $more may be a GitAsyncCat object
 855                 requeue_once($self) if !ref($more);
 856         } else { # all done!
 857                 delete $self->{long_cb};
 858                 my $elapsed = now() - $t0;
 859                 my $fd = fileno($self->{sock});
 860                 out($self, " deferred[$fd] done - %0.6f", $elapsed);
 861                 my $wbuf = $self->{wbuf}; # do NOT autovivify
 862
 863                 $self->requeue unless $wbuf && @$wbuf;
 864         }
 865 }
 866
 867 sub err ($$;@) {
 868         my ($self, $fmt, @args) = @_;
 869         printf { $self->{imapd}->{err} } $fmt."\n", @args;
 870 }
 871
 872 sub out ($$;@) {
 873         my ($self, $fmt, @args) = @_;
 874         printf { $self->{imapd}->{out} } $fmt."\n", @args;
 875 }
 876
 877 sub long_response ($$;@) {
 878         my ($self, $cb, @args) = @_; # cb returns true if more, false if done
 879
 880         my $sock = $self->{sock} or return;
 881         # make sure we disable reading during a long response,
 882         # clients should not be sending us stuff and making us do more
 883         # work while we are stream a response to them
 884         $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
 885         long_step($self); # kick off!
 886         undef;
 887 }
 888
 889 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
 890 sub event_step {
 891         my ($self) = @_;
 892
 893         return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
 894
 895         $self->update_idle_time;
 896         # only read more requests if we've drained the write buffer,
 897         # otherwise we can be buffering infinitely w/o backpressure
 898
 899         my $rbuf = $self->{rbuf} // \(my $x = '');
 900         my $line = index($$rbuf, "\n");
 901         while ($line < 0) {
 902                 return $self->close if length($$rbuf) >= LINE_MAX;
 903                 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or return;
 904                 $line = index($$rbuf, "\n");
 905         }
 906         $line = substr($$rbuf, 0, $line + 1, '');
 907         $line =~ s/\r?\n\z//s;
 908         return $self->close if $line =~ /[[:cntrl:]]/s;
 909         my $t0 = now();
 910         my $fd = fileno($self->{sock});
 911         my $r = eval { process_line($self, $line) };
 912         my $pending = $self->{wbuf} ? ' pending' : '';
 913         out($self, "[$fd] %s - %0.6f$pending - $r", $line, now() - $t0);
 914
 915         return $self->close if $r < 0;
 916         $self->rbuf_idle($rbuf);
 917         $self->update_idle_time;
 918
 919         # maybe there's more pipelined data, or we'll have
 920         # to register it for socket-readiness notifications
 921         $self->requeue unless $pending;
 922 }
 923
 924 sub compressed { undef }
 925
 926 sub zflush {} # overridden by IMAPdeflate
 927
 928 # RFC 4978
 929 sub cmd_compress ($$$) {
 930         my ($self, $tag, $alg) = @_;
 931         return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
 932         return "$tag BAD COMPRESS active\r\n" if $self->compressed;
 933
 934         # CRIME made TLS compression obsolete
 935         # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
 936
 937         PublicInbox::IMAPdeflate->enable($self, $tag);
 938         $self->requeue;
 939         undef
 940 }
 941
 942 sub cmd_starttls ($$) {
 943         my ($self, $tag) = @_;
 944         my $sock = $self->{sock} or return;
 945         if ($sock->can('stop_SSL') || $self->compressed) {
 946                 return "$tag BAD TLS or compression already enabled\r\n";
 947         }
 948         my $opt = $self->{imapd}->{accept_tls} or
 949                 return "$tag BAD can not initiate TLS negotiation\r\n";
 950         $self->write(\"$tag OK begin TLS negotiation now\r\n");
 951         $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
 952         $self->requeue if PublicInbox::DS::accept_tls_step($self);
 953         undef;
 954 }
 955
 956 # for graceful shutdown in PublicInbox::Daemon:
 957 sub busy {
 958         my ($self, $now) = @_;
 959         ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
 960 }
 961
 962 sub close {
 963         my ($self) = @_;
 964         if (my $ibx = delete $self->{ibx}) {
 965                 if (my $sock = $self->{sock}) {;
 966                         $ibx->unsubscribe_unlock(fileno($sock));
 967                 }
 968         }
 969         $self->SUPER::close; # PublicInbox::DS::close
 970 }
 971
 972 # we're read-only, so SELECT and EXAMINE do the same thing
 973 no warnings 'once';
 974 *cmd_select = \&cmd_examine;
 975
 976 1;