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