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