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