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