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