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