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