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