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) = @_;
 815         my $uids = $self->{ibx}->mm->msg_range($beg, $end, 'num');
 816         if (@$uids) {
 817                 $self->msg_more(join('', map { " $_->[0]" } @$uids));
 818         } else {
 819                 $self->write(\"\r\n$tag OK Search done\r\n");
 820                 undef;
 821         }
 822 }
 823
 824 sub date_search {
 825         my ($q, $k, $d) = @_;
 826         my $sql = $q->{sql};
 827
 828         # Date: header
 829         if ($k eq 'SENTON') {
 830                 my $end = $d + 86399; # no leap day...
 831                 my $da = strftime('%Y%m%d%H%M%S', gmtime($d));
 832                 my $db = strftime('%Y%m%d%H%M%S', gmtime($end));
 833                 $q->{xap} .= " dt:$da..$db";
 834                 $$sql .= " AND ds >= $d AND ds <= $end" if defined($sql);
 835         } elsif ($k eq 'SENTBEFORE') {
 836                 $q->{xap} .= ' d:..'.strftime('%Y%m%d', gmtime($d));
 837                 $$sql .= " AND ds <= $d" if defined($sql);
 838         } elsif ($k eq 'SENTSINCE') {
 839                 $q->{xap} .= ' d:'.strftime('%Y%m%d', gmtime($d)).'..';
 840                 $$sql .= " AND ds >= $d" if defined($sql);
 841
 842         # INTERNALDATE (Received)
 843         } elsif ($k eq 'ON') {
 844                 my $end = $d + 86399; # no leap day...
 845                 $q->{xap} .= " ts:$d..$end";
 846                 $$sql .= " AND ts >= $d AND ts <= $end" if defined($sql);
 847         } elsif ($k eq 'BEFORE') {
 848                 $q->{xap} .= " ts:..$d";
 849                 $$sql .= " AND ts <= $d" if defined($sql);
 850         } elsif ($k eq 'SINCE') {
 851                 $q->{xap} .= " ts:$d..";
 852                 $$sql .= " AND ts >= $d" if defined($sql);
 853         } else {
 854                 die "BUG: $k not recognized";
 855         }
 856 }
 857
 858 # IMAP to Xapian search key mapping
 859 my %I2X = (
 860         SUBJECT => 's:',
 861         BODY => 'b:',
 862         FROM => 'f:',
 863         TEXT => '', # n.b. does not include all headers
 864         TO => 't:',
 865         CC => 'c:',
 866         # BCC => 'bcc:', # TODO
 867         # KEYWORD # TODO ? dfpre,dfpost,...
 868 );
 869
 870 sub parse_query {
 871         my ($self, $rest) = @_;
 872         if (uc($rest->[0]) eq 'CHARSET') {
 873                 shift @$rest;
 874                 defined(my $c = shift @$rest) or return 'BAD missing charset';
 875                 $c =~ /\A(?:UTF-8|US-ASCII)\z/ or return 'NO [BADCHARSET]';
 876         }
 877
 878         my $sql = ''; # date conditions, {sql} deleted if Xapian is needed
 879         my $q = { xap => '', sql => \$sql };
 880         while (@$rest) {
 881                 my $k = uc(shift @$rest);
 882                 # default criteria
 883                 next if $k =~ /\A(?:ALL|RECENT|UNSEEN|NEW)\z/;
 884                 next if $k eq 'AND'; # the default, until we support OR
 885                 if ($k =~ $valid_range) { # sequence numbers == UIDs
 886                         push @{$q->{uid}}, $k;
 887                 } elsif ($k eq 'UID') {
 888                         $k = shift(@$rest) // '';
 889                         $k =~ $valid_range or return 'BAD UID range';
 890                         push @{$q->{uid}}, $k;
 891                 } elsif ($k =~ /\A(?:SENT)?(?:SINCE|ON|BEFORE)\z/) {
 892                         my $d = parse_date(shift(@$rest) // '');
 893                         defined $d or return "BAD $k date format";
 894                         date_search($q, $k, $d);
 895                 } elsif ($k =~ /\A(?:SMALLER|LARGER)\z/) {
 896                         delete $q->{sql}; # can't use over.sqlite3
 897                         my $bytes = shift(@$rest) // '';
 898                         $bytes =~ /\A[0-9]+\z/ or return "BAD $k not a number";
 899                         $q->{xap} .= ' bytes:' . ($k eq 'SMALLER' ?
 900                                                         '..'.(--$bytes) :
 901                                                         (++$bytes).'..');
 902                 } elsif (defined(my $xk = $I2X{$k})) {
 903                         delete $q->{sql}; # can't use over.sqlite3
 904                         my $arg = shift @$rest;
 905                         defined($arg) or return "BAD $k no arg";
 906
 907                         # Xapian can't handle [*"] in probabilistic terms
 908                         $arg =~ tr/*"//d;
 909                         $q->{xap} .= qq[ $xk:"$arg"];
 910                 } else {
 911                         # TODO: parentheses, OR, NOT ...
 912                         return "BAD $k not supported (yet?)";
 913                 }
 914         }
 915
 916         # favor using over.sqlite3 if possible, since Xapian is optional
 917         if (exists $q->{sql}) {
 918                 delete($q->{xap});
 919                 delete($q->{sql}) if $sql eq '';
 920         } elsif (!$self->{ibx}->search) {
 921                 return 'BAD Xapian not configured for mailbox';
 922         }
 923
 924         if (my $uid = $q->{uid}) {
 925                 ((@$uid > 1) || $uid->[0] =~ /,/) and
 926                         return 'BAD multiple ranges not supported, yet';
 927                 ($q->{sql} // $q->{xap}) and
 928                         return 'BAD ranges and queries do not mix, yet';
 929                 $q->{uid} = join(',', @$uid); # TODO: multiple ranges
 930         }
 931         $q;
 932 }
 933
 934 sub cmd_uid_search ($$$;) {
 935         my ($self, $tag) = splice(@_, 0, 2);
 936         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
 937         my $q = parse_query($self, \@_);
 938         return "$tag $q\r\n" if !ref($q);
 939
 940         if (!scalar(keys %$q)) {
 941                 $self->msg_more('* SEARCH');
 942                 my $beg = $self->{uid_min} // 1;
 943                 my $end = $ibx->mm->max;
 944                 uid_clamp($self, \$beg, \$end);
 945                 long_response($self, \&uid_search_uid_range, $tag, \$beg, $end);
 946         } elsif (my $uid = $q->{uid}) {
 947                 if ($uid =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
 948                         my ($beg, $end) = ($1, $2);
 949                         $end = $ibx->mm->max if $end eq '*';
 950                         uid_clamp($self, \$beg, \$end);
 951                         $self->msg_more('* SEARCH');
 952                         long_response($self, \&uid_search_uid_range,
 953                                         $tag, \$beg, $end);
 954                 } elsif ($uid =~ /\A[0-9]+\z/s) {
 955                         $uid = $ibx->over->get_art($uid) ? " $uid" : '';
 956                         "* SEARCH$uid\r\n$tag OK Search done\r\n";
 957                 } else {
 958                         "$tag BAD Error\r\n";
 959                 }
 960         } else {
 961                 "$tag BAD Error\r\n";
 962         }
 963 }
 964
 965 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
 966         my ($cb, $argc) = @_;
 967         my $tot = prototype $cb;
 968         my ($nreq, undef) = split(';', $tot);
 969         $nreq = ($nreq =~ tr/$//) - 1;
 970         $tot = ($tot =~ tr/$//) - 1;
 971         ($argc <= $tot && $argc >= $nreq);
 972 }
 973
 974 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
 975 sub process_line ($$) {
 976         my ($self, $l) = @_;
 977         my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
 978         pop(@args) if (@args && !defined($args[-1]));
 979         if (@args && uc($req) eq 'UID') {
 980                 $req .= "_".(shift @args);
 981         }
 982         my $res = eval {
 983                 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
 984                         defined($self->{-idle_tag}) ?
 985                                 "$self->{-idle_tag} BAD expected DONE\r\n" :
 986                                 $cmd->($self, $tag, @args);
 987                 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
 988                         cmd_done($self, $tag);
 989                 } else { # this is weird
 990                         auth_challenge_ok($self) //
 991                                         ($tag // '*') .
 992                                         ' BAD Error in IMAP command '.
 993                                         ($req // '(???)').
 994                                         ": Unknown command\r\n";
 995                 }
 996         };
 997         my $err = $@;
 998         if ($err && $self->{sock}) {
 999                 $l =~ s/\r?\n//s;
1000                 err($self, 'error from: %s (%s)', $l, $err);
1001                 $tag //= '*';
1002                 $res = "$tag BAD program fault - command not performed\r\n";
1003         }
1004         return 0 unless defined $res;
1005         $self->write($res);
1006 }
1007
1008 sub long_step {
1009         my ($self) = @_;
1010         # wbuf is unset or empty, here; {long} may add to it
1011         my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
1012         my $more = eval { $cb->($self, @args) };
1013         if ($@ || !$self->{sock}) { # something bad happened...
1014                 delete $self->{long_cb};
1015                 my $elapsed = now() - $t0;
1016                 if ($@) {
1017                         err($self,
1018                             "%s during long response[$fd] - %0.6f",
1019                             $@, $elapsed);
1020                 }
1021                 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
1022                 $self->close;
1023         } elsif ($more) { # $self->{wbuf}:
1024                 $self->update_idle_time;
1025
1026                 # control passed to $more may be a GitAsyncCat object
1027                 requeue_once($self) if !ref($more);
1028         } else { # all done!
1029                 delete $self->{long_cb};
1030                 my $elapsed = now() - $t0;
1031                 my $fd = fileno($self->{sock});
1032                 out($self, " deferred[$fd] done - %0.6f", $elapsed);
1033                 my $wbuf = $self->{wbuf}; # do NOT autovivify
1034
1035                 $self->requeue unless $wbuf && @$wbuf;
1036         }
1037 }
1038
1039 sub err ($$;@) {
1040         my ($self, $fmt, @args) = @_;
1041         printf { $self->{imapd}->{err} } $fmt."\n", @args;
1042 }
1043
1044 sub out ($$;@) {
1045         my ($self, $fmt, @args) = @_;
1046         printf { $self->{imapd}->{out} } $fmt."\n", @args;
1047 }
1048
1049 sub long_response ($$;@) {
1050         my ($self, $cb, @args) = @_; # cb returns true if more, false if done
1051
1052         my $sock = $self->{sock} or return;
1053         # make sure we disable reading during a long response,
1054         # clients should not be sending us stuff and making us do more
1055         # work while we are stream a response to them
1056         $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
1057         long_step($self); # kick off!
1058         undef;
1059 }
1060
1061 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
1062 sub event_step {
1063         my ($self) = @_;
1064
1065         return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
1066
1067         $self->update_idle_time;
1068         # only read more requests if we've drained the write buffer,
1069         # otherwise we can be buffering infinitely w/o backpressure
1070
1071         my $rbuf = $self->{rbuf} // \(my $x = '');
1072         my $line = index($$rbuf, "\n");
1073         while ($line < 0) {
1074                 return $self->close if length($$rbuf) >= LINE_MAX;
1075                 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or return;
1076                 $line = index($$rbuf, "\n");
1077         }
1078         $line = substr($$rbuf, 0, $line + 1, '');
1079         $line =~ s/\r?\n\z//s;
1080         return $self->close if $line =~ /[[:cntrl:]]/s;
1081         my $t0 = now();
1082         my $fd = fileno($self->{sock});
1083         my $r = eval { process_line($self, $line) };
1084         my $pending = $self->{wbuf} ? ' pending' : '';
1085         out($self, "[$fd] %s - %0.6f$pending - $r", $line, now() - $t0);
1086
1087         return $self->close if $r < 0;
1088         $self->rbuf_idle($rbuf);
1089         $self->update_idle_time;
1090
1091         # maybe there's more pipelined data, or we'll have
1092         # to register it for socket-readiness notifications
1093         $self->requeue unless $pending;
1094 }
1095
1096 sub compressed { undef }
1097
1098 sub zflush {} # overridden by IMAPdeflate
1099
1100 # RFC 4978
1101 sub cmd_compress ($$$) {
1102         my ($self, $tag, $alg) = @_;
1103         return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
1104         return "$tag BAD COMPRESS active\r\n" if $self->compressed;
1105
1106         # CRIME made TLS compression obsolete
1107         # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
1108
1109         PublicInbox::IMAPdeflate->enable($self, $tag);
1110         $self->requeue;
1111         undef
1112 }
1113
1114 sub cmd_starttls ($$) {
1115         my ($self, $tag) = @_;
1116         my $sock = $self->{sock} or return;
1117         if ($sock->can('stop_SSL') || $self->compressed) {
1118                 return "$tag BAD TLS or compression already enabled\r\n";
1119         }
1120         my $opt = $self->{imapd}->{accept_tls} or
1121                 return "$tag BAD can not initiate TLS negotiation\r\n";
1122         $self->write(\"$tag OK begin TLS negotiation now\r\n");
1123         $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
1124         $self->requeue if PublicInbox::DS::accept_tls_step($self);
1125         undef;
1126 }
1127
1128 # for graceful shutdown in PublicInbox::Daemon:
1129 sub busy {
1130         my ($self, $now) = @_;
1131         ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
1132 }
1133
1134 sub close {
1135         my ($self) = @_;
1136         if (my $ibx = delete $self->{ibx}) {
1137                 if (my $sock = $self->{sock}) {;
1138                         $ibx->unsubscribe_unlock(fileno($sock));
1139                 }
1140         }
1141         $self->SUPER::close; # PublicInbox::DS::close
1142 }
1143
1144 # we're read-only, so SELECT and EXAMINE do the same thing
1145 no warnings 'once';
1146 *cmd_select = \&cmd_examine;
1147
1148 1;