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_cat
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";
404 $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
406 # fixup old bug from import (pre-a0c07cba0e5d8b6a)
407 $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
409 $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
411 $want->{'RFC822.SIZE'} and
412 $self->msg_more(' RFC822.SIZE '.length($$bref));
413 $want->{INTERNALDATE} and
414 $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
415 $want->{FLAGS} and $self->msg_more(' FLAGS ()');
416 for ('RFC822', 'BODY[]') {
418 $self->msg_more(" $_ {".length($$bref)."}\r\n");
419 $self->msg_more($$bref);
422 my $eml = PublicInbox::Eml->new($bref);
424 $want->{ENVELOPE} and
425 $self->msg_more(' ENVELOPE '.eml_envelope($eml));
427 for ('RFC822.HEADER', 'BODY[HEADER]') {
429 $self->msg_more(" $_ {".length(${$eml->{hdr}})."}\r\n");
430 $self->msg_more(${$eml->{hdr}});
432 for ('RFC822.TEXT', 'BODY[TEXT]') {
434 $self->msg_more(" $_ {".length($$bref)."}\r\n");
435 $self->msg_more($$bref);
437 $want->{BODYSTRUCTURE} and
438 $self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
440 $self->msg_more(' BODY '.fetch_body($eml));
441 if (my $partial = $want->{-partial}) {
442 partial_emit($self, $partial, $eml);
444 $self->msg_more(")\r\n");
448 sub range_step ($$) {
449 my ($ibx, $range_csv) = @_;
450 my ($beg, $end, $range);
451 if ($$range_csv =~ s/\A([^,]+),//) {
454 $range = $$range_csv;
457 if ($range =~ /\A([0-9]+):([0-9]+)\z/) {
458 ($beg, $end) = ($1 + 0, $2 + 0);
459 } elsif ($range =~ /\A([0-9]+):\*\z/) {
461 $end = $ibx->mm->max // 0;
462 $beg = $end if $beg > $end;
463 } elsif ($range =~ /\A[0-9]+\z/) {
464 $beg = $end = $range + 0;
466 return 'BAD fetch range';
468 [ $beg, $end, $$range_csv ];
471 sub refill_range ($$$) {
472 my ($ibx, $msgs, $range_info) = @_;
473 my ($beg, $end, $range_csv) = @$range_info;
474 if (scalar(@$msgs = @{$ibx->over->query_xover($beg, $end)})) {
475 $range_info->[0] = $msgs->[-1]->{num} + 1;
478 return 'OK Fetch done' if !$range_csv;
479 my $next_range = range_step($ibx, \$range_csv);
480 return $next_range if !ref($next_range); # error
481 @$range_info = @$next_range;
482 undef; # keep looping
485 sub uid_fetch_m { # long_response
486 my ($self, $tag, $ibx, $msgs, $range_info, $want) = @_;
487 while (!@$msgs) { # rare
488 if (my $end = refill_range($ibx, $msgs, $range_info)) {
489 $self->write(\"$tag $end\r\n");
493 git_async_cat($ibx->git, $msgs->[0]->{blob}, \&uid_fetch_cb, \@_);
496 sub cmd_status ($$$;@) {
497 my ($self, $tag, $mailbox, @items) = @_;
498 my $ibx = $self->{imapd}->{groups}->{$mailbox} or
499 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
500 return "$tag BAD no items\r\n" if !scalar(@items);
501 ($items[0] !~ s/\A\(//s || $items[-1] !~ s/\)\z//s) and
502 return "$tag BAD invalid args\r\n";
506 for my $it (@items) {
509 if ($it =~ /\A(?:MESSAGES|UNSEEN|RECENT)\z/) {
510 push(@it, ($max //= $mm->max // 0));
511 } elsif ($it eq 'UIDNEXT') {
512 push(@it, ($max //= $mm->max // 0) + 1);
513 } elsif ($it eq 'UIDVALIDITY') {
514 push(@it, $mm->created_at //
515 return("$tag BAD UIDVALIDITY\r\n"));
517 return "$tag BAD invalid item\r\n";
520 return "$tag BAD no items\r\n" if !@it;
521 "* STATUS $mailbox (".join(' ', @it).")\r\n" .
522 "$tag OK Status done\r\n";
525 my %patmap = ('*' => '.*', '%' => '[^\.]*');
526 sub cmd_list ($$$$) {
527 my ($self, $tag, $refname, $wildcard) = @_;
528 my $l = $self->{imapd}->{inboxlist};
529 if ($refname eq '' && $wildcard eq '') {
530 # request for hierarchy delimiter
531 $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
532 } elsif ($refname ne '' || $wildcard ne '*') {
533 $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eig;
534 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
536 \(join('', @$l, "$tag OK List done\r\n"));
539 sub cmd_lsub ($$$$) {
540 my (undef, $tag) = @_; # same args as cmd_list
541 "$tag OK Lsub done\r\n";
544 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
546 my ($eml, undef, $idx) = @$p;
547 if ($idx && lc($eml->ct->{type}) eq 'multipart') {
548 $eml->{imap_bdy} = $eml->{bdy} // \'';
550 $all->{$idx} = $eml; # $idx => Eml
553 # prepares an index for BODY[$SECTION_IDX] fetches
554 sub eml_body_idx ($$) {
555 my ($eml, $section_idx) = @_;
556 my $idx = $eml->{imap_all_parts} //= do {
558 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
559 # top-level of multipart, BODY[0] not allowed (nz-number)
563 $idx->{$section_idx};
566 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
568 my ($eml, $section_idx, $section_name) = @_;
569 if (defined $section_idx) {
570 $eml = eml_body_idx($eml, $section_idx) or return;
572 if (defined $section_name) {
573 if ($section_name eq 'MIME') {
574 # RFC 3501 6.4.5 states:
575 # The MIME part specifier MUST be prefixed
576 # by one or more numeric part specifiers
577 return unless defined $section_idx;
578 return $eml->header_obj->as_string . "\r\n";
580 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
581 $eml = PublicInbox::Eml->new($$bdy);
582 if ($section_name eq 'TEXT') {
583 return $eml->body_raw;
584 } elsif ($section_name eq 'HEADER') {
585 return $eml->header_obj->as_string . "\r\n";
587 die "BUG: bad section_name=$section_name";
590 ${$eml->{bdy} // $eml->{imap_bdy} // \''};
593 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
594 # to avoid OOM with malicious users
595 sub hdrs_regexp ($) {
597 my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
598 qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
599 # continuation lines:
600 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
604 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
605 sub partial_hdr_not {
606 my ($eml, $section_idx, $hdrs_re) = @_;
607 if (defined $section_idx) {
608 $eml = eml_body_idx($eml, $section_idx) or return;
610 my $str = $eml->header_obj->as_string;
611 $str =~ s/$hdrs_re//g;
615 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
616 sub partial_hdr_get {
617 my ($eml, $section_idx, $hdrs_re) = @_;
618 if (defined $section_idx) {
619 $eml = eml_body_idx($eml, $section_idx) or return;
621 my $str = $eml->header_obj->as_string;
622 join('', ($str =~ m/($hdrs_re)/g), "\r\n");
625 sub partial_prepare ($$$) {
626 my ($partial, $want, $att) = @_;
628 # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
629 # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
630 return unless $att =~ /\ABODY\[/s;
631 until (rindex($att, ']') >= 0) {
632 my $next = shift @$want or return;
633 $att .= ' ' . uc($next);
635 if ($att =~ /\ABODY\[([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
636 (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
637 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
638 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
639 } elsif ($att =~ /\ABODY\[(?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
640 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
641 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
642 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
643 my $tmp = $partial->{$att} = [ $2 ? \&partial_hdr_not
646 $tmp->[2] = hdrs_regexp($3);
652 sub partial_emit ($$$) {
653 my ($self, $partial, $eml) = @_;
655 my ($k, $cb, @args) = @$_;
656 my ($offset, $len) = splice(@args, -2);
657 # $cb is partial_body|partial_hdr_get|partial_hdr_not
658 my $str = $cb->($eml, @args) // '';
659 if (defined $offset) {
661 $str = substr($str, $offset, $len);
662 $k =~ s/\.$len>\z/>/ or warn
663 "BUG: unable to remove `.$len>' from `$k'";
665 $str = substr($str, $offset);
671 $self->msg_more(" $k {$len}\r\n");
672 $self->msg_more($str);
676 sub fetch_common ($$$$) {
677 my ($self, $tag, $range_csv, $want) = @_;
678 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
679 if ($want->[0] =~ s/\A\(//s) {
680 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
682 my (%partial, %want);
683 while (defined(my $att = shift @$want)) {
685 $att =~ s/\ABODY\.PEEK\[/BODY\[/; # we're read-only
686 my $x = $FETCH_ATT{$att};
688 %want = (%want, %$x);
689 } elsif (!partial_prepare(\%partial, $want, $att)) {
690 return "$tag BAD param: $att\r\n";
694 # stabilize partial order for consistency and ease-of-debugging:
695 if (scalar keys %partial) {
696 $want{-partial} = [ map {;
697 [ $_, @{$partial{$_}} ]
698 } sort keys %partial ];
700 $range_csv = 'bad' if $range_csv !~ $valid_range;
701 my $range_info = range_step($ibx, \$range_csv);
702 return "$tag $range_info\r\n" if !ref($range_info);
703 [ $tag, $ibx, [], $range_info, \%want ];
706 sub cmd_uid_fetch ($$$;@) {
707 my ($self, $tag, $range_csv, @want) = @_;
708 my $args = fetch_common($self, $tag, $range_csv, \@want);
709 ref($args) eq 'ARRAY' ?
710 long_response($self, \&uid_fetch_m, @$args) :
714 sub seq_fetch_m { # long_response
715 my ($self, $tag, $ibx, $msgs, $range_info, $want) = @_;
716 while (!@$msgs) { # rare
717 if (my $end = refill_range($ibx, $msgs, $range_info)) {
718 $self->write(\"$tag $end\r\n");
722 my $seq = $want->{-seqno}++;
723 my $cur_num = $msgs->[0]->{num};
724 if ($cur_num == $seq) { # as expected
725 git_async_cat($ibx->git, $msgs->[0]->{blob},
726 \&uid_fetch_cb, \@_);
727 } elsif ($cur_num > $seq) {
728 # send dummy messages until $seq catches up to $cur_num
729 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
730 unshift @$msgs, $smsg;
731 my $bref = dummy_message($seq, $ibx);
732 uid_fetch_cb($bref, undef, undef, undef, \@_);
733 $smsg; # blessed response since uid_fetch_cb requeues
734 } else { # should not happen
735 die "BUG: cur_num=$cur_num < seq=$seq";
739 sub cmd_fetch ($$$;@) {
740 my ($self, $tag, $range_csv, @want) = @_;
741 my $args = fetch_common($self, $tag, $range_csv, \@want);
742 ref($args) eq 'ARRAY' ? do {
743 my $want = $args->[-1];
744 $want->{-seqno} = $args->[3]->[0]; # $beg == $range_info->[0];
745 long_response($self, \&seq_fetch_m, @$args)
749 sub uid_search_all { # long_response
750 my ($self, $tag, $ibx, $num) = @_;
751 my $uids = $ibx->mm->ids_after($num);
752 if (scalar(@$uids)) {
753 $self->msg_more(join(' ', '', @$uids));
755 $self->write(\"\r\n$tag OK Search done\r\n");
760 sub uid_search_uid_range { # long_response
761 my ($self, $tag, $ibx, $beg, $end) = @_;
762 my $uids = $ibx->mm->msg_range($beg, $end, 'num');
764 $self->msg_more(join('', map { " $_->[0]" } @$uids));
766 $self->write(\"\r\n$tag OK Search done\r\n");
771 sub cmd_uid_search ($$$;) {
772 my ($self, $tag, $arg, @rest) = @_;
773 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
775 if ($arg eq 'ALL' && !@rest) {
776 $self->msg_more('* SEARCH');
778 long_response($self, \&uid_search_all, $tag, $ibx, \$num);
779 } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
780 if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
781 my ($beg, $end) = ($1, $2);
782 $end = $ibx->mm->max if $end eq '*';
783 $self->msg_more('* SEARCH');
784 long_response($self, \&uid_search_uid_range,
785 $tag, $ibx, \$beg, $end);
786 } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
788 $uid = $ibx->over->get_art($uid) ? " $uid" : '';
789 "* SEARCH$uid\r\n$tag OK Search done\r\n";
791 "$tag BAD Error\r\n";
794 "$tag BAD Error\r\n";
798 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
799 my ($cb, $argc) = @_;
800 my $tot = prototype $cb;
801 my ($nreq, undef) = split(';', $tot);
802 $nreq = ($nreq =~ tr/$//) - 1;
803 $tot = ($tot =~ tr/$//) - 1;
804 ($argc <= $tot && $argc >= $nreq);
807 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
808 sub process_line ($$) {
810 my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
811 pop(@args) if (@args && !defined($args[-1]));
812 if (@args && uc($req) eq 'UID') {
813 $req .= "_".(shift @args);
816 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
817 defined($self->{-idle_tag}) ?
818 "$self->{-idle_tag} BAD expected DONE\r\n" :
819 $cmd->($self, $tag, @args);
820 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
821 cmd_done($self, $tag);
822 } else { # this is weird
823 auth_challenge_ok($self) //
824 "$tag BAD Error in IMAP command $req: ".
825 "Unknown command\r\n";
829 if ($err && $self->{sock}) {
831 err($self, 'error from: %s (%s)', $l, $err);
832 $res = "$tag BAD program fault - command not performed\r\n";
834 return 0 unless defined $res;
840 # wbuf is unset or empty, here; {long} may add to it
841 my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
842 my $more = eval { $cb->($self, @args) };
843 if ($@ || !$self->{sock}) { # something bad happened...
844 delete $self->{long_cb};
845 my $elapsed = now() - $t0;
848 "%s during long response[$fd] - %0.6f",
851 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
853 } elsif ($more) { # $self->{wbuf}:
854 $self->update_idle_time;
856 # control passed to $more may be a GitAsyncCat object
857 requeue_once($self) if !ref($more);
859 delete $self->{long_cb};
860 my $elapsed = now() - $t0;
861 my $fd = fileno($self->{sock});
862 out($self, " deferred[$fd] done - %0.6f", $elapsed);
863 my $wbuf = $self->{wbuf}; # do NOT autovivify
865 $self->requeue unless $wbuf && @$wbuf;
870 my ($self, $fmt, @args) = @_;
871 printf { $self->{imapd}->{err} } $fmt."\n", @args;
875 my ($self, $fmt, @args) = @_;
876 printf { $self->{imapd}->{out} } $fmt."\n", @args;
879 sub long_response ($$;@) {
880 my ($self, $cb, @args) = @_; # cb returns true if more, false if done
882 my $sock = $self->{sock} or return;
883 # make sure we disable reading during a long response,
884 # clients should not be sending us stuff and making us do more
885 # work while we are stream a response to them
886 $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
887 long_step($self); # kick off!
891 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
895 return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
897 $self->update_idle_time;
898 # only read more requests if we've drained the write buffer,
899 # otherwise we can be buffering infinitely w/o backpressure
901 my $rbuf = $self->{rbuf} // \(my $x = '');
902 my $line = index($$rbuf, "\n");
904 return $self->close if length($$rbuf) >= LINE_MAX;
905 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or return;
906 $line = index($$rbuf, "\n");
908 $line = substr($$rbuf, 0, $line + 1, '');
909 $line =~ s/\r?\n\z//s;
910 return $self->close if $line =~ /[[:cntrl:]]/s;
912 my $fd = fileno($self->{sock});
913 my $r = eval { process_line($self, $line) };
914 my $pending = $self->{wbuf} ? ' pending' : '';
915 out($self, "[$fd] %s - %0.6f$pending - $r", $line, now() - $t0);
917 return $self->close if $r < 0;
918 $self->rbuf_idle($rbuf);
919 $self->update_idle_time;
921 # maybe there's more pipelined data, or we'll have
922 # to register it for socket-readiness notifications
923 $self->requeue unless $pending;
926 sub compressed { undef }
928 sub zflush {} # overridden by IMAPdeflate
931 sub cmd_compress ($$$) {
932 my ($self, $tag, $alg) = @_;
933 return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
934 return "$tag BAD COMPRESS active\r\n" if $self->compressed;
936 # CRIME made TLS compression obsolete
937 # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
939 PublicInbox::IMAPdeflate->enable($self, $tag);
944 sub cmd_starttls ($$) {
945 my ($self, $tag) = @_;
946 my $sock = $self->{sock} or return;
947 if ($sock->can('stop_SSL') || $self->compressed) {
948 return "$tag BAD TLS or compression already enabled\r\n";
950 my $opt = $self->{imapd}->{accept_tls} or
951 return "$tag BAD can not initiate TLS negotiation\r\n";
952 $self->write(\"$tag OK begin TLS negotiation now\r\n");
953 $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
954 $self->requeue if PublicInbox::DS::accept_tls_step($self);
958 # for graceful shutdown in PublicInbox::Daemon:
960 my ($self, $now) = @_;
961 ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
966 if (my $ibx = delete $self->{ibx}) {
967 if (my $sock = $self->{sock}) {;
968 $ibx->unsubscribe_unlock(fileno($sock));
971 $self->SUPER::close; # PublicInbox::DS::close
974 # we're read-only, so SELECT and EXAMINE do the same thing
976 *cmd_select = \&cmd_examine;