lib/PublicInbox/IMAP.pm

   1 # Copyright (C) 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 #
  11 # * NNTP article numbers are UIDs, mm->created_at is UIDVALIDITY
  12 #
  13 # * public-inboxes are sliced into mailboxes of 50K messages
  14 #   to not overload MUAs: $NEWSGROUP_NAME.$SLICE_INDEX
  15 #   Slices are similar in concept to v2 "epochs".  Epochs
  16 #   are for the limitations of git clients, while slices are
  17 #   for the limitations of IMAP clients.
  18 #
  19 # * We also take advantage of slices being only 50K to store
  20 #   "UID offset" to message sequence number (MSN) mapping
  21 #   as a 50K uint16_t array (via pack("S*", ...)).  "UID offset"
  22 #   is the offset from {uid_base} which determines the start of
  23 #   the mailbox slice.
  24 #
  25 # fields:
  26 # imapd: PublicInbox::IMAPD ref
  27 # ibx: PublicInbox::Inbox ref
  28 # long_cb: long_response private data
  29 # uid_base: base UID for mailbox slice (0-based)
  30 # -login_tag: IMAP TAG for LOGIN
  31 # -idle_tag: IMAP response tag for IDLE
  32 # uo2m: UID-to-MSN mapping
  33 package PublicInbox::IMAP;
  34 use strict;
  35 use parent qw(PublicInbox::DS);
  36 use PublicInbox::Eml;
  37 use PublicInbox::EmlContentFoo qw(parse_content_disposition);
  38 use PublicInbox::DS qw(now);
  39 use PublicInbox::GitAsyncCat;
  40 use Text::ParseWords qw(parse_line);
  41 use Errno qw(EAGAIN);
  42 use PublicInbox::IMAPsearchqp;
  43
  44 my $Address;
  45 for my $mod (qw(Email::Address::XS Mail::Address)) {
  46         eval "require $mod" or next;
  47         $Address = $mod and last;
  48 }
  49 die "neither Email::Address::XS nor Mail::Address loaded: $@" if !$Address;
  50
  51 sub LINE_MAX () { 8000 } # RFC 2683 3.2.1.5
  52
  53 # Changing UID_SLICE will cause grief for clients which cache.
  54 # This also needs to be <64K: we pack it into a uint16_t
  55 # for long_response UID (offset) => MSN mappings
  56 sub UID_SLICE () { 50_000 }
  57
  58 # these values area also used for sorting
  59 sub NEED_SMSG () { 1 }
  60 sub NEED_BLOB () { NEED_SMSG|2 }
  61 sub CRLF_BREF () { 4 }
  62 sub EML_HDR () { 8 }
  63 sub CRLF_HDR () { 16 }
  64 sub EML_BDY () { 32 }
  65 sub CRLF_BDY () { 64 }
  66 my $OP_EML_NEW = [ EML_HDR - 1, \&op_eml_new ];
  67 my $OP_CRLF_BREF = [ CRLF_BREF, \&op_crlf_bref ];
  68 my $OP_CRLF_HDR = [ CRLF_HDR, \&op_crlf_hdr ];
  69 my $OP_CRLF_BDY = [ CRLF_BDY, \&op_crlf_bdy ];
  70
  71 my %FETCH_NEED = (
  72         'BODY[HEADER]' => [ NEED_BLOB|EML_HDR|CRLF_HDR, \&emit_rfc822_header ],
  73         'BODY[TEXT]' => [ NEED_BLOB|EML_BDY|CRLF_BDY, \&emit_rfc822_text ],
  74         'BODY[]' => [ NEED_BLOB|CRLF_BREF, \&emit_rfc822 ],
  75         'RFC822.HEADER' => [ NEED_BLOB|EML_HDR|CRLF_HDR, \&emit_rfc822_header ],
  76         'RFC822.TEXT' => [ NEED_BLOB|EML_BDY|CRLF_BDY, \&emit_rfc822_text ],
  77         'RFC822.SIZE' => [ NEED_SMSG, \&emit_rfc822_size ],
  78         RFC822 => [ NEED_BLOB|CRLF_BREF, \&emit_rfc822 ],
  79         BODY => [ NEED_BLOB|EML_HDR|EML_BDY, \&emit_body ],
  80         BODYSTRUCTURE => [ NEED_BLOB|EML_HDR|EML_BDY, \&emit_bodystructure ],
  81         ENVELOPE => [ NEED_BLOB|EML_HDR, \&emit_envelope ],
  82         FLAGS => [ 0, \&emit_flags ],
  83         INTERNALDATE => [ NEED_SMSG, \&emit_internaldate ],
  84 );
  85 my %FETCH_ATT = map { $_ => [ $_ ] } keys %FETCH_NEED;
  86
  87 # aliases (RFC 3501 section 6.4.5)
  88 $FETCH_ATT{FAST} = [ qw(FLAGS INTERNALDATE RFC822.SIZE) ];
  89 $FETCH_ATT{ALL} = [ @{$FETCH_ATT{FAST}}, 'ENVELOPE' ];
  90 $FETCH_ATT{FULL} = [ @{$FETCH_ATT{ALL}}, 'BODY' ];
  91
  92 for my $att (keys %FETCH_ATT) {
  93         my %h = map { $_ => $FETCH_NEED{$_} } @{$FETCH_ATT{$att}};
  94         $FETCH_ATT{$att} = \%h;
  95 }
  96 undef %FETCH_NEED;
  97
  98 my $valid_range = '[0-9]+|[0-9]+:[0-9]+|[0-9]+:\*';
  99 $valid_range = qr/\A(?:$valid_range)(?:,(?:$valid_range))*\z/;
 100
 101 sub do_greet {
 102         my ($self) = @_;
 103         my $capa = capa($self);
 104         $self->write(\"* OK [$capa] public-inbox-imapd ready\r\n");
 105 }
 106
 107 sub new {
 108         my (undef, $sock, $imapd) = @_;
 109         (bless { imapd => $imapd }, 'PublicInbox::IMAP_preauth')->greet($sock)
 110 }
 111
 112 sub logged_in { 1 }
 113
 114 sub capa ($) {
 115         my ($self) = @_;
 116
 117         # dovecot advertises IDLE pre-login; perhaps because some clients
 118         # depend on it, so we'll do the same
 119         my $capa = 'CAPABILITY IMAP4rev1 IDLE';
 120         if ($self->logged_in) {
 121                 $capa .= ' COMPRESS=DEFLATE';
 122         } else {
 123                 if (!($self->{sock} // $self)->can('accept_SSL') &&
 124                         $self->{imapd}->{ssl_ctx_opt}) {
 125                         $capa .= ' STARTTLS';
 126                 }
 127                 $capa .= ' AUTH=ANONYMOUS';
 128         }
 129 }
 130
 131 sub login_success ($$) {
 132         my ($self, $tag) = @_;
 133         bless $self, 'PublicInbox::IMAP';
 134         my $capa = capa($self);
 135         "$tag OK [$capa] Logged in\r\n";
 136 }
 137
 138 sub auth_challenge_ok ($) {
 139         my ($self) = @_;
 140         my $tag = delete($self->{-login_tag}) or return;
 141         $self->{anon} = 1;
 142         login_success($self, $tag);
 143 }
 144
 145 sub cmd_login ($$$$) {
 146         my ($self, $tag) = @_; # ignore ($user, $password) = ($_[2], $_[3])
 147         login_success($self, $tag);
 148 }
 149
 150 sub cmd_close ($$) {
 151         my ($self, $tag) = @_;
 152         delete @$self{qw(uid_base uo2m)};
 153         delete $self->{ibx} ? "$tag OK Close done\r\n"
 154                                 : "$tag BAD No mailbox\r\n";
 155 }
 156
 157 sub cmd_logout ($$) {
 158         my ($self, $tag) = @_;
 159         delete $self->{-idle_tag};
 160         $self->write(\"* BYE logging out\r\n$tag OK Logout done\r\n");
 161         $self->shutdn; # PublicInbox::DS::shutdn
 162         undef;
 163 }
 164
 165 sub cmd_authenticate ($$$) {
 166         my ($self, $tag) = @_; # $method = $_[2], should be "ANONYMOUS"
 167         $self->{-login_tag} = $tag;
 168         "+\r\n"; # challenge
 169 }
 170
 171 sub cmd_capability ($$) {
 172         my ($self, $tag) = @_;
 173         '* '.capa($self)."\r\n$tag OK Capability done\r\n";
 174 }
 175
 176 # uo2m: UID Offset to MSN, this is an arrayref by default,
 177 # but uo2m_hibernate can compact and deduplicate it
 178 sub uo2m_ary_new ($;$) {
 179         my ($self, $exists) = @_;
 180         my $ub = $self->{uid_base};
 181         my $uids = $self->{ibx}->over(1)->uid_range($ub + 1, $ub + UID_SLICE);
 182
 183         # convert UIDs to offsets from {base}
 184         my @tmp; # [$UID_OFFSET] => $MSN
 185         my $msn = 0;
 186         ++$ub;
 187         $tmp[$_ - $ub] = ++$msn for @$uids;
 188         $$exists = $msn if $exists;
 189         \@tmp;
 190 }
 191
 192 # changes UID-offset-to-MSN mapping into a deduplicated scalar:
 193 # uint16_t uo2m[UID_SLICE].
 194 # May be swapped out for idle clients if THP is disabled.
 195 sub uo2m_hibernate ($) {
 196         my ($self) = @_;
 197         ref(my $uo2m = $self->{uo2m}) or return;
 198         my %dedupe = ( uo2m_pack($uo2m) => undef );
 199         $self->{uo2m} = (keys(%dedupe))[0];
 200         undef;
 201 }
 202
 203 sub uo2m_last_uid ($) {
 204         my ($self) = @_;
 205         defined(my $uo2m = $self->{uo2m}) or die 'BUG: uo2m_last_uid w/o {uo2m}';
 206         (ref($uo2m) ? @$uo2m : (length($uo2m) >> 1)) + $self->{uid_base};
 207 }
 208
 209 sub uo2m_pack ($) {
 210         # $_[0] is an arrayref of MSNs, it may have undef gaps if there
 211         # are gaps in the corresponding UIDs: [ msn1, msn2, undef, msn3 ]
 212         no warnings 'uninitialized';
 213         pack('S*', @{$_[0]});
 214 }
 215
 216 # extend {uo2m} to account for new messages which arrived since
 217 # {uo2m} was created.
 218 sub uo2m_extend ($$;$) {
 219         my ($self, $new_uid_max) = @_;
 220         defined(my $uo2m = $self->{uo2m}) or
 221                 return($self->{uo2m} = uo2m_ary_new($self));
 222         my $beg = uo2m_last_uid($self); # last UID we've learned
 223         return $uo2m if $beg >= $new_uid_max; # fast path
 224
 225         # need to extend the current range:
 226         my $base = $self->{uid_base};
 227         ++$beg;
 228         my $uids = $self->{ibx}->over(1)->uid_range($beg, $base + UID_SLICE);
 229         return $uo2m if !scalar(@$uids);
 230         my @tmp; # [$UID_OFFSET] => $MSN
 231         my $write_method = $_[2] // 'msg_more';
 232         if (ref($uo2m)) {
 233                 my $msn = $uo2m->[-1];
 234                 $tmp[$_ - $beg] = ++$msn for @$uids;
 235                 $self->$write_method("* $msn EXISTS\r\n");
 236                 push @$uo2m, @tmp;
 237                 $uo2m;
 238         } else {
 239                 my $msn = unpack('S', substr($uo2m, -2, 2));
 240                 $tmp[$_ - $beg] = ++$msn for @$uids;
 241                 $self->$write_method("* $msn EXISTS\r\n");
 242                 $uo2m .= uo2m_pack(\@tmp);
 243                 my %dedupe = ($uo2m => undef);
 244                 $self->{uo2m} = (keys %dedupe)[0];
 245         }
 246 }
 247
 248 sub cmd_noop ($$) {
 249         my ($self, $tag) = @_;
 250         defined($self->{uid_base}) and
 251                 uo2m_extend($self, $self->{uid_base} + UID_SLICE);
 252         \"$tag OK Noop done\r\n";
 253 }
 254
 255 # the flexible version which works on scalars and array refs.
 256 # Must call uo2m_extend before this
 257 sub uid2msn ($$) {
 258         my ($self, $uid) = @_;
 259         my $uo2m = $self->{uo2m};
 260         my $off = $uid - $self->{uid_base} - 1;
 261         ref($uo2m) ? $uo2m->[$off] : unpack('S', substr($uo2m, $off << 1, 2));
 262 }
 263
 264 # returns an arrayref of UIDs, so MSNs can be translated to UIDs via:
 265 # $msn2uid->[$MSN-1] => $UID.  The result of this is always ephemeral
 266 # and does not live beyond the event loop.
 267 sub msn2uid ($) {
 268         my ($self) = @_;
 269         my $base = $self->{uid_base};
 270         my $uo2m = uo2m_extend($self, $base + UID_SLICE);
 271         $uo2m = [ unpack('S*', $uo2m) ] if !ref($uo2m);
 272
 273         my $uo = 0;
 274         my @msn2uid;
 275         for my $msn (@$uo2m) {
 276                 ++$uo;
 277                 $msn2uid[$msn - 1] = $uo + $base if $msn;
 278         }
 279         \@msn2uid;
 280 }
 281
 282 # converts a set of message sequence numbers in requests to UIDs:
 283 sub msn_to_uid_range ($$) {
 284         my $msn2uid = $_[0];
 285         $_[1] =~ s!([0-9]+)!$msn2uid->[$1 - 1] // ($msn2uid->[-1] // 0 + 1)!sge;
 286 }
 287
 288 # called by PublicInbox::InboxIdle
 289 sub on_inbox_unlock {
 290         my ($self, $ibx) = @_;
 291         my $uid_end = $self->{uid_base} + UID_SLICE;
 292         uo2m_extend($self, $uid_end, 'write');
 293         my $new = uo2m_last_uid($self);
 294         if ($new == $uid_end) { # max exceeded $uid_end
 295                 # continue idling w/o inotify
 296                 my $sock = $self->{sock} or return;
 297                 $ibx->unsubscribe_unlock(fileno($sock));
 298         }
 299 }
 300
 301 # called every minute or so by PublicInbox::DS::later
 302 my $IDLERS; # fileno($obj->{sock}) => PublicInbox::IMAP
 303 sub idle_tick_all {
 304         my $old = $IDLERS;
 305         $IDLERS = undef;
 306         for my $i (values %$old) {
 307                 next if ($i->{wbuf} || !exists($i->{-idle_tag}));
 308                 $IDLERS->{fileno($i->{sock})} = $i;
 309                 $i->write(\"* OK Still here\r\n");
 310         }
 311         $IDLERS and
 312                 PublicInbox::DS::add_uniq_timer('idle', 60, \&idle_tick_all);
 313 }
 314
 315 sub cmd_idle ($$) {
 316         my ($self, $tag) = @_;
 317         # IDLE seems allowed by dovecot w/o a mailbox selected *shrug*
 318         my $ibx = $self->{ibx} or return "$tag BAD no mailbox selected\r\n";
 319         my $uid_end = $self->{uid_base} + UID_SLICE;
 320         uo2m_extend($self, $uid_end);
 321         my $sock = $self->{sock} or return;
 322         my $fd = fileno($sock);
 323         $self->{-idle_tag} = $tag;
 324         # only do inotify on most recent slice
 325         if ($ibx->over(1)->max < $uid_end) {
 326                 $ibx->subscribe_unlock($fd, $self);
 327                 $self->{imapd}->idler_start;
 328         }
 329         PublicInbox::DS::add_uniq_timer('idle', 60, \&idle_tick_all);
 330         $IDLERS->{$fd} = $self;
 331         \"+ idling\r\n"
 332 }
 333
 334 sub stop_idle ($$) {
 335         my ($self, $ibx) = @_;
 336         my $sock = $self->{sock} or return;
 337         my $fd = fileno($sock);
 338         delete $IDLERS->{$fd};
 339         $ibx->unsubscribe_unlock($fd);
 340 }
 341
 342 sub idle_done ($$) {
 343         my ($self, $tag) = @_; # $tag is "DONE" (case-insensitive)
 344         defined(my $idle_tag = delete $self->{-idle_tag}) or
 345                 return "$tag BAD not idle\r\n";
 346         my $ibx = $self->{ibx} or do {
 347                 warn "BUG: idle_tag set w/o inbox";
 348                 return "$tag BAD internal bug\r\n";
 349         };
 350         stop_idle($self, $ibx);
 351         "$idle_tag OK Idle done\r\n";
 352 }
 353
 354 sub ensure_slices_exist ($$) {
 355         my ($imapd, $ibx) = @_;
 356         my $mb_top = $ibx->{newsgroup} // return;
 357         my $mailboxes = $imapd->{mailboxes};
 358         my $list = $imapd->{mailboxlist}; # may be undef, just autoviv + noop
 359         for (my $i = int($ibx->art_max/UID_SLICE); $i >= 0; --$i) {
 360                 my $sub_mailbox = "$mb_top.$i";
 361                 last if exists $mailboxes->{$sub_mailbox};
 362                 $mailboxes->{$sub_mailbox} = $ibx;
 363                 $sub_mailbox =~ s/\Ainbox\./INBOX./i; # more familiar to users
 364                 push @$list, qq[* LIST (\\HasNoChildren) "." $sub_mailbox\r\n]
 365         }
 366 }
 367
 368 sub inbox_lookup ($$;$) {
 369         my ($self, $mailbox, $examine) = @_;
 370         my ($ibx, $exists, $uidmax, $uid_base) = (undef, 0, 0, 0);
 371         $mailbox = lc $mailbox;
 372         $ibx = $self->{imapd}->{mailboxes}->{$mailbox} or return;
 373         my $over = $ibx->over(1);
 374         if ($over != $ibx) { # not a dummy
 375                 $mailbox =~ /\.([0-9]+)\z/ or
 376                                 die "BUG: unexpected dummy mailbox: $mailbox\n";
 377                 $uid_base = $1 * UID_SLICE;
 378
 379                 $uidmax = $ibx->mm->num_highwater // 0;
 380                 if ($examine) {
 381                         $self->{uid_base} = $uid_base;
 382                         $self->{ibx} = $ibx;
 383                         $self->{uo2m} = uo2m_ary_new($self, \$exists);
 384                 } else {
 385                         my $uid_end = $uid_base + UID_SLICE;
 386                         $exists = $over->imap_exists($uid_base, $uid_end);
 387                 }
 388                 delete $ibx->{-art_max};
 389                 ensure_slices_exist($self->{imapd}, $ibx);
 390         } else {
 391                 if ($examine) {
 392                         $self->{uid_base} = $uid_base;
 393                         $self->{ibx} = $ibx;
 394                         delete $self->{uo2m};
 395                 }
 396                 # if "INBOX.foo.bar" is selected and "INBOX.foo.bar.0",
 397                 # check for new UID ranges (e.g. "INBOX.foo.bar.1")
 398                 if (my $ibx = $self->{imapd}->{mailboxes}->{"$mailbox.0"}) {
 399                         delete $ibx->{-art_max};
 400                         ensure_slices_exist($self->{imapd}, $ibx);
 401                 }
 402         }
 403         ($ibx, $exists, $uidmax + 1, $uid_base);
 404 }
 405
 406 sub cmd_examine ($$$) {
 407         my ($self, $tag, $mailbox) = @_;
 408         # XXX: do we need this? RFC 5162/7162
 409         my $ret = $self->{ibx} ? "* OK [CLOSED] previous closed\r\n" : '';
 410         my ($ibx, $exists, $uidnext, $base) = inbox_lookup($self, $mailbox, 1);
 411         return "$tag NO Mailbox doesn't exist: $mailbox\r\n" if !$ibx;
 412         $ret .= <<EOF;
 413 * $exists EXISTS\r
 414 * $exists RECENT\r
 415 * FLAGS (\\Seen)\r
 416 * OK [PERMANENTFLAGS ()] Read-only mailbox\r
 417 * OK [UNSEEN $exists]\r
 418 * OK [UIDNEXT $uidnext]\r
 419 * OK [UIDVALIDITY $ibx->{uidvalidity}]\r
 420 $tag OK [READ-ONLY] EXAMINE/SELECT done\r
 421 EOF
 422 }
 423
 424 sub _esc ($) {
 425         my ($v) = @_;
 426         if (!defined($v)) {
 427                 'NIL';
 428         } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string
 429                 utf8::encode($v);
 430                 '{' . length($v) . "}\r\n" . $v;
 431         } else { # quoted string
 432                 utf8::encode($v);
 433                 qq{"$v"}
 434         }
 435 }
 436
 437 sub addr_envelope ($$;$) {
 438         my ($eml, $x, $y) = @_;
 439         my $v = $eml->header_raw($x) //
 440                 ($y ? $eml->header_raw($y) : undef) // return 'NIL';
 441
 442         my @x = $Address->parse($v) or return 'NIL';
 443         '(' . join('',
 444                 map { '(' . join(' ',
 445                                 _esc($_->name), 'NIL',
 446                                 _esc($_->user), _esc($_->host)
 447                         ) . ')'
 448                 } @x) .
 449         ')';
 450 }
 451
 452 sub eml_envelope ($) {
 453         my ($eml) = @_;
 454         '(' . join(' ',
 455                 _esc($eml->header_raw('Date')),
 456                 _esc($eml->header_raw('Subject')),
 457                 addr_envelope($eml, 'From'),
 458                 addr_envelope($eml, 'Sender', 'From'),
 459                 addr_envelope($eml, 'Reply-To', 'From'),
 460                 addr_envelope($eml, 'To'),
 461                 addr_envelope($eml, 'Cc'),
 462                 addr_envelope($eml, 'Bcc'),
 463                 _esc($eml->header_raw('In-Reply-To')),
 464                 _esc($eml->header_raw('Message-ID')),
 465         ) . ')';
 466 }
 467
 468 sub _esc_hash ($) {
 469         my ($hash) = @_;
 470         if ($hash && scalar keys %$hash) {
 471                 $hash = [ %$hash ]; # flatten hash into 1-dimensional array
 472                 '(' . join(' ', map { _esc($_) } @$hash) . ')';
 473         } else {
 474                 'NIL';
 475         }
 476 }
 477
 478 sub body_disposition ($) {
 479         my ($eml) = @_;
 480         my $cd = $eml->header_raw('Content-Disposition') or return 'NIL';
 481         $cd = parse_content_disposition($cd);
 482         my $buf = '('._esc($cd->{type});
 483         $buf .= ' ' . _esc_hash($cd->{attributes});
 484         $buf .= ')';
 485 }
 486
 487 sub body_leaf ($$;$) {
 488         my ($eml, $structure, $hold) = @_;
 489         my $buf = '';
 490         $eml->{is_submsg} and # parent was a message/(rfc822|news|global)
 491                 $buf .= eml_envelope($eml). ' ';
 492         my $ct = $eml->ct;
 493         $buf .= '('._esc($ct->{type}).' ';
 494         $buf .= _esc($ct->{subtype});
 495         $buf .= ' ' . _esc_hash($ct->{attributes});
 496         $buf .= ' ' . _esc($eml->header_raw('Content-ID'));
 497         $buf .= ' ' . _esc($eml->header_raw('Content-Description'));
 498         my $cte = $eml->header_raw('Content-Transfer-Encoding') // '7bit';
 499         $buf .= ' ' . _esc($cte);
 500         $buf .= ' ' . $eml->{imap_body_len};
 501         $buf .= ' '.($eml->body_raw =~ tr/\n/\n/) if lc($ct->{type}) eq 'text';
 502
 503         # for message/(rfc822|global|news), $hold[0] should have envelope
 504         $buf .= ' ' . (@$hold ? join('', @$hold) : 'NIL') if $hold;
 505
 506         if ($structure) {
 507                 $buf .= ' '._esc($eml->header_raw('Content-MD5'));
 508                 $buf .= ' '. body_disposition($eml);
 509                 $buf .= ' '._esc($eml->header_raw('Content-Language'));
 510                 $buf .= ' '._esc($eml->header_raw('Content-Location'));
 511         }
 512         $buf .= ')';
 513 }
 514
 515 sub body_parent ($$$) {
 516         my ($eml, $structure, $hold) = @_;
 517         my $ct = $eml->ct;
 518         my $type = lc($ct->{type});
 519         if ($type eq 'multipart') {
 520                 my $buf = '(';
 521                 $buf .= @$hold ? join('', @$hold) : 'NIL';
 522                 $buf .= ' '._esc($ct->{subtype});
 523                 if ($structure) {
 524                         $buf .= ' '._esc_hash($ct->{attributes});
 525                         $buf .= ' '.body_disposition($eml);
 526                         $buf .= ' '._esc($eml->header_raw('Content-Language'));
 527                         $buf .= ' '._esc($eml->header_raw('Content-Location'));
 528                 }
 529                 $buf .= ')';
 530                 @$hold = ($buf);
 531         } else { # message/(rfc822|global|news)
 532                 @$hold = (body_leaf($eml, $structure, $hold));
 533         }
 534 }
 535
 536 # this is gross, but we need to process the parent part AFTER
 537 # the child parts are done
 538 sub bodystructure_prep {
 539         my ($p, $q) = @_;
 540         my ($eml, $depth) = @$p; # ignore idx
 541         # set length here, as $eml->{bdy} gets deleted for message/rfc822
 542         $eml->{imap_body_len} = length($eml->body_raw);
 543         push @$q, $eml, $depth;
 544 }
 545
 546 # for FETCH BODY and FETCH BODYSTRUCTURE
 547 sub fetch_body ($;$) {
 548         my ($eml, $structure) = @_;
 549         my @q;
 550         $eml->each_part(\&bodystructure_prep, \@q, 0, 1);
 551         my $cur_depth = 0;
 552         my @hold;
 553         do {
 554                 my ($part, $depth) = splice(@q, -2);
 555                 my $is_mp_parent = $depth == ($cur_depth - 1);
 556                 $cur_depth = $depth;
 557
 558                 if ($is_mp_parent) {
 559                         body_parent($part, $structure, \@hold);
 560                 } else {
 561                         unshift @hold, body_leaf($part, $structure);
 562                 }
 563         } while (@q);
 564         join('', @hold);
 565 }
 566
 567 sub fetch_run_ops {
 568         my ($self, $smsg, $bref, $ops, $partial) = @_;
 569         my $uid = $smsg->{num};
 570         $self->msg_more('* '.uid2msn($self, $uid)." FETCH (UID $uid");
 571         my ($eml, $k);
 572         for (my $i = 0; $i < @$ops;) {
 573                 $k = $ops->[$i++];
 574                 $ops->[$i++]->($self, $k, $smsg, $bref, $eml);
 575         }
 576         partial_emit($self, $partial, $eml) if $partial;
 577         $self->msg_more(")\r\n");
 578 }
 579
 580 sub requeue { # overrides PublicInbox::DS::requeue
 581         my ($self) = @_;
 582         if ($self->{anon}) { # AUTH=ANONYMOUS gets high priority
 583                 $self->SUPER::requeue;
 584         } else { # low priority
 585                 push(@{$self->{imapd}->{-authed_q}}, $self) == 1 and
 586                         PublicInbox::DS::requeue($self->{imapd});
 587         }
 588 }
 589
 590 sub fetch_blob_cb { # called by git->cat_async via ibx_async_cat
 591         my ($bref, $oid, $type, $size, $fetch_arg) = @_;
 592         my ($self, undef, $msgs, $range_info, $ops, $partial) = @$fetch_arg;
 593         my $ibx = $self->{ibx} or return $self->close; # client disconnected
 594         my $smsg = shift @$msgs or die 'BUG: no smsg';
 595         if (!defined($oid)) {
 596                 # it's possible to have TOCTOU if an admin runs
 597                 # public-inbox-(edit|purge), just move onto the next message
 598                 warn "E: $smsg->{blob} missing in $ibx->{inboxdir}\n";
 599                 return $self->requeue_once;
 600         } else {
 601                 $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid";
 602         }
 603         my $pre;
 604         ($self->{anon} && !$self->{wbuf} && $msgs->[0]) and
 605                 $pre = ibx_async_prefetch($ibx, $msgs->[0]->{blob},
 606                                         \&fetch_blob_cb, $fetch_arg);
 607         fetch_run_ops($self, $smsg, $bref, $ops, $partial);
 608         $pre ? $self->dflush : $self->requeue_once;
 609 }
 610
 611 sub emit_rfc822 {
 612         my ($self, $k, undef, $bref) = @_;
 613         $self->msg_more(" $k {" . length($$bref)."}\r\n");
 614         $self->msg_more($$bref);
 615 }
 616
 617 # Mail::IMAPClient::message_string cares about this by default,
 618 # (->Ignoresizeerrors attribute).  Admins are encouraged to
 619 # --reindex for IMAP support, anyways.
 620 sub emit_rfc822_size {
 621         my ($self, $k, $smsg) = @_;
 622         $self->msg_more(' RFC822.SIZE ' . $smsg->{bytes});
 623 }
 624
 625 sub emit_internaldate {
 626         my ($self, undef, $smsg) = @_;
 627         $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
 628 }
 629
 630 sub emit_flags { $_[0]->msg_more(' FLAGS ()') }
 631
 632 sub emit_envelope {
 633         my ($self, undef, undef, undef, $eml) = @_;
 634         $self->msg_more(' ENVELOPE '.eml_envelope($eml));
 635 }
 636
 637 sub emit_rfc822_header {
 638         my ($self, $k, undef, undef, $eml) = @_;
 639         $self->msg_more(" $k {".length(${$eml->{hdr}})."}\r\n");
 640         $self->msg_more(${$eml->{hdr}});
 641 }
 642
 643 # n.b. this is sorted to be after any emit_eml_new ops
 644 sub emit_rfc822_text {
 645         my ($self, $k, undef, $bref) = @_;
 646         $self->msg_more(" $k {".length($$bref)."}\r\n");
 647         $self->msg_more($$bref);
 648 }
 649
 650 sub emit_bodystructure {
 651         my ($self, undef, undef, undef, $eml) = @_;
 652         $self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
 653 }
 654
 655 sub emit_body {
 656         my ($self, undef, undef, undef, $eml) = @_;
 657         $self->msg_more(' BODY '.fetch_body($eml));
 658 }
 659
 660 # set $eml once ($_[4] == $eml, $_[3] == $bref)
 661 sub op_eml_new { $_[4] = PublicInbox::Eml->new($_[3]) }
 662
 663 # s/From / fixes old bug from import (pre-a0c07cba0e5d8b6a)
 664 sub to_crlf_full {
 665         ${$_[0]} =~ s/(?<!\r)\n/\r\n/sg;
 666         ${$_[0]} =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
 667 }
 668
 669 sub op_crlf_bref { to_crlf_full($_[3]) }
 670
 671 sub op_crlf_hdr { to_crlf_full($_[4]->{hdr}) }
 672
 673 sub op_crlf_bdy { ${$_[4]->{bdy}} =~ s/(?<!\r)\n/\r\n/sg if $_[4]->{bdy} }
 674
 675 sub uid_clamp ($$$) {
 676         my ($self, $beg, $end) = @_;
 677         my $uid_min = $self->{uid_base} + 1;
 678         my $uid_end = $uid_min + UID_SLICE - 1;
 679         $$beg = $uid_min if $$beg < $uid_min;
 680         $$end = $uid_end if $$end > $uid_end;
 681 }
 682
 683 sub range_step ($$) {
 684         my ($self, $range_csv) = @_;
 685         my ($beg, $end, $range);
 686         if ($$range_csv =~ s/\A([^,]+),//) {
 687                 $range = $1;
 688         } else {
 689                 $range = $$range_csv;
 690                 $$range_csv = undef;
 691         }
 692         my $uid_base = $self->{uid_base};
 693         my $uid_end = $uid_base + UID_SLICE;
 694         if ($range =~ /\A([0-9]+):([0-9]+)\z/) {
 695                 ($beg, $end) = ($1 + 0, $2 + 0);
 696                 uid_clamp($self, \$beg, \$end);
 697         } elsif ($range =~ /\A([0-9]+):\*\z/) {
 698                 $beg = $1 + 0;
 699                 $end = $self->{ibx}->over(1)->max;
 700                 $end = $uid_end if $end > $uid_end;
 701                 $beg = $end if $beg > $end;
 702                 uid_clamp($self, \$beg, \$end);
 703         } elsif ($range =~ /\A[0-9]+\z/) {
 704                 $beg = $end = $range + 0;
 705                 # just let the caller do an out-of-range query if a single
 706                 # UID is out-of-range
 707                 ++$beg if ($beg <= $uid_base || $end > $uid_end);
 708         } else {
 709                 return 'BAD fetch range';
 710         }
 711         [ $beg, $end, $$range_csv ];
 712 }
 713
 714 sub refill_range ($$$) {
 715         my ($self, $msgs, $range_info) = @_;
 716         my ($beg, $end, $range_csv) = @$range_info;
 717         if (scalar(@$msgs = @{$self->{ibx}->over(1)->query_xover($beg, $end)})){
 718                 $range_info->[0] = $msgs->[-1]->{num} + 1;
 719                 return;
 720         }
 721         return 'OK Fetch done' if !$range_csv;
 722         my $next_range = range_step($self, \$range_csv);
 723         return $next_range if !ref($next_range); # error
 724         @$range_info = @$next_range;
 725         undef; # keep looping
 726 }
 727
 728 sub fetch_blob { # long_response
 729         my ($self, $tag, $msgs, $range_info, $ops, $partial) = @_;
 730         while (!@$msgs) { # rare
 731                 if (my $end = refill_range($self, $msgs, $range_info)) {
 732                         $self->write(\"$tag $end\r\n");
 733                         return;
 734                 }
 735         }
 736         uo2m_extend($self, $msgs->[-1]->{num});
 737         ibx_async_cat($self->{ibx}, $msgs->[0]->{blob},
 738                         \&fetch_blob_cb, \@_);
 739 }
 740
 741 sub fetch_smsg { # long_response
 742         my ($self, $tag, $msgs, $range_info, $ops) = @_;
 743         while (!@$msgs) { # rare
 744                 if (my $end = refill_range($self, $msgs, $range_info)) {
 745                         $self->write(\"$tag $end\r\n");
 746                         return;
 747                 }
 748         }
 749         uo2m_extend($self, $msgs->[-1]->{num});
 750         fetch_run_ops($self, $_, undef, $ops) for @$msgs;
 751         @$msgs = ();
 752         1; # more
 753 }
 754
 755 sub refill_uids ($$$;$) {
 756         my ($self, $uids, $range_info, $sql) = @_;
 757         my ($beg, $end, $range_csv) = @$range_info;
 758         my $over = $self->{ibx}->over(1);
 759         while (1) {
 760                 if (scalar(@$uids = @{$over->uid_range($beg, $end, $sql)})) {
 761                         $range_info->[0] = $uids->[-1] + 1; # update $beg
 762                         return;
 763                 } elsif (!$range_csv) {
 764                         return 0;
 765                 } else {
 766                         my $next_range = range_step($self, \$range_csv);
 767                         return $next_range if !ref($next_range); # error
 768                         ($beg, $end, $range_csv) = @$range_info = @$next_range;
 769                         # continue looping
 770                 }
 771         }
 772 }
 773
 774 sub fetch_uid { # long_response
 775         my ($self, $tag, $uids, $range_info, $ops) = @_;
 776         if (defined(my $err = refill_uids($self, $uids, $range_info))) {
 777                 $err ||= 'OK Fetch done';
 778                 $self->write("$tag $err\r\n");
 779                 return;
 780         }
 781         my $adj = $self->{uid_base} + 1;
 782         my $uo2m = uo2m_extend($self, $uids->[-1]);
 783         $uo2m = [ unpack('S*', $uo2m) ] if !ref($uo2m);
 784         my ($i, $k);
 785         for (@$uids) {
 786                 $self->msg_more("* $uo2m->[$_ - $adj] FETCH (UID $_");
 787                 for ($i = 0; $i < @$ops;) {
 788                         $k = $ops->[$i++];
 789                         $ops->[$i++]->($self, $k);
 790                 }
 791                 $self->msg_more(")\r\n");
 792         }
 793         @$uids = ();
 794         1; # more
 795 }
 796
 797 sub cmd_status ($$$;@) {
 798         my ($self, $tag, $mailbox, @items) = @_;
 799         return "$tag BAD no items\r\n" if !scalar(@items);
 800         ($items[0] !~ s/\A\(//s || $items[-1] !~ s/\)\z//s) and
 801                 return "$tag BAD invalid args\r\n";
 802         my ($ibx, $exists, $uidnext) = inbox_lookup($self, $mailbox);
 803         return "$tag NO Mailbox doesn't exist: $mailbox\r\n" if !$ibx;
 804         my @it;
 805         for my $it (@items) {
 806                 $it = uc($it);
 807                 push @it, $it;
 808                 if ($it =~ /\A(?:MESSAGES|UNSEEN|RECENT)\z/) {
 809                         push @it, $exists;
 810                 } elsif ($it eq 'UIDNEXT') {
 811                         push @it, $uidnext;
 812                 } elsif ($it eq 'UIDVALIDITY') {
 813                         push @it, $ibx->{uidvalidity};
 814                 } else {
 815                         return "$tag BAD invalid item\r\n";
 816                 }
 817         }
 818         return "$tag BAD no items\r\n" if !@it;
 819         "* STATUS $mailbox (".join(' ', @it).")\r\n" .
 820         "$tag OK Status done\r\n";
 821 }
 822
 823 my %patmap = ('*' => '.*', '%' => '[^\.]*');
 824 sub cmd_list ($$$$) {
 825         my ($self, $tag, $refname, $wildcard) = @_;
 826         my $l = $self->{imapd}->{mailboxlist};
 827         if ($refname eq '' && $wildcard eq '') {
 828                 # request for hierarchy delimiter
 829                 $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
 830         } elsif ($refname ne '' || $wildcard ne '*') {
 831                 $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!egi;
 832                 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/is, @$l) ];
 833         }
 834         \(join('', @$l, "$tag OK List done\r\n"));
 835 }
 836
 837 sub cmd_lsub ($$$$) {
 838         my (undef, $tag) = @_; # same args as cmd_list
 839         "$tag OK Lsub done\r\n";
 840 }
 841
 842 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
 843         my ($p, $all) = @_;
 844         my ($eml, undef, $idx) = @$p;
 845         if ($idx && lc($eml->ct->{type}) eq 'multipart') {
 846                 $eml->{imap_bdy} = $eml->{bdy} // \'';
 847         }
 848         $all->{$idx} = $eml; # $idx => Eml
 849 }
 850
 851 # prepares an index for BODY[$SECTION_IDX] fetches
 852 sub eml_body_idx ($$) {
 853         my ($eml, $section_idx) = @_;
 854         my $idx = $eml->{imap_all_parts} // do {
 855                 my $all = {};
 856                 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
 857                 # top-level of multipart, BODY[0] not allowed (nz-number)
 858                 delete $all->{0};
 859                 $eml->{imap_all_parts} = $all;
 860         };
 861         $idx->{$section_idx};
 862 }
 863
 864 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
 865 sub partial_body {
 866         my ($eml, $section_idx, $section_name) = @_;
 867         if (defined $section_idx) {
 868                 $eml = eml_body_idx($eml, $section_idx) or return;
 869         }
 870         if (defined $section_name) {
 871                 if ($section_name eq 'MIME') {
 872                         # RFC 3501 6.4.5 states:
 873                         #       The MIME part specifier MUST be prefixed
 874                         #       by one or more numeric part specifiers
 875                         return unless defined $section_idx;
 876                         return $eml->header_obj->as_string . "\r\n";
 877                 }
 878                 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
 879                 $eml = PublicInbox::Eml->new($$bdy);
 880                 if ($section_name eq 'TEXT') {
 881                         return $eml->body_raw;
 882                 } elsif ($section_name eq 'HEADER') {
 883                         return $eml->header_obj->as_string . "\r\n";
 884                 } else {
 885                         die "BUG: bad section_name=$section_name";
 886                 }
 887         }
 888         ${$eml->{bdy} // $eml->{imap_bdy} // \''};
 889 }
 890
 891 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
 892 # to avoid OOM with malicious users
 893 sub hdrs_regexp ($) {
 894         my ($hdrs) = @_;
 895         my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
 896         qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
 897                 # continuation lines:
 898                 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
 899                 /ismx;
 900 }
 901
 902 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
 903 sub partial_hdr_not {
 904         my ($eml, $section_idx, $hdrs_re) = @_;
 905         if (defined $section_idx) {
 906                 $eml = eml_body_idx($eml, $section_idx) or return;
 907         }
 908         my $str = $eml->header_obj->as_string;
 909         $str =~ s/$hdrs_re//g;
 910         $str =~ s/(?<!\r)\n/\r\n/sg;
 911         $str .= "\r\n";
 912 }
 913
 914 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
 915 sub partial_hdr_get {
 916         my ($eml, $section_idx, $hdrs_re) = @_;
 917         if (defined $section_idx) {
 918                 $eml = eml_body_idx($eml, $section_idx) or return;
 919         }
 920         my $str = $eml->header_obj->as_string;
 921         $str = join('', ($str =~ m/($hdrs_re)/g));
 922         $str =~ s/(?<!\r)\n/\r\n/sg;
 923         $str .= "\r\n";
 924 }
 925
 926 sub partial_prepare ($$$$) {
 927         my ($need, $partial, $want, $att) = @_;
 928
 929         # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
 930         # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
 931         return unless $att =~ /\ABODY\[/s;
 932         until (rindex($att, ']') >= 0) {
 933                 my $next = shift @$want or return;
 934                 $att .= ' ' . uc($next);
 935         }
 936         if ($att =~ /\ABODY\[([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
 937                         (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
 938                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
 939                 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
 940                 $$need |= CRLF_BREF|EML_HDR|EML_BDY;
 941         } elsif ($att =~ /\ABODY\[(?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
 942                                 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
 943                                 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
 944                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
 945                 my $tmp = $partial->{$att} = [ $2 ? \&partial_hdr_not
 946                                                 : \&partial_hdr_get,
 947                                                 $1, undef, $4, $5 ];
 948                 $tmp->[2] = hdrs_regexp($3);
 949
 950                 # don't emit CRLF_HDR instruction, here, partial_hdr_*
 951                 # will do CRLF conversion with only the extracted result
 952                 # and not waste time converting lines we don't care about.
 953                 $$need |= EML_HDR;
 954         } else {
 955                 undef;
 956         }
 957 }
 958
 959 sub partial_emit ($$$) {
 960         my ($self, $partial, $eml) = @_;
 961         for (@$partial) {
 962                 my ($k, $cb, @args) = @$_;
 963                 my ($offset, $len) = splice(@args, -2);
 964                 # $cb is partial_body|partial_hdr_get|partial_hdr_not
 965                 my $str = $cb->($eml, @args) // '';
 966                 if (defined $offset) {
 967                         if (defined $len) {
 968                                 $str = substr($str, $offset, $len);
 969                                 $k =~ s/\.$len>\z/>/ or warn
 970 "BUG: unable to remove `.$len>' from `$k'";
 971                         } else {
 972                                 $str = substr($str, $offset);
 973                                 $len = length($str);
 974                         }
 975                 } else {
 976                         $len = length($str);
 977                 }
 978                 $self->msg_more(" $k {$len}\r\n");
 979                 $self->msg_more($str);
 980         }
 981 }
 982
 983 sub fetch_compile ($) {
 984         my ($want) = @_;
 985         if ($want->[0] =~ s/\A\(//s) {
 986                 $want->[-1] =~ s/\)\z//s or return 'BAD no rparen';
 987         }
 988         my (%partial, %seen, @op);
 989         my $need = 0;
 990         while (defined(my $att = shift @$want)) {
 991                 $att = uc($att);
 992                 next if $att eq 'UID'; # always returned
 993                 $att =~ s/\ABODY\.PEEK\[/BODY\[/; # we're read-only
 994                 my $x = $FETCH_ATT{$att};
 995                 if ($x) {
 996                         while (my ($k, $fl_cb) = each %$x) {
 997                                 next if $seen{$k}++;
 998                                 $need |= $fl_cb->[0];
 999                                 push @op, [ @$fl_cb, $k ];
1000                         }
1001                 } elsif (!partial_prepare(\$need, \%partial, $want, $att)) {
1002                         return "BAD param: $att";
1003                 }
1004         }
1005         my @r;
1006
1007         # stabilize partial order for consistency and ease-of-debugging:
1008         if (scalar keys %partial) {
1009                 $need |= NEED_BLOB;
1010                 @{$r[2]} = map { [ $_, @{$partial{$_}} ] } sort keys %partial;
1011         }
1012
1013         push @op, $OP_EML_NEW if ($need & (EML_HDR|EML_BDY));
1014
1015         # do we need CRLF conversion?
1016         if ($need & CRLF_BREF) {
1017                 push @op, $OP_CRLF_BREF;
1018         } elsif (my $crlf = ($need & (CRLF_HDR|CRLF_BDY))) {
1019                 if ($crlf == (CRLF_HDR|CRLF_BDY)) {
1020                         push @op, $OP_CRLF_BREF;
1021                 } elsif ($need & CRLF_HDR) {
1022                         push @op, $OP_CRLF_HDR;
1023                 } else {
1024                         push @op, $OP_CRLF_BDY;
1025                 }
1026         }
1027
1028         $r[0] = $need & NEED_BLOB ? \&fetch_blob :
1029                 ($need & NEED_SMSG ? \&fetch_smsg : \&fetch_uid);
1030
1031         # r[1] = [ $key1, $cb1, $key2, $cb2, ... ]
1032         use sort 'stable'; # makes output more consistent
1033         @{$r[1]} = map { ($_->[2], $_->[1]) } sort { $a->[0] <=> $b->[0] } @op;
1034         @r;
1035 }
1036
1037 sub cmd_uid_fetch ($$$$;@) {
1038         my ($self, $tag, $range_csv, @want) = @_;
1039         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
1040         my ($cb, $ops, $partial) = fetch_compile(\@want);
1041         return "$tag $cb\r\n" unless $ops;
1042
1043         # cb is one of fetch_blob, fetch_smsg, fetch_uid
1044         $range_csv = 'bad' if $range_csv !~ $valid_range;
1045         my $range_info = range_step($self, \$range_csv);
1046         return "$tag $range_info\r\n" if !ref($range_info);
1047         uo2m_hibernate($self) if $cb == \&fetch_blob; # slow, save RAM
1048         $self->long_response($cb, $tag, [], $range_info, $ops, $partial);
1049 }
1050
1051 sub cmd_fetch ($$$$;@) {
1052         my ($self, $tag, $range_csv, @want) = @_;
1053         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
1054         my ($cb, $ops, $partial) = fetch_compile(\@want);
1055         return "$tag $cb\r\n" unless $ops;
1056
1057         # cb is one of fetch_blob, fetch_smsg, fetch_uid
1058         $range_csv = 'bad' if $range_csv !~ $valid_range;
1059         msn_to_uid_range(msn2uid($self), $range_csv);
1060         my $range_info = range_step($self, \$range_csv);
1061         return "$tag $range_info\r\n" if !ref($range_info);
1062         uo2m_hibernate($self) if $cb == \&fetch_blob; # slow, save RAM
1063         $self->long_response($cb, $tag, [], $range_info, $ops, $partial);
1064 }
1065
1066 sub msn_convert ($$) {
1067         my ($self, $uids) = @_;
1068         my $adj = $self->{uid_base} + 1;
1069         my $uo2m = uo2m_extend($self, $uids->[-1]);
1070         $uo2m = [ unpack('S*', $uo2m) ] if !ref($uo2m);
1071         $_ = $uo2m->[$_ - $adj] for @$uids;
1072 }
1073
1074 sub search_uid_range { # long_response
1075         my ($self, $tag, $sql, $range_info, $want_msn) = @_;
1076         my $uids = [];
1077         if (defined(my $err = refill_uids($self, $uids, $range_info, $sql))) {
1078                 $err ||= 'OK Search done';
1079                 $self->write("\r\n$tag $err\r\n");
1080                 return;
1081         }
1082         msn_convert($self, $uids) if $want_msn;
1083         $self->msg_more(join(' ', '', @$uids));
1084         1; # more
1085 }
1086
1087 sub parse_imap_query ($$) {
1088         my ($self, $query) = @_;
1089         my $q = PublicInbox::IMAPsearchqp::parse($self, $query);
1090         if (ref($q)) {
1091                 my $max = $self->{ibx}->over(1)->max;
1092                 my $beg = 1;
1093                 uid_clamp($self, \$beg, \$max);
1094                 $q->{range_info} = [ $beg, $max ];
1095         }
1096         $q;
1097 }
1098
1099 sub search_common {
1100         my ($self, $tag, $query, $want_msn) = @_;
1101         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
1102         my $q = parse_imap_query($self, $query);
1103         return "$tag $q\r\n" if !ref($q);
1104         my ($sql, $range_info) = delete @$q{qw(sql range_info)};
1105         if (!scalar(keys %$q)) { # overview.sqlite3
1106                 $self->msg_more('* SEARCH');
1107                 $self->long_response(\&search_uid_range,
1108                                 $tag, $sql, $range_info, $want_msn);
1109         } elsif ($q = $q->{xap}) {
1110                 my $srch = $self->{ibx}->isrch or
1111                         return "$tag BAD search not available for mailbox\r\n";
1112                 my $opt = {
1113                         relevance => -1,
1114                         limit => UID_SLICE,
1115                         uid_range => $range_info
1116                 };
1117                 my $mset = $srch->mset($q, $opt);
1118                 my $uids = $srch->mset_to_artnums($mset, $opt);
1119                 msn_convert($self, $uids) if scalar(@$uids) && $want_msn;
1120                 "* SEARCH @$uids\r\n$tag OK Search done\r\n";
1121         } else {
1122                 "$tag BAD Error\r\n";
1123         }
1124 }
1125
1126 sub cmd_uid_search ($$$) {
1127         my ($self, $tag, $query) = @_;
1128         search_common($self, $tag, $query);
1129 }
1130
1131 sub cmd_search ($$$;) {
1132         my ($self, $tag, $query) = @_;
1133         search_common($self, $tag, $query, 1);
1134 }
1135
1136 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
1137 sub process_line ($$) {
1138         my ($self, $l) = @_;
1139
1140         # TODO: IMAP allows literals for big requests to upload messages
1141         # (which we don't support) but maybe some big search queries use it.
1142         # RFC 3501 9 (2) doesn't permit TAB or multiple SP
1143         my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
1144         pop(@args) if (@args && !defined($args[-1]));
1145         if (@args && uc($req) eq 'UID') {
1146                 $req .= "_".(shift @args);
1147         }
1148         my $res = eval {
1149                 if (defined(my $idle_tag = $self->{-idle_tag})) {
1150                         (uc($tag // '') eq 'DONE' && !defined($req)) ?
1151                                 idle_done($self, $tag) :
1152                                 "$idle_tag BAD expected DONE\r\n";
1153                 } elsif (my $cmd = $self->can('cmd_'.lc($req // ''))) {
1154                         if ($cmd == \&cmd_uid_search || $cmd == \&cmd_search) {
1155                                 # preserve user-supplied quotes for search
1156                                 (undef, @args) = split(/ search /i, $l, 2);
1157                         }
1158                         $cmd->($self, $tag, @args);
1159                 } else { # this is weird
1160                         auth_challenge_ok($self) //
1161                                         ($tag // '*') .
1162                                         ' BAD Error in IMAP command '.
1163                                         ($req // '(???)').
1164                                         ": Unknown command\r\n";
1165                 }
1166         };
1167         my $err = $@;
1168         if ($err && $self->{sock}) {
1169                 $l =~ s/\r?\n//s;
1170                 warn("error from: $l ($err)\n");
1171                 $tag //= '*';
1172                 $res = \"$tag BAD program fault - command not performed\r\n";
1173         }
1174         defined($res) ? $self->write($res) : 0;
1175 }
1176
1177 sub out ($$;@) {
1178         my ($self, $fmt, @args) = @_;
1179         printf { $self->{imapd}->{out} } $fmt."\n", @args;
1180 }
1181
1182 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
1183 sub event_step {
1184         my ($self) = @_;
1185         local $SIG{__WARN__} = $self->{imapd}->{warn_cb};
1186         return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
1187
1188         # only read more requests if we've drained the write buffer,
1189         # otherwise we can be buffering infinitely w/o backpressure
1190
1191         my $rbuf = $self->{rbuf} // \(my $x = '');
1192         my $line = index($$rbuf, "\n");
1193         while ($line < 0) {
1194                 if (length($$rbuf) >= LINE_MAX) {
1195                         $self->write(\"\* BAD request too long\r\n");
1196                         return $self->close;
1197                 }
1198                 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or
1199                                 return uo2m_hibernate($self);
1200                 $line = index($$rbuf, "\n");
1201         }
1202         $line = substr($$rbuf, 0, $line + 1, '');
1203         $line =~ s/\r?\n\z//s;
1204         return $self->close if $line =~ /[[:cntrl:]]/s;
1205         my $t0 = now();
1206         my $fd = fileno($self->{sock});
1207         my $r = eval { process_line($self, $line) };
1208         my $pending = $self->{wbuf} ? ' pending' : '';
1209         out($self, "[$fd] %s - %0.6f$pending - $r", $line, now() - $t0);
1210
1211         return $self->close if $r < 0;
1212         $self->rbuf_idle($rbuf);
1213
1214         # maybe there's more pipelined data, or we'll have
1215         # to register it for socket-readiness notifications
1216         $self->requeue unless $pending;
1217 }
1218
1219 # RFC 4978
1220 sub cmd_compress ($$$) {
1221         my ($self, $tag, $alg) = @_;
1222         return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
1223         return "$tag BAD COMPRESS active\r\n" if $self->compressed;
1224
1225         # CRIME made TLS compression obsolete
1226         # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
1227
1228         PublicInbox::IMAPdeflate->enable($self) or return
1229                                 \"$tag BAD failed to activate compression\r\n";
1230         PublicInbox::DS::write($self, \"$tag OK DEFLATE active\r\n");
1231         $self->requeue;
1232         undef
1233 }
1234
1235 sub cmd_starttls ($$) {
1236         my ($self, $tag) = @_;
1237         (($self->{sock} // return)->can('stop_SSL') || $self->compressed) and
1238                 return "$tag BAD TLS or compression already enabled\r\n";
1239         $self->{imapd}->{ssl_ctx_opt} or
1240                 return "$tag BAD can not initiate TLS negotiation\r\n";
1241         $self->write(\"$tag OK begin TLS negotiation now\r\n");
1242         PublicInbox::TLS::start($self->{sock}, $self->{imapd});
1243         $self->requeue if PublicInbox::DS::accept_tls_step($self);
1244         undef;
1245 }
1246
1247 sub busy { # for graceful shutdown in PublicInbox::Daemon:
1248         my ($self) = @_;
1249         if (defined($self->{-idle_tag})) {
1250                 $self->write(\"* BYE server shutting down\r\n");
1251                 return; # not busy anymore
1252         }
1253         defined($self->{rbuf}) || defined($self->{wbuf}) ||
1254                 !$self->write(\"* BYE server shutting down\r\n");
1255 }
1256
1257 sub close {
1258         my ($self) = @_;
1259         if (my $ibx = delete $self->{ibx}) {
1260                 stop_idle($self, $ibx);
1261         }
1262         $self->SUPER::close; # PublicInbox::DS::close
1263 }
1264
1265 # we're read-only, so SELECT and EXAMINE do the same thing
1266 no warnings 'once';
1267 *cmd_select = \&cmd_examine;
1268
1269 package PublicInbox::IMAP_preauth;
1270 our @ISA = qw(PublicInbox::IMAP);
1271
1272 sub logged_in { 0 }
1273
1274 package PublicInbox::IMAPdeflate;
1275 use PublicInbox::DSdeflate;
1276 our @ISA = qw(PublicInbox::DSdeflate PublicInbox::IMAP);
1277
1278 1;