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 PublicInbox::GitAsyncCat;
25 use Text::ParseWords qw(parse_line);
29 for my $mod (qw(Email::Address::XS Mail::Address)) {
30 eval "require $mod" or next;
31 $Address = $mod and last;
33 die "neither Email::Address::XS nor Mail::Address loaded: $@" if !$Address;
35 sub LINE_MAX () { 512 } # does RFC 3501 have a limit like RFC 977?
37 my %FETCH_NEED_BLOB = ( # for future optimization
42 'RFC822.SIZE' => 1, # needs CRLF conversion :<
52 my %FETCH_ATT = map { $_ => [ $_ ] } keys %FETCH_NEED_BLOB;
54 # aliases (RFC 3501 section 6.4.5)
55 $FETCH_ATT{FAST} = [ qw(FLAGS INTERNALDATE RFC822.SIZE) ];
56 $FETCH_ATT{ALL} = [ @{$FETCH_ATT{FAST}}, 'ENVELOPE' ];
57 $FETCH_ATT{FULL} = [ @{$FETCH_ATT{ALL}}, 'BODY' ];
59 for my $att (keys %FETCH_ATT) {
60 my %h = map { $_ => 1 } @{$FETCH_ATT{$att}};
61 $FETCH_ATT{$att} = \%h;
64 my $valid_range = '[0-9]+|[0-9]+:[0-9]+|[0-9]+:\*';
65 $valid_range = qr/\A(?:$valid_range)(?:,(?:$valid_range))*\z/;
69 my $capa = capa($self);
70 $self->write(\"* OK [$capa] public-inbox-imapd ready\r\n");
74 my ($class, $sock, $imapd) = @_;
75 my $self = fields::new($class);
78 if ($sock->can('accept_SSL') && !$sock->accept_SSL) {
79 return CORE::close($sock) if $! != EAGAIN;
80 $ev = PublicInbox::TLS::epollbit();
81 $wbuf = [ \&PublicInbox::DS::accept_tls_step, \&greet ];
83 $self->SUPER::new($sock, $ev | EPOLLONESHOT);
84 $self->{imapd} = $imapd;
86 $self->{wbuf} = $wbuf;
90 $self->update_idle_time;
97 # dovecot advertises IDLE pre-login; perhaps because some clients
98 # depend on it, so we'll do the same
99 my $capa = 'CAPABILITY IMAP4rev1 IDLE';
100 if ($self->{logged_in}) {
101 $capa .= ' COMPRESS=DEFLATE';
103 if (!($self->{sock} // $self)->can('accept_SSL') &&
104 $self->{imapd}->{accept_tls}) {
105 $capa .= ' STARTTLS';
107 $capa .= ' AUTH=ANONYMOUS';
111 sub login_success ($$) {
112 my ($self, $tag) = @_;
113 $self->{logged_in} = 1;
114 my $capa = capa($self);
115 "$tag OK [$capa] Logged in\r\n";
118 sub auth_challenge_ok ($) {
120 my $tag = delete($self->{-login_tag}) or return;
121 login_success($self, $tag);
124 sub cmd_login ($$$$) {
125 my ($self, $tag) = @_; # ignore ($user, $password) = ($_[2], $_[3])
126 login_success($self, $tag);
130 my ($self, $tag) = @_;
131 delete $self->{ibx} ? "$tag OK Close done\r\n"
132 : "$tag BAD No mailbox\r\n";
135 sub cmd_logout ($$) {
136 my ($self, $tag) = @_;
137 delete $self->{logged_in};
138 $self->write(\"* BYE logging out\r\n$tag OK Logout done\r\n");
139 $self->shutdn; # PublicInbox::DS::shutdn
143 sub cmd_authenticate ($$$) {
144 my ($self, $tag) = @_; # $method = $_[2], should be "ANONYMOUS"
145 $self->{-login_tag} = $tag;
149 sub cmd_capability ($$) {
150 my ($self, $tag) = @_;
151 '* '.capa($self)."\r\n$tag OK Capability done\r\n";
154 sub cmd_noop ($$) { "$_[1] OK Noop done\r\n" }
156 # called by PublicInbox::InboxIdle
157 sub on_inbox_unlock {
158 my ($self, $ibx) = @_;
159 my $new = $ibx->mm->max;
160 defined(my $old = $self->{-idle_max}) or die 'BUG: -idle_max unset';
162 $self->{-idle_max} = $new;
163 $self->msg_more("* $_ EXISTS\r\n") for (($old + 1)..($new - 1));
164 $self->write(\"* $new EXISTS\r\n");
169 my ($self, $tag) = @_;
170 # IDLE seems allowed by dovecot w/o a mailbox selected *shrug*
171 my $ibx = $self->{ibx} or return "$tag BAD no mailbox selected\r\n";
172 $ibx->subscribe_unlock(fileno($self->{sock}), $self);
173 $self->{imapd}->idler_start;
174 $self->{-idle_tag} = $tag;
175 $self->{-idle_max} = $ibx->mm->max // 0;
180 my ($self, $tag) = @_; # $tag is "DONE" (case-insensitive)
181 defined(my $idle_tag = delete $self->{-idle_tag}) or
182 return "$tag BAD not idle\r\n";
183 my $ibx = $self->{ibx} or do {
184 warn "BUG: idle_tag set w/o inbox";
185 return "$tag BAD internal bug\r\n";
187 $ibx->unsubscribe_unlock(fileno($self->{sock}));
188 "$idle_tag OK Idle done\r\n";
191 sub cmd_examine ($$$) {
192 my ($self, $tag, $mailbox) = @_;
193 my $ibx = $self->{imapd}->{groups}->{$mailbox} or
194 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
196 my $max = $mm->max // 0;
197 # RFC 3501 2.3.1.1 - "A good UIDVALIDITY value to use in
198 # this case is a 32-bit representation of the creation
199 # date/time of the mailbox"
200 my $uidvalidity = $mm->created_at or return "$tag BAD UIDVALIDITY\r\n";
201 my $uidnext = $max + 1;
203 # XXX: do we need this? RFC 5162/7162
204 my $ret = $self->{ibx} ? "* OK [CLOSED] previous closed\r\n" : '';
210 * OK [PERMANENTFLAGS ()] Read-only mailbox\r
212 $ret .= "* OK [UNSEEN $max]\r\n" if $max;
213 $ret .= "* OK [UIDNEXT $uidnext]\r\n" if defined $uidnext;
214 $ret .= "* OK [UIDVALIDITY $uidvalidity]\r\n" if defined $uidvalidity;
215 $ret .= "$tag OK [READ-ONLY] EXAMINE/SELECT done\r\n";
222 } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string
223 '{' . length($v) . "}\r\n" . $v;
224 } else { # quoted string
229 sub addr_envelope ($$;$) {
230 my ($eml, $x, $y) = @_;
231 my $v = $eml->header_raw($x) //
232 ($y ? $eml->header_raw($y) : undef) // return 'NIL';
234 my @x = $Address->parse($v) or return 'NIL';
236 map { '(' . join(' ',
237 _esc($_->name), 'NIL',
238 _esc($_->user), _esc($_->host)
244 sub eml_envelope ($) {
247 _esc($eml->header_raw('Date')),
248 _esc($eml->header_raw('Subject')),
249 addr_envelope($eml, 'From'),
250 addr_envelope($eml, 'Sender', 'From'),
251 addr_envelope($eml, 'Reply-To', 'From'),
252 addr_envelope($eml, 'To'),
253 addr_envelope($eml, 'Cc'),
254 addr_envelope($eml, 'Bcc'),
255 _esc($eml->header_raw('In-Reply-To')),
256 _esc($eml->header_raw('Message-ID')),
262 if ($hash && scalar keys %$hash) {
263 $hash = [ %$hash ]; # flatten hash into 1-dimensional array
264 '(' . join(' ', map { _esc($_) } @$hash) . ')';
270 sub body_disposition ($) {
272 my $cd = $eml->header_raw('Content-Disposition') or return 'NIL';
273 $cd = parse_content_disposition($cd);
274 my $buf = '('._esc($cd->{type});
275 $buf .= ' ' . _esc_hash(delete $cd->{attributes});
279 sub body_leaf ($$;$) {
280 my ($eml, $structure, $hold) = @_;
282 $eml->{is_submsg} and # parent was a message/(rfc822|news|global)
283 $buf .= eml_envelope($eml). ' ';
285 $buf .= '('._esc($ct->{type}).' ';
286 $buf .= _esc($ct->{subtype});
287 $buf .= ' ' . _esc_hash(delete $ct->{attributes});
288 $buf .= ' ' . _esc($eml->header_raw('Content-ID'));
289 $buf .= ' ' . _esc($eml->header_raw('Content-Description'));
290 my $cte = $eml->header_raw('Content-Transfer-Encoding') // '7bit';
291 $buf .= ' ' . _esc($cte);
292 $buf .= ' ' . $eml->{imap_body_len};
293 $buf .= ' '.($eml->body_raw =~ tr/\n/\n/) if lc($ct->{type}) eq 'text';
295 # for message/(rfc822|global|news), $hold[0] should have envelope
296 $buf .= ' ' . (@$hold ? join('', @$hold) : 'NIL') if $hold;
299 $buf .= ' '._esc($eml->header_raw('Content-MD5'));
300 $buf .= ' '. body_disposition($eml);
301 $buf .= ' '._esc($eml->header_raw('Content-Language'));
302 $buf .= ' '._esc($eml->header_raw('Content-Location'));
307 sub body_parent ($$$) {
308 my ($eml, $structure, $hold) = @_;
310 my $type = lc($ct->{type});
311 if ($type eq 'multipart') {
313 $buf .= @$hold ? join('', @$hold) : 'NIL';
314 $buf .= ' '._esc($ct->{subtype});
316 $buf .= ' '._esc_hash(delete $ct->{attributes});
317 $buf .= ' '.body_disposition($eml);
318 $buf .= ' '._esc($eml->header_raw('Content-Language'));
319 $buf .= ' '._esc($eml->header_raw('Content-Location'));
323 } else { # message/(rfc822|global|news)
324 @$hold = (body_leaf($eml, $structure, $hold));
328 # this is gross, but we need to process the parent part AFTER
329 # the child parts are done
330 sub bodystructure_prep {
332 my ($eml, $depth) = @$p; # ignore idx
333 # set length here, as $eml->{bdy} gets deleted for message/rfc822
334 $eml->{imap_body_len} = length($eml->body_raw);
335 push @$q, $eml, $depth;
338 # for FETCH BODY and FETCH BODYSTRUCTURE
339 sub fetch_body ($;$) {
340 my ($eml, $structure) = @_;
342 $eml->each_part(\&bodystructure_prep, \@q, 0, 1);
346 my ($part, $depth) = splice(@q, -2);
347 my $is_mp_parent = $depth == ($cur_depth - 1);
351 body_parent($part, $structure, \@hold);
353 unshift @hold, body_leaf($part, $structure);
359 sub dummy_message ($$) {
360 my ($seqno, $ibx) = @_;
362 From: nobody\@localhost\r
363 To: nobody\@localhost\r
364 Date: Thu, 01 Jan 1970 00:00:00 +0000\r
365 Message-ID: <dummy-$seqno\@$ibx->{newsgroup}>\r
366 Subject: dummy message #$seqno\r
368 You're seeing this message because your IMAP client didn't use UIDs.\r
369 The message which used to use this sequence number was likely spam\r
370 and removed by the administrator.\r
375 sub requeue_once ($) {
377 # COMPRESS users all share the same DEFLATE context.
378 # Flush it here to ensure clients don't see
382 # no recursion, schedule another call ASAP,
383 # but only after all pending writes are done.
385 my $new_size = push(@{$self->{wbuf}}, \&long_step);
387 # wbuf may be populated by $cb, no need to rearm if so:
388 $self->requeue if $new_size == 1;
391 sub uid_fetch_cb { # called by git->cat_async via git_async_msg
392 my ($bref, $oid, $type, $size, $fetch_m_arg) = @_;
393 my ($self, undef, $ibx, $msgs, undef, $want) = @$fetch_m_arg;
394 my $smsg = shift @$msgs or die 'BUG: no smsg';
395 if (!defined($oid)) {
396 # it's possible to have TOCTOU if an admin runs
397 # public-inbox-(edit|purge), just move onto the next message
398 return requeue_once($self) unless defined $want->{-seqno};
399 $bref = dummy_message($smsg->{num}, $ibx);
401 $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid";
403 $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
405 # fixup old bug from import (pre-a0c07cba0e5d8b6a)
406 $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
408 $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
410 $want->{'RFC822.SIZE'} and
411 $self->msg_more(' RFC822.SIZE '.length($$bref));
412 $want->{INTERNALDATE} and
413 $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
414 $want->{FLAGS} and $self->msg_more(' FLAGS ()');
415 for ('RFC822', 'BODY[]') {
417 $self->msg_more(" $_ {".length($$bref)."}\r\n");
418 $self->msg_more($$bref);
421 my $eml = PublicInbox::Eml->new($bref);
423 $want->{ENVELOPE} and
424 $self->msg_more(' ENVELOPE '.eml_envelope($eml));
426 for ('RFC822.HEADER', 'BODY[HEADER]') {
428 $self->msg_more(" $_ {".length(${$eml->{hdr}})."}\r\n");
429 $self->msg_more(${$eml->{hdr}});
431 for ('RFC822.TEXT', 'BODY[TEXT]') {
433 $self->msg_more(" $_ {".length($$bref)."}\r\n");
434 $self->msg_more($$bref);
436 $want->{BODYSTRUCTURE} and
437 $self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
439 $self->msg_more(' BODY '.fetch_body($eml));
440 if (my $partial = $want->{-partial}) {
441 partial_emit($self, $partial, $eml);
443 $self->msg_more(")\r\n");
447 sub range_step ($$) {
448 my ($ibx, $range_csv) = @_;
449 my ($beg, $end, $range);
450 if ($$range_csv =~ s/\A([^,]+),//) {
453 $range = $$range_csv;
456 if ($range =~ /\A([0-9]+):([0-9]+)\z/) {
457 ($beg, $end) = ($1, $2);
458 } elsif ($range =~ /\A([0-9]+):\*\z/) {
459 ($beg, $end) = ($1, $ibx->mm->max // 0);
460 } elsif ($range =~ /\A[0-9]+\z/) {
461 $beg = $end = $range;
463 return 'BAD fetch range';
465 [ $beg, $end, $$range_csv ];
468 sub refill_range ($$$) {
469 my ($ibx, $msgs, $range_info) = @_;
470 my ($beg, $end, $range_csv) = @$range_info;
471 if (scalar(@$msgs = @{$ibx->over->query_xover($beg, $end)})) {
472 $range_info->[0] = $msgs->[-1]->{num} + 1;
475 return 'OK Fetch done' if !$range_csv;
476 my $next_range = range_step($ibx, \$range_csv);
477 return $next_range if !ref($next_range); # error
478 @$range_info = @$next_range;
479 undef; # keep looping
482 sub uid_fetch_m { # long_response
483 my ($self, $tag, $ibx, $msgs, $range_info, $want) = @_;
484 while (!@$msgs) { # rare
485 if (my $end = refill_range($ibx, $msgs, $range_info)) {
486 $self->write(\"$tag $end\r\n");
490 git_async_msg($ibx, $msgs->[0], \&uid_fetch_cb, \@_);
493 sub cmd_status ($$$;@) {
494 my ($self, $tag, $mailbox, @items) = @_;
495 my $ibx = $self->{imapd}->{groups}->{$mailbox} or
496 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
497 return "$tag BAD no items\r\n" if !scalar(@items);
498 ($items[0] !~ s/\A\(//s || $items[-1] !~ s/\)\z//s) and
499 return "$tag BAD invalid args\r\n";
503 for my $it (@items) {
506 if ($it =~ /\A(?:MESSAGES|UNSEEN|RECENT)\z/) {
507 push(@it, ($max //= $mm->max // 0));
508 } elsif ($it eq 'UIDNEXT') {
509 push(@it, ($max //= $mm->max // 0) + 1);
510 } elsif ($it eq 'UIDVALIDITY') {
511 push(@it, $mm->created_at //
512 return("$tag BAD UIDVALIDITY\r\n"));
514 return "$tag BAD invalid item\r\n";
517 return "$tag BAD no items\r\n" if !@it;
518 "* STATUS $mailbox (".join(' ', @it).")\r\n" .
519 "$tag OK Status done\r\n";
522 my %patmap = ('*' => '.*', '%' => '[^\.]*');
523 sub cmd_list ($$$$) {
524 my ($self, $tag, $refname, $wildcard) = @_;
525 my $l = $self->{imapd}->{inboxlist};
526 if ($refname eq '' && $wildcard eq '') {
527 # request for hierarchy delimiter
528 $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
529 } elsif ($refname ne '' || $wildcard ne '*') {
530 $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eig;
531 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
533 \(join('', @$l, "$tag OK List done\r\n"));
536 sub cmd_lsub ($$$$) {
537 my (undef, $tag) = @_; # same args as cmd_list
538 "$tag OK Lsub done\r\n";
541 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
543 my ($eml, undef, $idx) = @$p;
544 if ($idx && lc($eml->ct->{type}) eq 'multipart') {
545 $eml->{imap_bdy} = $eml->{bdy} // \'';
547 $all->{$idx} = $eml; # $idx => Eml
550 # prepares an index for BODY[$SECTION_IDX] fetches
551 sub eml_body_idx ($$) {
552 my ($eml, $section_idx) = @_;
553 my $idx = $eml->{imap_all_parts} //= do {
555 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
556 # top-level of multipart, BODY[0] not allowed (nz-number)
560 $idx->{$section_idx};
563 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
565 my ($eml, $section_idx, $section_name) = @_;
566 if (defined $section_idx) {
567 $eml = eml_body_idx($eml, $section_idx) or return;
569 if (defined $section_name) {
570 if ($section_name eq 'MIME') {
571 # RFC 3501 6.4.5 states:
572 # The MIME part specifier MUST be prefixed
573 # by one or more numeric part specifiers
574 return unless defined $section_idx;
575 return $eml->header_obj->as_string . "\r\n";
577 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
578 $eml = PublicInbox::Eml->new($$bdy);
579 if ($section_name eq 'TEXT') {
580 return $eml->body_raw;
581 } elsif ($section_name eq 'HEADER') {
582 return $eml->header_obj->as_string . "\r\n";
584 die "BUG: bad section_name=$section_name";
587 ${$eml->{bdy} // $eml->{imap_bdy} // \''};
590 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
591 # to avoid OOM with malicious users
592 sub hdrs_regexp ($) {
594 my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
595 qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
596 # continuation lines:
597 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
601 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
602 sub partial_hdr_not {
603 my ($eml, $section_idx, $hdrs_re) = @_;
604 if (defined $section_idx) {
605 $eml = eml_body_idx($eml, $section_idx) or return;
607 my $str = $eml->header_obj->as_string;
608 $str =~ s/$hdrs_re//g;
612 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
613 sub partial_hdr_get {
614 my ($eml, $section_idx, $hdrs_re) = @_;
615 if (defined $section_idx) {
616 $eml = eml_body_idx($eml, $section_idx) or return;
618 my $str = $eml->header_obj->as_string;
619 join('', ($str =~ m/($hdrs_re)/g), "\r\n");
622 sub partial_prepare ($$$) {
623 my ($partial, $want, $att) = @_;
625 # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
626 # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
627 return unless $att =~ /\ABODY\[/s;
628 until (rindex($att, ']') >= 0) {
629 my $next = shift @$want or return;
630 $att .= ' ' . uc($next);
632 if ($att =~ /\ABODY\[([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
633 (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
634 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
635 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
636 } elsif ($att =~ /\ABODY\[(?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
637 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
638 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
639 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
640 my $tmp = $partial->{$att} = [ $2 ? \&partial_hdr_not
643 $tmp->[2] = hdrs_regexp($3);
649 sub partial_emit ($$$) {
650 my ($self, $partial, $eml) = @_;
652 my ($k, $cb, @args) = @$_;
653 my ($offset, $len) = splice(@args, -2);
654 # $cb is partial_body|partial_hdr_get|partial_hdr_not
655 my $str = $cb->($eml, @args) // '';
656 if (defined $offset) {
658 $str = substr($str, $offset, $len);
659 $k =~ s/\.$len>\z/>/ or warn
660 "BUG: unable to remove `.$len>' from `$k'";
662 $str = substr($str, $offset);
668 $self->msg_more(" $k {$len}\r\n");
669 $self->msg_more($str);
673 sub fetch_common ($$$$) {
674 my ($self, $tag, $range_csv, $want) = @_;
675 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
676 if ($want->[0] =~ s/\A\(//s) {
677 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
679 my (%partial, %want);
680 while (defined(my $att = shift @$want)) {
682 $att =~ s/\ABODY\.PEEK\[/BODY\[/; # we're read-only
683 my $x = $FETCH_ATT{$att};
685 %want = (%want, %$x);
686 } elsif (!partial_prepare(\%partial, $want, $att)) {
687 return "$tag BAD param: $att\r\n";
691 # stabilize partial order for consistency and ease-of-debugging:
692 if (scalar keys %partial) {
693 $want{-partial} = [ map {;
694 [ $_, @{$partial{$_}} ]
695 } sort keys %partial ];
697 $range_csv = 'bad' if $range_csv !~ $valid_range;
698 my $range_info = range_step($ibx, \$range_csv);
699 return "$tag $range_info\r\n" if !ref($range_info);
700 [ $tag, $ibx, [], $range_info, \%want ];
703 sub cmd_uid_fetch ($$$;@) {
704 my ($self, $tag, $range_csv, @want) = @_;
705 my $args = fetch_common($self, $tag, $range_csv, \@want);
706 ref($args) eq 'ARRAY' ?
707 long_response($self, \&uid_fetch_m, @$args) :
711 sub seq_fetch_m { # long_response
712 my ($self, $tag, $ibx, $msgs, $range_info, $want) = @_;
713 while (!@$msgs) { # rare
714 if (my $end = refill_range($ibx, $msgs, $range_info)) {
715 $self->write(\"$tag $end\r\n");
719 my $seq = $want->{-seqno}++;
720 my $cur_num = $msgs->[0]->{num};
721 if ($cur_num == $seq) { # as expected
722 git_async_msg($ibx, $msgs->[0], \&uid_fetch_cb, \@_);
723 } elsif ($cur_num > $seq) {
724 # send dummy messages until $seq catches up to $cur_num
725 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
726 unshift @$msgs, $smsg;
727 my $bref = dummy_message($seq, $ibx);
728 uid_fetch_cb($bref, undef, undef, undef, \@_);
729 $smsg; # blessed response since uid_fetch_cb requeues
730 } else { # should not happen
731 die "BUG: cur_num=$cur_num < seq=$seq";
735 sub cmd_fetch ($$$;@) {
736 my ($self, $tag, $range_csv, @want) = @_;
737 my $args = fetch_common($self, $tag, $range_csv, \@want);
738 ref($args) eq 'ARRAY' ? do {
739 my $want = $args->[-1];
740 $want->{-seqno} = $args->[3]->[0]; # $beg == $range_info->[0];
741 long_response($self, \&seq_fetch_m, @$args)
745 sub uid_search_all { # long_response
746 my ($self, $tag, $ibx, $num) = @_;
747 my $uids = $ibx->mm->ids_after($num);
748 if (scalar(@$uids)) {
749 $self->msg_more(join(' ', '', @$uids));
751 $self->write(\"\r\n$tag OK Search done\r\n");
756 sub uid_search_uid_range { # long_response
757 my ($self, $tag, $ibx, $beg, $end) = @_;
758 my $uids = $ibx->mm->msg_range($beg, $end, 'num');
760 $self->msg_more(join('', map { " $_->[0]" } @$uids));
762 $self->write(\"\r\n$tag OK Search done\r\n");
767 sub cmd_uid_search ($$$;) {
768 my ($self, $tag, $arg, @rest) = @_;
769 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
771 if ($arg eq 'ALL' && !@rest) {
772 $self->msg_more('* SEARCH');
774 long_response($self, \&uid_search_all, $tag, $ibx, \$num);
775 } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
776 if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
777 my ($beg, $end) = ($1, $2);
778 $end = $ibx->mm->max if $end eq '*';
779 $self->msg_more('* SEARCH');
780 long_response($self, \&uid_search_uid_range,
781 $tag, $ibx, \$beg, $end);
782 } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
784 $uid = $ibx->over->get_art($uid) ? " $uid" : '';
785 "* SEARCH$uid\r\n$tag OK Search done\r\n";
787 "$tag BAD Error\r\n";
790 "$tag BAD Error\r\n";
794 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
795 my ($cb, $argc) = @_;
796 my $tot = prototype $cb;
797 my ($nreq, undef) = split(';', $tot);
798 $nreq = ($nreq =~ tr/$//) - 1;
799 $tot = ($tot =~ tr/$//) - 1;
800 ($argc <= $tot && $argc >= $nreq);
803 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
804 sub process_line ($$) {
806 my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
807 pop(@args) if (@args && !defined($args[-1]));
808 if (@args && uc($req) eq 'UID') {
809 $req .= "_".(shift @args);
812 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
813 defined($self->{-idle_tag}) ?
814 "$self->{-idle_tag} BAD expected DONE\r\n" :
815 $cmd->($self, $tag, @args);
816 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
817 cmd_done($self, $tag);
818 } else { # this is weird
819 auth_challenge_ok($self) //
820 "$tag BAD Error in IMAP command $req: ".
821 "Unknown command\r\n";
825 if ($err && $self->{sock}) {
827 err($self, 'error from: %s (%s)', $l, $err);
828 $res = "$tag BAD program fault - command not performed\r\n";
830 return 0 unless defined $res;
836 # wbuf is unset or empty, here; {long} may add to it
837 my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
838 my $more = eval { $cb->($self, @args) };
839 if ($@ || !$self->{sock}) { # something bad happened...
840 delete $self->{long_cb};
841 my $elapsed = now() - $t0;
844 "%s during long response[$fd] - %0.6f",
847 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
849 } elsif ($more) { # $self->{wbuf}:
850 $self->update_idle_time;
852 # control passed to $more may be a GitAsyncCat object
853 requeue_once($self) if !ref($more);
855 delete $self->{long_cb};
856 my $elapsed = now() - $t0;
857 my $fd = fileno($self->{sock});
858 out($self, " deferred[$fd] done - %0.6f", $elapsed);
859 my $wbuf = $self->{wbuf}; # do NOT autovivify
861 $self->requeue unless $wbuf && @$wbuf;
866 my ($self, $fmt, @args) = @_;
867 printf { $self->{imapd}->{err} } $fmt."\n", @args;
871 my ($self, $fmt, @args) = @_;
872 printf { $self->{imapd}->{out} } $fmt."\n", @args;
875 sub long_response ($$;@) {
876 my ($self, $cb, @args) = @_; # cb returns true if more, false if done
878 my $sock = $self->{sock} or return;
879 # make sure we disable reading during a long response,
880 # clients should not be sending us stuff and making us do more
881 # work while we are stream a response to them
882 $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
883 long_step($self); # kick off!
887 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
891 return unless $self->flush_write && $self->{sock};
893 $self->update_idle_time;
894 # only read more requests if we've drained the write buffer,
895 # otherwise we can be buffering infinitely w/o backpressure
897 my $rbuf = $self->{rbuf} // (\(my $x = ''));
900 if (index($$rbuf, "\n") < 0) {
901 my $off = length($$rbuf);
902 $r = $self->do_read($rbuf, LINE_MAX, $off) or return;
904 while ($r > 0 && $$rbuf =~ s/\A[ \t]*([^\n]*?)\r?\n//) {
906 return $self->close if $line =~ /[[:cntrl:]]/s;
908 my $fd = fileno($self->{sock});
909 $r = eval { process_line($self, $line) };
910 my $pending = $self->{wbuf} ? ' pending' : '';
911 out($self, "[$fd] %s - %0.6f$pending", $line, now() - $t0);
914 return $self->close if $r < 0;
915 my $len = length($$rbuf);
916 return $self->close if ($len >= LINE_MAX);
917 $self->rbuf_idle($rbuf);
918 $self->update_idle_time;
920 # maybe there's more pipelined data, or we'll have
921 # to register it for socket-readiness notifications
922 $self->requeue unless $self->{wbuf};
925 sub compressed { undef }
927 sub zflush {} # overridden by IMAPdeflate
930 sub cmd_compress ($$$) {
931 my ($self, $tag, $alg) = @_;
932 return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
933 return "$tag BAD COMPRESS active\r\n" if $self->compressed;
935 # CRIME made TLS compression obsolete
936 # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
938 PublicInbox::IMAPdeflate->enable($self, $tag);
943 sub cmd_starttls ($$) {
944 my ($self, $tag) = @_;
945 my $sock = $self->{sock} or return;
946 if ($sock->can('stop_SSL') || $self->compressed) {
947 return "$tag BAD TLS or compression already enabled\r\n";
949 my $opt = $self->{imapd}->{accept_tls} or
950 return "$tag BAD can not initiate TLS negotiation\r\n";
951 $self->write(\"$tag OK begin TLS negotiation now\r\n");
952 $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
953 $self->requeue if PublicInbox::DS::accept_tls_step($self);
957 # for graceful shutdown in PublicInbox::Daemon:
959 my ($self, $now) = @_;
960 ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
965 if (my $ibx = delete $self->{ibx}) {
966 if (my $sock = $self->{sock}) {;
967 $ibx->unsubscribe_unlock(fileno($sock));
970 $self->SUPER::close; # PublicInbox::DS::close
973 # we're read-only, so SELECT and EXAMINE do the same thing
975 *cmd_select = \&cmd_examine;