1 # Copyright (C) 2020 all contributors <meta@public-inbox.org>
2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
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
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.
15 package PublicInbox::IMAP;
17 use base qw(PublicInbox::DS);
18 use fields qw(imapd logged_in ibx long_cb -login_tag
21 use PublicInbox::EmlContentFoo qw(parse_content_disposition);
22 use PublicInbox::DS qw(now);
23 use PublicInbox::Syscall qw(EPOLLIN EPOLLONESHOT);
24 use Text::ParseWords qw(parse_line);
27 for my $mod (qw(Email::Address::XS Mail::Address)) {
28 eval "require $mod" or next;
29 $Address = $mod and last;
31 die "neither Email::Address::XS nor Mail::Address loaded: $@" if !$Address;
33 sub LINE_MAX () { 512 } # does RFC 3501 have a limit like RFC 977?
35 my %FETCH_NEED_BLOB = ( # for future optimization
36 'BODY.PEEK[HEADER]' => 1,
37 'BODY.PEEK[TEXT]' => 1,
43 'RFC822.SIZE' => 1, # needs CRLF conversion :<
53 my %FETCH_ATT = map { $_ => [ $_ ] } keys %FETCH_NEED_BLOB;
55 # aliases (RFC 3501 section 6.4.5)
56 $FETCH_ATT{FAST} = [ qw(FLAGS INTERNALDATE RFC822.SIZE) ];
57 $FETCH_ATT{ALL} = [ @{$FETCH_ATT{FAST}}, 'ENVELOPE' ];
58 $FETCH_ATT{FULL} = [ @{$FETCH_ATT{ALL}}, 'BODY' ];
60 for my $att (keys %FETCH_ATT) {
61 my %h = map { $_ => 1 } @{$FETCH_ATT{$att}};
62 $FETCH_ATT{$att} = \%h;
67 my $capa = capa($self);
68 $self->write(\"* OK [$capa] public-inbox-imapd ready\r\n");
72 my ($class, $sock, $imapd) = @_;
73 my $self = fields::new($class);
76 if ($sock->can('accept_SSL') && !$sock->accept_SSL) {
77 return CORE::close($sock) if $! != EAGAIN;
78 $ev = PublicInbox::TLS::epollbit();
79 $wbuf = [ \&PublicInbox::DS::accept_tls_step, \&greet ];
81 $self->SUPER::new($sock, $ev | EPOLLONESHOT);
82 $self->{imapd} = $imapd;
84 $self->{wbuf} = $wbuf;
88 $self->update_idle_time;
95 # dovecot advertises IDLE pre-login; perhaps because some clients
96 # depend on it, so we'll do the same
97 my $capa = 'CAPABILITY IMAP4rev1 IDLE';
98 if ($self->{logged_in}) {
99 $capa .= ' COMPRESS=DEFLATE';
101 if (!($self->{sock} // $self)->can('accept_SSL') &&
102 $self->{imapd}->{accept_tls}) {
103 $capa .= ' STARTTLS';
105 $capa .= ' AUTH=ANONYMOUS';
109 sub login_success ($$) {
110 my ($self, $tag) = @_;
111 $self->{logged_in} = 1;
112 my $capa = capa($self);
113 "$tag OK [$capa] Logged in\r\n";
116 sub auth_challenge_ok ($) {
118 my $tag = delete($self->{-login_tag}) or return;
119 login_success($self, $tag);
122 sub cmd_login ($$$$) {
123 my ($self, $tag) = @_; # ignore ($user, $password) = ($_[2], $_[3])
124 login_success($self, $tag);
127 sub cmd_logout ($$) {
128 my ($self, $tag) = @_;
129 delete $self->{logged_in};
130 $self->write(\"* BYE logging out\r\n$tag OK Logout done\r\n");
131 $self->shutdn; # PublicInbox::DS::shutdn
135 sub cmd_authenticate ($$$) {
136 my ($self, $tag) = @_; # $method = $_[2], should be "ANONYMOUS"
137 $self->{-login_tag} = $tag;
141 sub cmd_capability ($$) {
142 my ($self, $tag) = @_;
143 '* '.capa($self)."\r\n$tag OK Capability done\r\n";
146 sub cmd_noop ($$) { "$_[1] OK Noop done\r\n" }
148 # called by PublicInbox::InboxIdle
149 sub on_inbox_unlock {
150 my ($self, $ibx) = @_;
151 my $new = $ibx->mm->max;
152 defined(my $old = $self->{-idle_max}) or die 'BUG: -idle_max unset';
154 $self->{-idle_max} = $new;
155 $self->msg_more("* $_ EXISTS\r\n") for (($old + 1)..($new - 1));
156 $self->write(\"* $new EXISTS\r\n");
161 my ($self, $tag) = @_;
162 # IDLE seems allowed by dovecot w/o a mailbox selected *shrug*
163 my $ibx = $self->{ibx} or return "$tag BAD no mailbox selected\r\n";
164 $ibx->subscribe_unlock(fileno($self->{sock}), $self);
165 $self->{imapd}->idler_start;
166 $self->{-idle_tag} = $tag;
167 $self->{-idle_max} = $ibx->mm->max // 0;
172 my ($self, $tag) = @_; # $tag is "DONE" (case-insensitive)
173 defined(my $idle_tag = delete $self->{-idle_tag}) or
174 return "$tag BAD not idle\r\n";
175 my $ibx = $self->{ibx} or do {
176 warn "BUG: idle_tag set w/o inbox";
177 return "$tag BAD internal bug\r\n";
179 $ibx->unsubscribe_unlock(fileno($self->{sock}));
180 "$idle_tag OK Idle done\r\n";
183 sub cmd_examine ($$$) {
184 my ($self, $tag, $mailbox) = @_;
185 my $ibx = $self->{imapd}->{groups}->{$mailbox} or
186 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
188 my $max = $mm->max // 0;
189 # RFC 3501 2.3.1.1 - "A good UIDVALIDITY value to use in
190 # this case is a 32-bit representation of the creation
191 # date/time of the mailbox"
192 my $uidvalidity = $mm->created_at or return "$tag BAD UIDVALIDITY\r\n";
193 my $uidnext = $max + 1;
195 # XXX: do we need this? RFC 5162/7162
196 my $ret = $self->{ibx} ? "* OK [CLOSED] previous closed\r\n" : '';
202 * OK [PERMANENTFLAGS ()] Read-only mailbox\r
204 $ret .= "* OK [UNSEEN $max]\r\n" if $max;
205 $ret .= "* OK [UIDNEXT $uidnext]\r\n" if defined $uidnext;
206 $ret .= "* OK [UIDVALIDITY $uidvalidity]\r\n" if defined $uidvalidity;
207 $ret .= "$tag OK [READ-ONLY] EXAMINE/SELECT done\r\n";
214 } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string
215 '{' . length($v) . "}\r\n" . $v;
216 } else { # quoted string
221 sub addr_envelope ($$;$) {
222 my ($eml, $x, $y) = @_;
223 my $v = $eml->header_raw($x) //
224 ($y ? $eml->header_raw($y) : undef) // return 'NIL';
226 my @x = $Address->parse($v) or return 'NIL';
228 map { '(' . join(' ',
229 _esc($_->name), 'NIL',
230 _esc($_->user), _esc($_->host)
236 sub eml_envelope ($) {
239 _esc($eml->header_raw('Date')),
240 _esc($eml->header_raw('Subject')),
241 addr_envelope($eml, 'From'),
242 addr_envelope($eml, 'Sender', 'From'),
243 addr_envelope($eml, 'Reply-To', 'From'),
244 addr_envelope($eml, 'To'),
245 addr_envelope($eml, 'Cc'),
246 addr_envelope($eml, 'Bcc'),
247 _esc($eml->header_raw('In-Reply-To')),
248 _esc($eml->header_raw('Message-ID')),
254 if ($hash && scalar keys %$hash) {
255 $hash = [ %$hash ]; # flatten hash into 1-dimensional array
256 '(' . join(' ', map { _esc($_) } @$hash) . ')';
262 sub body_disposition ($) {
264 my $cd = $eml->header_raw('Content-Disposition') or return 'NIL';
265 $cd = parse_content_disposition($cd);
266 my $buf = '('._esc($cd->{type});
267 $buf .= ' ' . _esc_hash(delete $cd->{attributes});
271 sub body_leaf ($$;$) {
272 my ($eml, $structure, $hold) = @_;
274 $eml->{is_submsg} and # parent was a message/(rfc822|news|global)
275 $buf .= eml_envelope($eml). ' ';
277 $buf .= '('._esc($ct->{type}).' ';
278 $buf .= _esc($ct->{subtype});
279 $buf .= ' ' . _esc_hash(delete $ct->{attributes});
280 $buf .= ' ' . _esc($eml->header_raw('Content-ID'));
281 $buf .= ' ' . _esc($eml->header_raw('Content-Description'));
282 my $cte = $eml->header_raw('Content-Transfer-Encoding') // '7bit';
283 $buf .= ' ' . _esc($cte);
284 $buf .= ' ' . $eml->{imap_body_len};
285 $buf .= ' '.($eml->body_raw =~ tr/\n/\n/) if lc($ct->{type}) eq 'text';
287 # for message/(rfc822|global|news), $hold[0] should have envelope
288 $buf .= ' ' . (@$hold ? join('', @$hold) : 'NIL') if $hold;
291 $buf .= ' '._esc($eml->header_raw('Content-MD5'));
292 $buf .= ' '. body_disposition($eml);
293 $buf .= ' '._esc($eml->header_raw('Content-Language'));
294 $buf .= ' '._esc($eml->header_raw('Content-Location'));
299 sub body_parent ($$$) {
300 my ($eml, $structure, $hold) = @_;
302 my $type = lc($ct->{type});
303 if ($type eq 'multipart') {
305 $buf .= @$hold ? join('', @$hold) : 'NIL';
306 $buf .= ' '._esc($ct->{subtype});
308 $buf .= ' '._esc_hash(delete $ct->{attributes});
309 $buf .= ' '.body_disposition($eml);
310 $buf .= ' '._esc($eml->header_raw('Content-Language'));
311 $buf .= ' '._esc($eml->header_raw('Content-Location'));
315 } else { # message/(rfc822|global|news)
316 @$hold = (body_leaf($eml, $structure, $hold));
320 # this is gross, but we need to process the parent part AFTER
321 # the child parts are done
322 sub bodystructure_prep {
324 my ($eml, $depth) = @$p; # ignore idx
325 # set length here, as $eml->{bdy} gets deleted for message/rfc822
326 $eml->{imap_body_len} = length($eml->body_raw);
327 push @$q, $eml, $depth;
330 # for FETCH BODY and FETCH BODYSTRUCTURE
331 sub fetch_body ($;$) {
332 my ($eml, $structure) = @_;
334 $eml->each_part(\&bodystructure_prep, \@q, 0, 1);
338 my ($part, $depth) = splice(@q, -2);
339 my $is_mp_parent = $depth == ($cur_depth - 1);
343 body_parent($part, $structure, \@hold);
345 unshift @hold, body_leaf($part, $structure);
351 sub dummy_message ($$) {
352 my ($seqno, $ibx) = @_;
354 From: nobody\@localhost\r
355 To: nobody\@localhost\r
356 Date: Thu, 01 Jan 1970 00:00:00 +0000\r
357 Message-ID: <dummy-$seqno\@$ibx->{newsgroup}>\r
358 Subject: dummy message #$seqno\r
360 You're seeing this message because your IMAP client didn't use UIDs.\r
361 The message which used to use this sequence number was likely spam\r
362 and removed by the administrator.\r
367 sub uid_fetch_cb { # called by git->cat_async
368 my ($bref, $oid, $type, $size, $fetch_m_arg) = @_;
369 my ($self, undef, $ibx, undef, undef, $msgs, $want) = @$fetch_m_arg;
370 my $smsg = shift @$msgs or die 'BUG: no smsg';
371 if (!defined($oid)) {
372 # it's possible to have TOCTOU if an admin runs
373 # public-inbox-(edit|purge), just move onto the next message
374 return unless defined $want->{-seqno};
375 $bref = dummy_message($smsg->{num}, $ibx);
377 $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid";
379 $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
381 # fixup old bug from import (pre-a0c07cba0e5d8b6a)
382 $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
384 $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
386 $want->{'RFC822.SIZE'} and
387 $self->msg_more(' RFC822.SIZE '.length($$bref));
388 $want->{INTERNALDATE} and
389 $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
390 $want->{FLAGS} and $self->msg_more(' FLAGS ()');
391 for ('RFC822', 'BODY[]', 'BODY.PEEK[]') {
392 next unless $want->{$_};
393 $self->msg_more(" $_ {".length($$bref)."}\r\n");
394 $self->msg_more($$bref);
397 my $eml = PublicInbox::Eml->new($bref);
399 $want->{ENVELOPE} and
400 $self->msg_more(' ENVELOPE '.eml_envelope($eml));
402 for my $f ('RFC822.HEADER', 'BODY[HEADER]', 'BODY.PEEK[HEADER]') {
403 next unless $want->{$f};
404 $self->msg_more(" $f {".length(${$eml->{hdr}})."}\r\n");
405 $self->msg_more(${$eml->{hdr}});
407 for my $f ('RFC822.TEXT', 'BODY[TEXT]') {
408 next unless $want->{$f};
409 $self->msg_more(" $f {".length($$bref)."}\r\n");
410 $self->msg_more($$bref);
412 $want->{BODYSTRUCTURE} and
413 $self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
415 $self->msg_more(' BODY '.fetch_body($eml));
416 if (my $partial = $want->{-partial}) {
417 partial_emit($self, $partial, $eml);
419 $self->msg_more(")\r\n");
422 sub uid_fetch_m { # long_response
423 my ($self, $tag, $ibx, $beg, $end, $msgs, $want) = @_;
424 if (!@$msgs) { # refill
425 @$msgs = @{$ibx->over->query_xover($$beg, $end)};
427 $self->write(\"$tag OK Fetch done\r\n");
430 $$beg = $msgs->[-1]->{num} + 1;
433 $git->cat_async_begin; # TODO: actually make async
434 $git->cat_async($msgs->[0]->{blob}, \&uid_fetch_cb, \@_);
435 $git->cat_async_wait;
439 sub cmd_status ($$$;@) {
440 my ($self, $tag, $mailbox, @items) = @_;
441 my $ibx = $self->{imapd}->{groups}->{$mailbox} or
442 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
443 return "$tag BAD no items\r\n" if !scalar(@items);
444 ($items[0] !~ s/\A\(//s || $items[-1] !~ s/\)\z//s) and
445 return "$tag BAD invalid args\r\n";
449 for my $it (@items) {
452 if ($it =~ /\A(?:MESSAGES|UNSEEN|RECENT)\z/) {
453 push(@it, ($max //= $mm->max // 0));
454 } elsif ($it eq 'UIDNEXT') {
455 push(@it, ($max //= $mm->max // 0) + 1);
456 } elsif ($it eq 'UIDVALIDITY') {
457 push(@it, $mm->created_at //
458 return("$tag BAD UIDVALIDITY\r\n"));
460 return "$tag BAD invalid item\r\n";
463 return "$tag BAD no items\r\n" if !@it;
464 "* STATUS $mailbox (".join(' ', @it).")\r\n" .
465 "$tag OK Status done\r\n";
468 my %patmap = ('*' => '.*', '%' => '[^\.]*');
469 sub cmd_list ($$$$) {
470 my ($self, $tag, $refname, $wildcard) = @_;
471 my $l = $self->{imapd}->{inboxlist};
472 if ($refname eq '' && $wildcard eq '') {
473 # request for hierarchy delimiter
474 $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
475 } elsif ($refname ne '' || $wildcard ne '*') {
476 $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eig;
477 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
479 \(join('', @$l, "$tag OK List done\r\n"));
482 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
484 my ($eml, undef, $idx) = @$p;
485 if ($idx && lc($eml->ct->{type}) eq 'multipart') {
486 $eml->{imap_bdy} = $eml->{bdy} // \'';
488 $all->{$idx} = $eml; # $idx => Eml
491 # prepares an index for BODY[$SECTION_IDX] fetches
492 sub eml_body_idx ($$) {
493 my ($eml, $section_idx) = @_;
494 my $idx = $eml->{imap_all_parts} //= do {
496 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
497 # top-level of multipart, BODY[0] not allowed (nz-number)
501 $idx->{$section_idx};
504 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
506 my ($eml, $section_idx, $section_name) = @_;
507 if (defined $section_idx) {
508 $eml = eml_body_idx($eml, $section_idx) or return;
510 if (defined $section_name) {
511 if ($section_name eq 'MIME') {
512 # RFC 3501 6.4.5 states:
513 # The MIME part specifier MUST be prefixed
514 # by one or more numeric part specifiers
515 return unless defined $section_idx;
516 return $eml->header_obj->as_string . "\r\n";
518 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
519 $eml = PublicInbox::Eml->new($$bdy);
520 if ($section_name eq 'TEXT') {
521 return $eml->body_raw;
522 } elsif ($section_name eq 'HEADER') {
523 return $eml->header_obj->as_string . "\r\n";
525 die "BUG: bad section_name=$section_name";
528 ${$eml->{bdy} // $eml->{imap_bdy} // \''};
531 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
532 # to avoid OOM with malicious users
533 sub hdrs_regexp ($) {
535 my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
536 qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
537 # continuation lines:
538 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
542 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
543 sub partial_hdr_not {
544 my ($eml, $section_idx, $hdrs) = @_;
545 if (defined $section_idx) {
546 $eml = eml_body_idx($eml, $section_idx) or return;
548 my $str = $eml->header_obj->as_string;
549 my $re = hdrs_regexp($hdrs);
554 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
555 sub partial_hdr_get {
556 my ($eml, $section_idx, $hdrs) = @_;
557 if (defined $section_idx) {
558 $eml = eml_body_idx($eml, $section_idx) or return;
560 my $str = $eml->header_obj->as_string;
561 my $re = hdrs_regexp($hdrs);
562 join('', ($str =~ m/($re)/g), "\r\n");
565 sub partial_prepare ($$$) {
566 my ($partial, $want, $att) = @_;
568 # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
569 # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
570 return unless $att =~ /\ABODY(?:\.PEEK)?\[/s;
571 until (rindex($att, ']') >= 0) {
572 my $next = shift @$want or return;
573 $att .= ' ' . uc($next);
575 if ($att =~ /\ABODY(?:\.PEEK)?\[
576 ([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
577 (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
578 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
579 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
580 } elsif ($att =~ /\ABODY(?:\.PEEK)?\[
581 (?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
582 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
583 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
584 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
585 $partial->{$att} = [ $2 ? \&partial_hdr_not
593 sub partial_emit ($$$) {
594 my ($self, $partial, $eml) = @_;
596 my ($k, $cb, @args) = @$_;
597 my ($offset, $len) = splice(@args, -2);
598 # $cb is partial_body|partial_hdr_get|partial_hdr_not
599 my $str = $cb->($eml, @args) // '';
600 if (defined $offset) {
602 $str = substr($str, $offset, $len);
603 $k =~ s/\.$len>\z/>/ or warn
604 "BUG: unable to remove `.$len>' from `$k'";
606 $str = substr($str, $offset);
612 $self->msg_more(" $k {$len}\r\n");
613 $self->msg_more($str);
617 sub fetch_common ($$$$) {
618 my ($self, $tag, $range, $want) = @_;
619 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
620 if ($want->[0] =~ s/\A\(//s) {
621 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
623 my (%partial, %want);
624 while (defined(my $att = shift @$want)) {
626 my $x = $FETCH_ATT{$att};
628 %want = (%want, %$x);
629 } elsif (!partial_prepare(\%partial, $want, $att)) {
630 return "$tag BAD param: $att\r\n";
634 # stabilize partial order for consistency and ease-of-debugging:
635 if (scalar keys %partial) {
636 $want{-partial} = [ map {
637 [ $_, @{$partial{$_}} ]
638 } sort keys %partial ];
643 if ($range =~ /\A([0-9]+):([0-9]+)\z/s) {
644 ($beg, $end) = ($1, $2);
645 } elsif ($range =~ /\A([0-9]+):\*\z/s) {
646 ($beg, $end) = ($1, $ibx->mm->max // 0);
647 } elsif ($range =~ /\A[0-9]+\z/) {
648 my $smsg = $ibx->over->get_art($range) or
649 return "$tag OK Fetch done\r\n"; # really OK(!)
651 ($beg, $end) = ($range, 0);
653 return "$tag BAD fetch range\r\n";
655 [ $tag, $ibx, \$beg, $end, $msgs, \%want ];
658 sub cmd_uid_fetch ($$$;@) {
659 my ($self, $tag, $range, @want) = @_;
660 my $args = fetch_common($self, $tag, $range, \@want);
661 ref($args) eq 'ARRAY' ?
662 long_response($self, \&uid_fetch_m, @$args) :
666 sub seq_fetch_m { # long_response
667 my ($self, $tag, $ibx, $beg, $end, $msgs, $want) = @_;
668 if (!@$msgs) { # refill
669 @$msgs = @{$ibx->over->query_xover($$beg, $end)};
671 $self->write(\"$tag OK Fetch done\r\n");
674 $$beg = $msgs->[-1]->{num} + 1;
676 my $seq = $want->{-seqno}++;
677 my $cur_num = $msgs->[0]->{num};
678 if ($cur_num == $seq) { # as expected
680 $git->cat_async_begin; # TODO: actually make async
681 $git->cat_async($msgs->[0]->{blob}, \&uid_fetch_cb, \@_);
682 $git->cat_async_wait;
683 } elsif ($cur_num > $seq) {
684 # send dummy messages until $seq catches up to $cur_num
685 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
686 unshift @$msgs, $smsg;
687 my $bref = dummy_message($seq, $ibx);
688 uid_fetch_cb($bref, undef, undef, undef, \@_);
689 } else { # should not happen
690 die "BUG: cur_num=$cur_num < seq=$seq";
692 1; # more messages on the way
695 sub cmd_fetch ($$$;@) {
696 my ($self, $tag, $range, @want) = @_;
697 my $args = fetch_common($self, $tag, $range, \@want);
698 ref($args) eq 'ARRAY' ? do {
699 my $want = $args->[-1];
700 $want->{-seqno} = ${$args->[2]}; # $$beg
701 long_response($self, \&seq_fetch_m, @$args)
705 sub uid_search_all { # long_response
706 my ($self, $tag, $ibx, $num) = @_;
707 my $uids = $ibx->mm->ids_after($num);
708 if (scalar(@$uids)) {
709 $self->msg_more(join(' ', '', @$uids));
711 $self->write(\"\r\n$tag OK Search done\r\n");
716 sub uid_search_uid_range { # long_response
717 my ($self, $tag, $ibx, $beg, $end) = @_;
718 my $uids = $ibx->mm->msg_range($beg, $end, 'num');
720 $self->msg_more(join('', map { " $_->[0]" } @$uids));
722 $self->write(\"\r\n$tag OK Search done\r\n");
727 sub cmd_uid_search ($$$;) {
728 my ($self, $tag, $arg, @rest) = @_;
729 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
731 if ($arg eq 'ALL' && !@rest) {
732 $self->msg_more('* SEARCH');
734 long_response($self, \&uid_search_all, $tag, $ibx, \$num);
735 } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
736 if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
737 my ($beg, $end) = ($1, $2);
738 $end = $ibx->mm->max if $end eq '*';
739 $self->msg_more('* SEARCH');
740 long_response($self, \&uid_search_uid_range,
741 $tag, $ibx, \$beg, $end);
742 } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
744 $uid = $ibx->over->get_art($uid) ? " $uid" : '';
745 "* SEARCH$uid\r\n$tag OK Search done\r\n";
747 "$tag BAD Error\r\n";
750 "$tag BAD Error\r\n";
754 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
755 my ($cb, $argc) = @_;
756 my $tot = prototype $cb;
757 my ($nreq, undef) = split(';', $tot);
758 $nreq = ($nreq =~ tr/$//) - 1;
759 $tot = ($tot =~ tr/$//) - 1;
760 ($argc <= $tot && $argc >= $nreq);
763 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
764 sub process_line ($$) {
766 my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
767 pop(@args) if (@args && !defined($args[-1]));
768 if (@args && uc($req) eq 'UID') {
769 $req .= "_".(shift @args);
772 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
773 defined($self->{-idle_tag}) ?
774 "$self->{-idle_tag} BAD expected DONE\r\n" :
775 $cmd->($self, $tag, @args);
776 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
777 cmd_done($self, $tag);
778 } else { # this is weird
779 auth_challenge_ok($self) //
780 "$tag BAD Error in IMAP command $req: ".
781 "Unknown command\r\n";
785 if ($err && $self->{sock}) {
787 err($self, 'error from: %s (%s)', $l, $err);
788 $res = "$tag BAD program fault - command not performed\r\n";
790 return 0 unless defined $res;
796 # wbuf is unset or empty, here; {long} may add to it
797 my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
798 my $more = eval { $cb->($self, @args) };
799 if ($@ || !$self->{sock}) { # something bad happened...
800 delete $self->{long_cb};
801 my $elapsed = now() - $t0;
804 "%s during long response[$fd] - %0.6f",
807 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
809 } elsif ($more) { # $self->{wbuf}:
810 $self->update_idle_time;
812 # COMPRESS users all share the same DEFLATE context.
813 # Flush it here to ensure clients don't see
817 # no recursion, schedule another call ASAP, but only after
818 # all pending writes are done. autovivify wbuf:
819 my $new_size = push(@{$self->{wbuf}}, \&long_step);
821 # wbuf may be populated by $cb, no need to rearm if so:
822 $self->requeue if $new_size == 1;
824 delete $self->{long_cb};
825 my $elapsed = now() - $t0;
826 my $fd = fileno($self->{sock});
827 out($self, " deferred[$fd] done - %0.6f", $elapsed);
828 my $wbuf = $self->{wbuf}; # do NOT autovivify
830 $self->requeue unless $wbuf && @$wbuf;
835 my ($self, $fmt, @args) = @_;
836 printf { $self->{imapd}->{err} } $fmt."\n", @args;
840 my ($self, $fmt, @args) = @_;
841 printf { $self->{imapd}->{out} } $fmt."\n", @args;
844 sub long_response ($$;@) {
845 my ($self, $cb, @args) = @_; # cb returns true if more, false if done
847 my $sock = $self->{sock} or return;
848 # make sure we disable reading during a long response,
849 # clients should not be sending us stuff and making us do more
850 # work while we are stream a response to them
851 $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
852 long_step($self); # kick off!
856 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
860 return unless $self->flush_write && $self->{sock};
862 $self->update_idle_time;
863 # only read more requests if we've drained the write buffer,
864 # otherwise we can be buffering infinitely w/o backpressure
866 my $rbuf = $self->{rbuf} // (\(my $x = ''));
869 if (index($$rbuf, "\n") < 0) {
870 my $off = length($$rbuf);
871 $r = $self->do_read($rbuf, LINE_MAX, $off) or return;
873 while ($r > 0 && $$rbuf =~ s/\A[ \t]*([^\n]*?)\r?\n//) {
875 return $self->close if $line =~ /[[:cntrl:]]/s;
877 my $fd = fileno($self->{sock});
878 $r = eval { process_line($self, $line) };
879 my $pending = $self->{wbuf} ? ' pending' : '';
880 out($self, "[$fd] %s - %0.6f$pending", $line, now() - $t0);
883 return $self->close if $r < 0;
884 my $len = length($$rbuf);
885 return $self->close if ($len >= LINE_MAX);
886 $self->rbuf_idle($rbuf);
887 $self->update_idle_time;
889 # maybe there's more pipelined data, or we'll have
890 # to register it for socket-readiness notifications
891 $self->requeue unless $self->{wbuf};
894 sub compressed { undef }
896 sub zflush {} # overridden by IMAPdeflate
899 sub cmd_compress ($$$) {
900 my ($self, $tag, $alg) = @_;
901 return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
902 return "$tag BAD COMPRESS active\r\n" if $self->compressed;
904 # CRIME made TLS compression obsolete
905 # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
907 PublicInbox::IMAPdeflate->enable($self, $tag);
912 sub cmd_starttls ($$) {
913 my ($self, $tag) = @_;
914 my $sock = $self->{sock} or return;
915 if ($sock->can('stop_SSL') || $self->compressed) {
916 return "$tag BAD TLS or compression already enabled\r\n";
918 my $opt = $self->{imapd}->{accept_tls} or
919 return "$tag BAD can not initiate TLS negotiation\r\n";
920 $self->write(\"$tag OK begin TLS negotiation now\r\n");
921 $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
922 $self->requeue if PublicInbox::DS::accept_tls_step($self);
926 # for graceful shutdown in PublicInbox::Daemon:
928 my ($self, $now) = @_;
929 ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
934 if (my $ibx = delete $self->{ibx}) {
935 if (my $sock = $self->{sock}) {;
936 $ibx->unsubscribe_unlock(fileno($sock));
939 $self->SUPER::close; # PublicInbox::DS::close
942 # we're read-only, so SELECT and EXAMINE do the same thing
944 *cmd_select = \&cmd_examine;