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_re) = @_;
 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         $str =~ s/$hdrs_re//g;
 553         $str .= "\r\n";
 554 }
 555
 556 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
 557 sub partial_hdr_get {
 558         my ($eml, $section_idx, $hdrs_re) = @_;
 559         if (defined $section_idx) {
 560                 $eml = eml_body_idx($eml, $section_idx) or return;
 561         }
 562         my $str = $eml->header_obj->as_string;
 563         join('', ($str =~ m/($hdrs_re)/g), "\r\n");
 564 }
 565
 566 sub partial_prepare ($$$) {
 567         my ($partial, $want, $att) = @_;
 568
 569         # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
 570         # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
 571         return unless $att =~ /\ABODY\[/s;
 572         until (rindex($att, ']') >= 0) {
 573                 my $next = shift @$want or return;
 574                 $att .= ' ' . uc($next);
 575         }
 576         if ($att =~ /\ABODY\[([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
 577                         (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
 578                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
 579                 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
 580         } elsif ($att =~ /\ABODY\[(?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
 581                                 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
 582                                 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
 583                         \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
 584                 my $tmp = $partial->{$att} = [ $2 ? \&partial_hdr_not
 585                                                 : \&partial_hdr_get,
 586                                                 $1, undef, $4, $5 ];
 587                 $tmp->[2] = hdrs_regexp($3);
 588         } else {
 589                 undef;
 590         }
 591 }
 592
 593 sub partial_emit ($$$) {
 594         my ($self, $partial, $eml) = @_;
 595         for (@$partial) {
 596                 my ($k, $cb, @args) = @$_;
 597                 my ($offset, $len) = splice(@args, -2);
 598                 # $cb is partial_body|partial_hdr_get|partial_hdr_not
 599                 my $str = $cb->($eml, @args) // '';
 600                 if (defined $offset) {
 601                         if (defined $len) {
 602                                 $str = substr($str, $offset, $len);
 603                                 $k =~ s/\.$len>\z/>/ or warn
 604 "BUG: unable to remove `.$len>' from `$k'";
 605                         } else {
 606                                 $str = substr($str, $offset);
 607                                 $len = length($str);
 608                         }
 609                 } else {
 610                         $len = length($str);
 611                 }
 612                 $self->msg_more(" $k {$len}\r\n");
 613                 $self->msg_more($str);
 614         }
 615 }
 616
 617 sub fetch_common ($$$$) {
 618         my ($self, $tag, $range, $want) = @_;
 619         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
 620         if ($want->[0] =~ s/\A\(//s) {
 621                 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
 622         }
 623         my (%partial, %want);
 624         while (defined(my $att = shift @$want)) {
 625                 $att = uc($att);
 626                 $att =~ s/\ABODY\.PEEK\[/BODY\[/; # we're read-only
 627                 my $x = $FETCH_ATT{$att};
 628                 if ($x) {
 629                         %want = (%want, %$x);
 630                 } elsif (!partial_prepare(\%partial, $want, $att)) {
 631                         return "$tag BAD param: $att\r\n";
 632                 }
 633         }
 634
 635         # stabilize partial order for consistency and ease-of-debugging:
 636         if (scalar keys %partial) {
 637                 $want{-partial} = [ map {;
 638                         [ $_, @{$partial{$_}} ]
 639                 } sort keys %partial ];
 640         }
 641
 642         my ($beg, $end);
 643         my $msgs = [];
 644         if ($range =~ /\A([0-9]+):([0-9]+)\z/s) {
 645                 ($beg, $end) = ($1, $2);
 646         } elsif ($range =~ /\A([0-9]+):\*\z/s) {
 647                 ($beg, $end) =  ($1, $ibx->mm->max // 0);
 648         } elsif ($range =~ /\A[0-9]+\z/) {
 649                 my $smsg = $ibx->over->get_art($range) or
 650                         return "$tag OK Fetch done\r\n"; # really OK(!)
 651                 push @$msgs, $smsg;
 652                 ($beg, $end) = ($range, 0);
 653         } else {
 654                 return "$tag BAD fetch range\r\n";
 655         }
 656         [ $tag, $ibx, \$beg, $end, $msgs, \%want ];
 657 }
 658
 659 sub cmd_uid_fetch ($$$;@) {
 660         my ($self, $tag, $range, @want) = @_;
 661         my $args = fetch_common($self, $tag, $range, \@want);
 662         ref($args) eq 'ARRAY' ?
 663                 long_response($self, \&uid_fetch_m, @$args) :
 664                 $args; # error
 665 }
 666
 667 sub seq_fetch_m { # long_response
 668         my ($self, $tag, $ibx, $beg, $end, $msgs, $want) = @_;
 669         if (!@$msgs) { # refill
 670                 @$msgs = @{$ibx->over->query_xover($$beg, $end)};
 671                 if (!@$msgs) {
 672                         $self->write(\"$tag OK Fetch done\r\n");
 673                         return;
 674                 }
 675                 $$beg = $msgs->[-1]->{num} + 1;
 676         }
 677         my $seq = $want->{-seqno}++;
 678         my $cur_num = $msgs->[0]->{num};
 679         if ($cur_num == $seq) { # as expected
 680                 my $git = $ibx->git;
 681                 $git->cat_async_begin; # TODO: actually make async
 682                 $git->cat_async($msgs->[0]->{blob}, \&uid_fetch_cb, \@_);
 683                 $git->cat_async_wait;
 684         } elsif ($cur_num > $seq) {
 685                 # send dummy messages until $seq catches up to $cur_num
 686                 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
 687                 unshift @$msgs, $smsg;
 688                 my $bref = dummy_message($seq, $ibx);
 689                 uid_fetch_cb($bref, undef, undef, undef, \@_);
 690         } else { # should not happen
 691                 die "BUG: cur_num=$cur_num < seq=$seq";
 692         }
 693         1; # more messages on the way
 694 }
 695
 696 sub cmd_fetch ($$$;@) {
 697         my ($self, $tag, $range, @want) = @_;
 698         my $args = fetch_common($self, $tag, $range, \@want);
 699         ref($args) eq 'ARRAY' ? do {
 700                 my $want = $args->[-1];
 701                 $want->{-seqno} = ${$args->[2]}; # $$beg
 702                 long_response($self, \&seq_fetch_m, @$args)
 703         } : $args; # error
 704 }
 705
 706 sub uid_search_all { # long_response
 707         my ($self, $tag, $ibx, $num) = @_;
 708         my $uids = $ibx->mm->ids_after($num);
 709         if (scalar(@$uids)) {
 710                 $self->msg_more(join(' ', '', @$uids));
 711         } else {
 712                 $self->write(\"\r\n$tag OK Search done\r\n");
 713                 undef;
 714         }
 715 }
 716
 717 sub uid_search_uid_range { # long_response
 718         my ($self, $tag, $ibx, $beg, $end) = @_;
 719         my $uids = $ibx->mm->msg_range($beg, $end, 'num');
 720         if (@$uids) {
 721                 $self->msg_more(join('', map { " $_->[0]" } @$uids));
 722         } else {
 723                 $self->write(\"\r\n$tag OK Search done\r\n");
 724                 undef;
 725         }
 726 }
 727
 728 sub cmd_uid_search ($$$;) {
 729         my ($self, $tag, $arg, @rest) = @_;
 730         my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
 731         $arg = uc($arg);
 732         if ($arg eq 'ALL' && !@rest) {
 733                 $self->msg_more('* SEARCH');
 734                 my $num = 0;
 735                 long_response($self, \&uid_search_all, $tag, $ibx, \$num);
 736         } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
 737                 if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
 738                         my ($beg, $end) = ($1, $2);
 739                         $end = $ibx->mm->max if $end eq '*';
 740                         $self->msg_more('* SEARCH');
 741                         long_response($self, \&uid_search_uid_range,
 742                                         $tag, $ibx, \$beg, $end);
 743                 } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
 744                         my $uid = $rest[0];
 745                         $uid = $ibx->over->get_art($uid) ? " $uid" : '';
 746                         "* SEARCH$uid\r\n$tag OK Search done\r\n";
 747                 } else {
 748                         "$tag BAD Error\r\n";
 749                 }
 750         } else {
 751                 "$tag BAD Error\r\n";
 752         }
 753 }
 754
 755 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
 756         my ($cb, $argc) = @_;
 757         my $tot = prototype $cb;
 758         my ($nreq, undef) = split(';', $tot);
 759         $nreq = ($nreq =~ tr/$//) - 1;
 760         $tot = ($tot =~ tr/$//) - 1;
 761         ($argc <= $tot && $argc >= $nreq);
 762 }
 763
 764 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
 765 sub process_line ($$) {
 766         my ($self, $l) = @_;
 767         my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
 768         pop(@args) if (@args && !defined($args[-1]));
 769         if (@args && uc($req) eq 'UID') {
 770                 $req .= "_".(shift @args);
 771         }
 772         my $res = eval {
 773                 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
 774                         defined($self->{-idle_tag}) ?
 775                                 "$self->{-idle_tag} BAD expected DONE\r\n" :
 776                                 $cmd->($self, $tag, @args);
 777                 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
 778                         cmd_done($self, $tag);
 779                 } else { # this is weird
 780                         auth_challenge_ok($self) //
 781                                 "$tag BAD Error in IMAP command $req: ".
 782                                 "Unknown command\r\n";
 783                 }
 784         };
 785         my $err = $@;
 786         if ($err && $self->{sock}) {
 787                 $l =~ s/\r?\n//s;
 788                 err($self, 'error from: %s (%s)', $l, $err);
 789                 $res = "$tag BAD program fault - command not performed\r\n";
 790         }
 791         return 0 unless defined $res;
 792         $self->write($res);
 793 }
 794
 795 sub long_step {
 796         my ($self) = @_;
 797         # wbuf is unset or empty, here; {long} may add to it
 798         my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
 799         my $more = eval { $cb->($self, @args) };
 800         if ($@ || !$self->{sock}) { # something bad happened...
 801                 delete $self->{long_cb};
 802                 my $elapsed = now() - $t0;
 803                 if ($@) {
 804                         err($self,
 805                             "%s during long response[$fd] - %0.6f",
 806                             $@, $elapsed);
 807                 }
 808                 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
 809                 $self->close;
 810         } elsif ($more) { # $self->{wbuf}:
 811                 $self->update_idle_time;
 812
 813                 # COMPRESS users all share the same DEFLATE context.
 814                 # Flush it here to ensure clients don't see
 815                 # each other's data
 816                 $self->zflush;
 817
 818                 # no recursion, schedule another call ASAP, but only after
 819                 # all pending writes are done.  autovivify wbuf:
 820                 my $new_size = push(@{$self->{wbuf}}, \&long_step);
 821
 822                 # wbuf may be populated by $cb, no need to rearm if so:
 823                 $self->requeue if $new_size == 1;
 824         } else { # all done!
 825                 delete $self->{long_cb};
 826                 my $elapsed = now() - $t0;
 827                 my $fd = fileno($self->{sock});
 828                 out($self, " deferred[$fd] done - %0.6f", $elapsed);
 829                 my $wbuf = $self->{wbuf}; # do NOT autovivify
 830
 831                 $self->requeue unless $wbuf && @$wbuf;
 832         }
 833 }
 834
 835 sub err ($$;@) {
 836         my ($self, $fmt, @args) = @_;
 837         printf { $self->{imapd}->{err} } $fmt."\n", @args;
 838 }
 839
 840 sub out ($$;@) {
 841         my ($self, $fmt, @args) = @_;
 842         printf { $self->{imapd}->{out} } $fmt."\n", @args;
 843 }
 844
 845 sub long_response ($$;@) {
 846         my ($self, $cb, @args) = @_; # cb returns true if more, false if done
 847
 848         my $sock = $self->{sock} or return;
 849         # make sure we disable reading during a long response,
 850         # clients should not be sending us stuff and making us do more
 851         # work while we are stream a response to them
 852         $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
 853         long_step($self); # kick off!
 854         undef;
 855 }
 856
 857 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
 858 sub event_step {
 859         my ($self) = @_;
 860
 861         return unless $self->flush_write && $self->{sock};
 862
 863         $self->update_idle_time;
 864         # only read more requests if we've drained the write buffer,
 865         # otherwise we can be buffering infinitely w/o backpressure
 866
 867         my $rbuf = $self->{rbuf} // (\(my $x = ''));
 868         my $r = 1;
 869
 870         if (index($$rbuf, "\n") < 0) {
 871                 my $off = length($$rbuf);
 872                 $r = $self->do_read($rbuf, LINE_MAX, $off) or return;
 873         }
 874         while ($r > 0 && $$rbuf =~ s/\A[ \t]*([^\n]*?)\r?\n//) {
 875                 my $line = $1;
 876                 return $self->close if $line =~ /[[:cntrl:]]/s;
 877                 my $t0 = now();
 878                 my $fd = fileno($self->{sock});
 879                 $r = eval { process_line($self, $line) };
 880                 my $pending = $self->{wbuf} ? ' pending' : '';
 881                 out($self, "[$fd] %s - %0.6f$pending", $line, now() - $t0);
 882         }
 883
 884         return $self->close if $r < 0;
 885         my $len = length($$rbuf);
 886         return $self->close if ($len >= LINE_MAX);
 887         $self->rbuf_idle($rbuf);
 888         $self->update_idle_time;
 889
 890         # maybe there's more pipelined data, or we'll have
 891         # to register it for socket-readiness notifications
 892         $self->requeue unless $self->{wbuf};
 893 }
 894
 895 sub compressed { undef }
 896
 897 sub zflush {} # overridden by IMAPdeflate
 898
 899 # RFC 4978
 900 sub cmd_compress ($$$) {
 901         my ($self, $tag, $alg) = @_;
 902         return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
 903         return "$tag BAD COMPRESS active\r\n" if $self->compressed;
 904
 905         # CRIME made TLS compression obsolete
 906         # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
 907
 908         PublicInbox::IMAPdeflate->enable($self, $tag);
 909         $self->requeue;
 910         undef
 911 }
 912
 913 sub cmd_starttls ($$) {
 914         my ($self, $tag) = @_;
 915         my $sock = $self->{sock} or return;
 916         if ($sock->can('stop_SSL') || $self->compressed) {
 917                 return "$tag BAD TLS or compression already enabled\r\n";
 918         }
 919         my $opt = $self->{imapd}->{accept_tls} or
 920                 return "$tag BAD can not initiate TLS negotiation\r\n";
 921         $self->write(\"$tag OK begin TLS negotiation now\r\n");
 922         $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
 923         $self->requeue if PublicInbox::DS::accept_tls_step($self);
 924         undef;
 925 }
 926
 927 # for graceful shutdown in PublicInbox::Daemon:
 928 sub busy {
 929         my ($self, $now) = @_;
 930         ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
 931 }
 932
 933 sub close {
 934         my ($self) = @_;
 935         if (my $ibx = delete $self->{ibx}) {
 936                 if (my $sock = $self->{sock}) {;
 937                         $ibx->unsubscribe_unlock(fileno($sock));
 938                 }
 939         }
 940         $self->SUPER::close; # PublicInbox::DS::close
 941 }
 942
 943 # we're read-only, so SELECT and EXAMINE do the same thing
 944 no warnings 'once';
 945 *cmd_select = \&cmd_examine;
 946
 947 1;