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