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 range_step ($$) {
 491         my ($self, $range_csv) = @_;
 492         my ($beg, $end, $range);
 493         if ($$range_csv =~ s/\A([^,]+),//) {
 494                 $range = $1;
 495         } else {
 496                 $range = $$range_csv;
 497                 $$range_csv = undef;
 498         }
 499         if ($range =~ /\A([0-9]+):([0-9]+)\z/) {
 500                 ($beg, $end) = ($1 + 0, $2 + 0);
 501         } elsif ($range =~ /\A([0-9]+):\*\z/) {
 502                 $beg = $1 + 0;
 503                 $end = $self->{ibx}->mm->max // 0;
 504                 $beg = $end if $beg > $end;
 505         } elsif ($range =~ /\A[0-9]+\z/) {
 506                 $beg = $end = $range + 0;
 507                 undef $range;
 508         } else {
 509                 return 'BAD fetch range';
 510         }
 511         if (defined($range) && (my $uid_min = $self->{uid_min})) {
 512                 my $uid_end = $uid_min + UID_BLOCK - 1;
 513                 $beg = $uid_min if $beg < $uid_min;
 514                 $end = $uid_end if $end > $uid_end;
 515         }
 516         [ $beg, $end, $$range_csv ];
 517 }
 518
 519 sub refill_range ($$$) {
 520         my ($self, $msgs, $range_info) = @_;
 521         my ($beg, $end, $range_csv) = @$range_info;
 522         if (scalar(@$msgs = @{$self->{ibx}->over->query_xover($beg, $end)})) {
 523                 $range_info->[0] = $msgs->[-1]->{num} + 1;
 524                 return;
 525         }
 526         return 'OK Fetch done' if !$range_csv;
 527         my $next_range = range_step($self, \$range_csv);
 528         return $next_range if !ref($next_range); # error
 529         @$range_info = @$next_range;
 530         undef; # keep looping
 531 }
 532
 533 sub uid_fetch_m { # long_response
 534         my ($self, $tag, $msgs, $range_info, $want) = @_;
 535         while (!@$msgs) { # rare
 536                 if (my $end = refill_range($self, $msgs, $range_info)) {
 537                         $self->write(\"$tag $end\r\n");
 538                         return;
 539                 }
 540         }
 541         git_async_cat($self->{ibx}->git, $msgs->[0]->{blob},
 542                         \&uid_fetch_cb, \@_);
 543 }
 544
 545 sub cmd_status ($$$;@) {
 546         my ($self, $tag, $mailbox, @items) = @_;
 547         return "$tag BAD no items\r\n" if !scalar(@items);
 548         ($items[0] !~ s/\A\(//s || $items[-1] !~ s/\)\z//s) and
 549                 return "$tag BAD invalid args\r\n";
 550         my ($ibx, $exists, $uidnext) = inbox_lookup($self, $mailbox);
 551         return "$tag NO Mailbox doesn't exist: $mailbox\r\n" if !$ibx;
 552         my @it;
 553         for my $it (@items) {
 554                 $it = uc($it);
 555                 push @it, $it;
 556                 if ($it =~ /\A(?:MESSAGES|UNSEEN|RECENT)\z/) {
 557                         push @it, $exists;
 558                 } elsif ($it eq 'UIDNEXT') {
 559                         push @it, $uidnext;
 560                 } elsif ($it eq 'UIDVALIDITY') {
 561                         push @it, $ibx->{uidvalidity};
 562                 } else {
 563                         return "$tag BAD invalid item\r\n";
 564                 }
 565         }
 566         return "$tag BAD no items\r\n" if !@it;
 567         "* STATUS $mailbox (".join(' ', @it).")\r\n" .
 568         "$tag OK Status done\r\n";
 569 }
 570
 571 my %patmap = ('*' => '.*', '%' => '[^\.]*');
 572 sub cmd_list ($$$$) {
 573         my ($self, $tag, $refname, $wildcard) = @_;
 574         my $l = $self->{imapd}->{inboxlist};
 575         if ($refname eq '' && $wildcard eq '') {
 576                 # request for hierarchy delimiter
 577                 $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
 578         } elsif ($refname ne '' || $wildcard ne '*') {
 579                 $wildcard = lc $wildcard;
 580                 $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eg;
 581                 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
 582         }
 583         \(join('', @$l, "$tag OK List done\r\n"));
 584 }
 585
 586 sub cmd_lsub ($$$$) {
 587         my (undef, $tag) = @_; # same args as cmd_list
 588         "$tag OK Lsub done\r\n";
 589 }
 590
 591 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
 592         my ($p, $all) = @_;
 593         my ($eml, undef, $idx) = @$p;
 594         if ($idx && lc($eml->ct->{type}) eq 'multipart') {
 595                 $eml->{imap_bdy} = $eml->{bdy} // \'';
 596         }
 597         $all->{$idx} = $eml; # $idx => Eml
 598 }
 599
 600 # prepares an index for BODY[$SECTION_IDX] fetches
 601 sub eml_body_idx ($$) {
 602         my ($eml, $section_idx) = @_;
 603         my $idx = $eml->{imap_all_parts} //= do {
 604                 my $all = {};
 605                 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
 606                 # top-level of multipart, BODY[0] not allowed (nz-number)
 607                 delete $all->{0};
 608                 $all;
 609         };
 610         $idx->{$section_idx};
 611 }
 612
 613 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
 614 sub partial_body {
 615         my ($eml, $section_idx, $section_name) = @_;
 616         if (defined $section_idx) {
 617                 $eml = eml_body_idx($eml, $section_idx) or return;
 618         }
 619         if (defined $section_name) {
 620                 if ($section_name eq 'MIME') {
 621                         # RFC 3501 6.4.5 states:
 622                         #       The MIME part specifier MUST be prefixed
 623                         #       by one or more numeric part specifiers
 624                         return unless defined $section_idx;
 625                         return $eml->header_obj->as_string . "\r\n";
 626                 }
 627                 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
 628                 $eml = PublicInbox::Eml->new($$bdy);
 629                 if ($section_name eq 'TEXT') {
 630                         return $eml->body_raw;
 631                 } elsif ($section_name eq 'HEADER') {
 632                         return $eml->header_obj->as_string . "\r\n";
 633                 } else {
 634                         die "BUG: bad section_name=$section_name";
 635                 }
 636         }
 637         ${$eml->{bdy} // $eml->{imap_bdy} // \''};
 638 }
 639
 640 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
 641 # to avoid OOM with malicious users
 642 sub hdrs_regexp ($) {
 643         my ($hdrs) = @_;
 644         my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
 645         qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
 646                 # continuation lines:
 647                 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
 648                 /ismx;
 649 }
 650
 651 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
 652 sub partial_hdr_not {
 653         my ($eml, $section_idx, $hdrs_re) = @_;
 654         if (defined $section_idx) {
 655                 $eml = eml_body_idx($eml, $section_idx) or return;
 656         }
 657         my $str = $eml->header_obj->as_string;
 658         $str =~ s/$hdrs_re//g;
 659         $str .= "\r\n";
 660 }
 661
 662 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
 663 sub partial_hdr_get {
 664         my ($eml, $section_idx, $hdrs_re) = @_;
 665         if (defined $section_idx) {
 666                 $eml = eml_body_idx($eml, $section_idx) or return;
 667         }
 668         my $str = $eml->header_obj->as_string;
 669         join('', ($str =~ m/($hdrs_re)/g), "\r\n");
 670 }
 671
 672 sub partial_prepare ($$$) {
 673         my ($partial, $want, $att) = @_;
 674
 675         # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
 676         # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
 677         return unless $att =~ /\ABODY\[/s;
 678         until (rindex($att, ']') >= 0) {
 679                 my $next = shift @$want or return;
 680                 $att .= ' ' . uc($next);
 681         }
 682         if ($att =~ /\ABODY\[([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
 683                         (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
 684                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
 685                 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
 686         } elsif ($att =~ /\ABODY\[(?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
 687                                 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
 688                                 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
 689                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
 690                 my $tmp = $partial->{$att} = [ $2 ? \&partial_hdr_not
 691                                                 : \&partial_hdr_get,
 692                                                 $1, undef, $4, $5 ];
 693                 $tmp->[2] = hdrs_regexp($3);
 694         } else {
 695                 undef;
 696         }
 697 }
 698
 699 sub partial_emit ($$$) {
 700         my ($self, $partial, $eml) = @_;
 701         for (@$partial) {
 702                 my ($k, $cb, @args) = @$_;
 703                 my ($offset, $len) = splice(@args, -2);
 704                 # $cb is partial_body|partial_hdr_get|partial_hdr_not
 705                 my $str = $cb->($eml, @args) // '';
 706                 if (defined $offset) {
 707                         if (defined $len) {
 708                                 $str = substr($str, $offset, $len);
 709                                 $k =~ s/\.$len>\z/>/ or warn
 710 "BUG: unable to remove `.$len>' from `$k'";
 711                         } else {
 712                                 $str = substr($str, $offset);
 713                                 $len = length($str);
 714                         }
 715                 } else {
 716                         $len = length($str);
 717                 }
 718                 $self->msg_more(" $k {$len}\r\n");
 719                 $self->msg_more($str);
 720         }
 721 }
 722
 723 sub fetch_common ($$$$) {
 724         my ($self, $tag, $range_csv, $want) = @_;
 725         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
 726         if ($want->[0] =~ s/\A\(//s) {
 727                 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
 728         }
 729         my (%partial, %want);
 730         while (defined(my $att = shift @$want)) {
 731                 $att = uc($att);
 732                 $att =~ s/\ABODY\.PEEK\[/BODY\[/; # we're read-only
 733                 my $x = $FETCH_ATT{$att};
 734                 if ($x) {
 735                         %want = (%want, %$x);
 736                 } elsif (!partial_prepare(\%partial, $want, $att)) {
 737                         return "$tag BAD param: $att\r\n";
 738                 }
 739         }
 740
 741         # stabilize partial order for consistency and ease-of-debugging:
 742         if (scalar keys %partial) {
 743                 $want{-partial} = [ map {;
 744                         [ $_, @{$partial{$_}} ]
 745                 } sort keys %partial ];
 746         }
 747         $range_csv = 'bad' if $range_csv !~ $valid_range;
 748         my $range_info = range_step($self, \$range_csv);
 749         return "$tag $range_info\r\n" if !ref($range_info);
 750         [ $tag, [], $range_info, \%want ];
 751 }
 752
 753 sub cmd_uid_fetch ($$$;@) {
 754         my ($self, $tag, $range_csv, @want) = @_;
 755         my $args = fetch_common($self, $tag, $range_csv, \@want);
 756         ref($args) eq 'ARRAY' ?
 757                 long_response($self, \&uid_fetch_m, @$args) :
 758                 $args; # error
 759 }
 760
 761 sub seq_fetch_m { # long_response
 762         my ($self, $tag, $msgs, $range_info, $want) = @_;
 763         while (!@$msgs) { # rare
 764                 if (my $end = refill_range($self, $msgs, $range_info)) {
 765                         $self->write(\"$tag $end\r\n");
 766                         return;
 767                 }
 768         }
 769         my $seq = $want->{-seqno}++;
 770         my $cur_num = $msgs->[0]->{num};
 771         if ($cur_num == $seq) { # as expected
 772                 git_async_cat($self->{ibx}->git, $msgs->[0]->{blob},
 773                                 \&uid_fetch_cb, \@_);
 774         } elsif ($cur_num > $seq) {
 775                 # send dummy messages until $seq catches up to $cur_num
 776                 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
 777                 unshift @$msgs, $smsg;
 778                 my $bref = dummy_message($self, $seq);
 779                 uid_fetch_cb($bref, undef, undef, undef, \@_);
 780                 $smsg; # blessed response since uid_fetch_cb requeues
 781         } else { # should not happen
 782                 die "BUG: cur_num=$cur_num < seq=$seq";
 783         }
 784 }
 785
 786 sub cmd_fetch ($$$;@) {
 787         my ($self, $tag, $range_csv, @want) = @_;
 788         my $args = fetch_common($self, $tag, $range_csv, \@want);
 789         ref($args) eq 'ARRAY' ? do {
 790                 my $want = $args->[-1];
 791                 $want->{-seqno} = $args->[2]->[0]; # $beg == $range_info->[0];
 792                 long_response($self, \&seq_fetch_m, @$args)
 793         } : $args; # error
 794 }
 795
 796
 797 sub parse_date ($) { # 02-Oct-1993
 798         my ($date_text) = @_;
 799         my ($dd, $mon, $yyyy) = split(/-/, $_[0], 3);
 800         defined($yyyy) or return;
 801         my $mm = $MoY{$mon} // return;
 802         $dd =~ /\A[0123]?[0-9]\z/ or return;
 803         $yyyy =~ /\A[0-9]{4,}\z/ or return; # Y10K-compatible!
 804         timegm(0, 0, 0, $dd, $mm, $yyyy);
 805 }
 806
 807 sub uid_search_all { # long_response
 808         my ($self, $tag, $num) = @_;
 809         my $uids = $self->{ibx}->mm->ids_after($num);
 810         if (scalar(@$uids)) {
 811                 $self->msg_more(join(' ', '', @$uids));
 812         } else {
 813                 $self->write(\"\r\n$tag OK Search done\r\n");
 814                 undef;
 815         }
 816 }
 817
 818 sub uid_search_uid_range { # long_response
 819         my ($self, $tag, $beg, $end) = @_;
 820         my $uids = $self->{ibx}->mm->msg_range($beg, $end, 'num');
 821         if (@$uids) {
 822                 $self->msg_more(join('', map { " $_->[0]" } @$uids));
 823         } else {
 824                 $self->write(\"\r\n$tag OK Search done\r\n");
 825                 undef;
 826         }
 827 }
 828
 829 sub date_search {
 830         my ($q, $k, $d) = @_;
 831         my $sql = $q->{sql};
 832
 833         # Date: header
 834         if ($k eq 'SENTON') {
 835                 my $end = $d + 86399; # no leap day...
 836                 my $da = strftime('%Y%m%d%H%M%S', gmtime($d));
 837                 my $db = strftime('%Y%m%d%H%M%S', gmtime($end));
 838                 $q->{xap} .= " dt:$da..$db";
 839                 $$sql .= " AND ds >= $d AND ds <= $end" if defined($sql);
 840         } elsif ($k eq 'SENTBEFORE') {
 841                 $q->{xap} .= ' d:..'.strftime('%Y%m%d', gmtime($d));
 842                 $$sql .= " AND ds <= $d" if defined($sql);
 843         } elsif ($k eq 'SENTSINCE') {
 844                 $q->{xap} .= ' d:'.strftime('%Y%m%d', gmtime($d)).'..';
 845                 $$sql .= " AND ds >= $d" if defined($sql);
 846
 847         # INTERNALDATE (Received)
 848         } elsif ($k eq 'ON') {
 849                 my $end = $d + 86399; # no leap day...
 850                 $q->{xap} .= " ts:$d..$end";
 851                 $$sql .= " AND ts >= $d AND ts <= $end" if defined($sql);
 852         } elsif ($k eq 'BEFORE') {
 853                 $q->{xap} .= " ts:..$d";
 854                 $$sql .= " AND ts <= $d" if defined($sql);
 855         } elsif ($k eq 'SINCE') {
 856                 $q->{xap} .= " ts:$d..";
 857                 $$sql .= " AND ts >= $d" if defined($sql);
 858         } else {
 859                 die "BUG: $k not recognized";
 860         }
 861 }
 862
 863 # IMAP to Xapian search key mapping
 864 my %I2X = (
 865         SUBJECT => 's:',
 866         BODY => 'b:',
 867         FROM => 'f:',
 868         TEXT => '', # n.b. does not include all headers
 869         TO => 't:',
 870         CC => 'c:',
 871         # BCC => 'bcc:', # TODO
 872         # KEYWORD # TODO ? dfpre,dfpost,...
 873 );
 874
 875 sub parse_query {
 876         my ($self, $rest) = @_;
 877         if (uc($rest->[0]) eq 'CHARSET') {
 878                 shift @$rest;
 879                 defined(my $c = shift @$rest) or return 'BAD missing charset';
 880                 $c =~ /\A(?:UTF-8|US-ASCII)\z/ or return 'NO [BADCHARSET]';
 881         }
 882
 883         my $sql = ''; # date conditions, {sql} deleted if Xapian is needed
 884         my $q = { xap => '', sql => \$sql };
 885         while (@$rest) {
 886                 my $k = uc(shift @$rest);
 887                 # default criteria
 888                 next if $k =~ /\A(?:ALL|RECENT|UNSEEN|NEW)\z/;
 889                 next if $k eq 'AND'; # the default, until we support OR
 890                 if ($k =~ $valid_range) { # sequence numbers == UIDs
 891                         push @{$q->{uid}}, $k;
 892                 } elsif ($k eq 'UID') {
 893                         $k = shift(@$rest) // '';
 894                         $k =~ $valid_range or return 'BAD UID range';
 895                         push @{$q->{uid}}, $k;
 896                 } elsif ($k =~ /\A(?:SENT)?(?:SINCE|ON|BEFORE)\z/) {
 897                         my $d = parse_date(shift(@$rest) // '');
 898                         defined $d or return "BAD $k date format";
 899                         date_search($q, $k, $d);
 900                 } elsif ($k =~ /\A(?:SMALLER|LARGER)\z/) {
 901                         delete $q->{sql}; # can't use over.sqlite3
 902                         my $bytes = shift(@$rest) // '';
 903                         $bytes =~ /\A[0-9]+\z/ or return "BAD $k not a number";
 904                         $q->{xap} .= ' bytes:' . ($k eq 'SMALLER' ?
 905                                                         '..'.(--$bytes) :
 906                                                         (++$bytes).'..');
 907                 } elsif (defined(my $xk = $I2X{$k})) {
 908                         delete $q->{sql}; # can't use over.sqlite3
 909                         my $arg = shift @$rest;
 910                         defined($arg) or return "BAD $k no arg";
 911
 912                         # Xapian can't handle [*"] in probabilistic terms
 913                         $arg =~ tr/*"//d;
 914                         $q->{xap} .= qq[ $xk:"$arg"];
 915                 } else {
 916                         # TODO: parentheses, OR, NOT ...
 917                         return "BAD $k not supported (yet?)";
 918                 }
 919         }
 920
 921         # favor using over.sqlite3 if possible, since Xapian is optional
 922         if (exists $q->{sql}) {
 923                 delete($q->{xap});
 924                 delete($q->{sql}) if $sql eq '';
 925         } elsif (!$self->{ibx}->search) {
 926                 return 'BAD Xapian not configured for mailbox';
 927         }
 928
 929         if (my $uid = $q->{uid}) {
 930                 ((@$uid > 1) || $uid->[0] =~ /,/) and
 931                         return 'BAD multiple ranges not supported, yet';
 932                 ($q->{sql} // $q->{xap}) and
 933                         return 'BAD ranges and queries do not mix, yet';
 934                 $q->{uid} = join(',', @$uid); # TODO: multiple ranges
 935         }
 936         $q;
 937 }
 938
 939 sub cmd_uid_search ($$$;) {
 940         my ($self, $tag) = splice(@_, 0, 2);
 941         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
 942         my $q = parse_query($self, \@_);
 943         return "$tag $q\r\n" if !ref($q);
 944
 945         if (!scalar(keys %$q)) {
 946                 $self->msg_more('* SEARCH');
 947                 my $num = 0;
 948                 long_response($self, \&uid_search_all, $tag, \$num);
 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                         $self->msg_more('* SEARCH');
 954                         long_response($self, \&uid_search_uid_range,
 955                                         $tag, \$beg, $end);
 956                 } elsif ($uid =~ /\A[0-9]+\z/s) {
 957                         $uid = $ibx->over->get_art($uid) ? " $uid" : '';
 958                         "* SEARCH$uid\r\n$tag OK Search done\r\n";
 959                 } else {
 960                         "$tag BAD Error\r\n";
 961                 }
 962         } else {
 963                 "$tag BAD Error\r\n";
 964         }
 965 }
 966
 967 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
 968         my ($cb, $argc) = @_;
 969         my $tot = prototype $cb;
 970         my ($nreq, undef) = split(';', $tot);
 971         $nreq = ($nreq =~ tr/$//) - 1;
 972         $tot = ($tot =~ tr/$//) - 1;
 973         ($argc <= $tot && $argc >= $nreq);
 974 }
 975
 976 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
 977 sub process_line ($$) {
 978         my ($self, $l) = @_;
 979         my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
 980         pop(@args) if (@args && !defined($args[-1]));
 981         if (@args && uc($req) eq 'UID') {
 982                 $req .= "_".(shift @args);
 983         }
 984         my $res = eval {
 985                 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
 986                         defined($self->{-idle_tag}) ?
 987                                 "$self->{-idle_tag} BAD expected DONE\r\n" :
 988                                 $cmd->($self, $tag, @args);
 989                 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
 990                         cmd_done($self, $tag);
 991                 } else { # this is weird
 992                         auth_challenge_ok($self) //
 993                                         ($tag // '*') .
 994                                         ' BAD Error in IMAP command '.
 995                                         ($req // '(???)').
 996                                         ": Unknown command\r\n";
 997                 }
 998         };
 999         my $err = $@;
1000         if ($err && $self->{sock}) {
1001                 $l =~ s/\r?\n//s;
1002                 err($self, 'error from: %s (%s)', $l, $err);
1003                 $tag //= '*';
1004                 $res = "$tag BAD program fault - command not performed\r\n";
1005         }
1006         return 0 unless defined $res;
1007         $self->write($res);
1008 }
1009
1010 sub long_step {
1011         my ($self) = @_;
1012         # wbuf is unset or empty, here; {long} may add to it
1013         my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
1014         my $more = eval { $cb->($self, @args) };
1015         if ($@ || !$self->{sock}) { # something bad happened...
1016                 delete $self->{long_cb};
1017                 my $elapsed = now() - $t0;
1018                 if ($@) {
1019                         err($self,
1020                             "%s during long response[$fd] - %0.6f",
1021                             $@, $elapsed);
1022                 }
1023                 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
1024                 $self->close;
1025         } elsif ($more) { # $self->{wbuf}:
1026                 $self->update_idle_time;
1027
1028                 # control passed to $more may be a GitAsyncCat object
1029                 requeue_once($self) if !ref($more);
1030         } else { # all done!
1031                 delete $self->{long_cb};
1032                 my $elapsed = now() - $t0;
1033                 my $fd = fileno($self->{sock});
1034                 out($self, " deferred[$fd] done - %0.6f", $elapsed);
1035                 my $wbuf = $self->{wbuf}; # do NOT autovivify
1036
1037                 $self->requeue unless $wbuf && @$wbuf;
1038         }
1039 }
1040
1041 sub err ($$;@) {
1042         my ($self, $fmt, @args) = @_;
1043         printf { $self->{imapd}->{err} } $fmt."\n", @args;
1044 }
1045
1046 sub out ($$;@) {
1047         my ($self, $fmt, @args) = @_;
1048         printf { $self->{imapd}->{out} } $fmt."\n", @args;
1049 }
1050
1051 sub long_response ($$;@) {
1052         my ($self, $cb, @args) = @_; # cb returns true if more, false if done
1053
1054         my $sock = $self->{sock} or return;
1055         # make sure we disable reading during a long response,
1056         # clients should not be sending us stuff and making us do more
1057         # work while we are stream a response to them
1058         $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
1059         long_step($self); # kick off!
1060         undef;
1061 }
1062
1063 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
1064 sub event_step {
1065         my ($self) = @_;
1066
1067         return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
1068
1069         $self->update_idle_time;
1070         # only read more requests if we've drained the write buffer,
1071         # otherwise we can be buffering infinitely w/o backpressure
1072
1073         my $rbuf = $self->{rbuf} // \(my $x = '');
1074         my $line = index($$rbuf, "\n");
1075         while ($line < 0) {
1076                 return $self->close if length($$rbuf) >= LINE_MAX;
1077                 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or return;
1078                 $line = index($$rbuf, "\n");
1079         }
1080         $line = substr($$rbuf, 0, $line + 1, '');
1081         $line =~ s/\r?\n\z//s;
1082         return $self->close if $line =~ /[[:cntrl:]]/s;
1083         my $t0 = now();
1084         my $fd = fileno($self->{sock});
1085         my $r = eval { process_line($self, $line) };
1086         my $pending = $self->{wbuf} ? ' pending' : '';
1087         out($self, "[$fd] %s - %0.6f$pending - $r", $line, now() - $t0);
1088
1089         return $self->close if $r < 0;
1090         $self->rbuf_idle($rbuf);
1091         $self->update_idle_time;
1092
1093         # maybe there's more pipelined data, or we'll have
1094         # to register it for socket-readiness notifications
1095         $self->requeue unless $pending;
1096 }
1097
1098 sub compressed { undef }
1099
1100 sub zflush {} # overridden by IMAPdeflate
1101
1102 # RFC 4978
1103 sub cmd_compress ($$$) {
1104         my ($self, $tag, $alg) = @_;
1105         return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
1106         return "$tag BAD COMPRESS active\r\n" if $self->compressed;
1107
1108         # CRIME made TLS compression obsolete
1109         # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
1110
1111         PublicInbox::IMAPdeflate->enable($self, $tag);
1112         $self->requeue;
1113         undef
1114 }
1115
1116 sub cmd_starttls ($$) {
1117         my ($self, $tag) = @_;
1118         my $sock = $self->{sock} or return;
1119         if ($sock->can('stop_SSL') || $self->compressed) {
1120                 return "$tag BAD TLS or compression already enabled\r\n";
1121         }
1122         my $opt = $self->{imapd}->{accept_tls} or
1123                 return "$tag BAD can not initiate TLS negotiation\r\n";
1124         $self->write(\"$tag OK begin TLS negotiation now\r\n");
1125         $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
1126         $self->requeue if PublicInbox::DS::accept_tls_step($self);
1127         undef;
1128 }
1129
1130 # for graceful shutdown in PublicInbox::Daemon:
1131 sub busy {
1132         my ($self, $now) = @_;
1133         ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
1134 }
1135
1136 sub close {
1137         my ($self) = @_;
1138         if (my $ibx = delete $self->{ibx}) {
1139                 if (my $sock = $self->{sock}) {;
1140                         $ibx->unsubscribe_unlock(fileno($sock));
1141                 }
1142         }
1143         $self->SUPER::close; # PublicInbox::DS::close
1144 }
1145
1146 # we're read-only, so SELECT and EXAMINE do the same thing
1147 no warnings 'once';
1148 *cmd_select = \&cmd_examine;
1149
1150 1;