lib/PublicInbox/IMAP.pm

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