lib/PublicInbox/IMAP.pm

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