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
19 uid_min -idle_tag -idle_max);
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 # changing this will cause grief for clients which cache
38 sub UID_BLOCK () { 50_000 }
40 my %FETCH_NEED_BLOB = ( # for future optimization
45 'RFC822.SIZE' => 1, # needs CRLF conversion :<
55 my %FETCH_ATT = map { $_ => [ $_ ] } keys %FETCH_NEED_BLOB;
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' ];
62 for my $att (keys %FETCH_ATT) {
63 my %h = map { $_ => 1 } @{$FETCH_ATT{$att}};
64 $FETCH_ATT{$att} = \%h;
67 my $valid_range = '[0-9]+|[0-9]+:[0-9]+|[0-9]+:\*';
68 $valid_range = qr/\A(?:$valid_range)(?:,(?:$valid_range))*\z/;
72 my $capa = capa($self);
73 $self->write(\"* OK [$capa] public-inbox-imapd ready\r\n");
77 my ($class, $sock, $imapd) = @_;
78 my $self = fields::new($class);
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 ];
86 $self->SUPER::new($sock, $ev | EPOLLONESHOT);
87 $self->{imapd} = $imapd;
89 $self->{wbuf} = $wbuf;
93 $self->update_idle_time;
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';
106 if (!($self->{sock} // $self)->can('accept_SSL') &&
107 $self->{imapd}->{accept_tls}) {
108 $capa .= ' STARTTLS';
110 $capa .= ' AUTH=ANONYMOUS';
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";
121 sub auth_challenge_ok ($) {
123 my $tag = delete($self->{-login_tag}) or return;
124 login_success($self, $tag);
127 sub cmd_login ($$$$) {
128 my ($self, $tag) = @_; # ignore ($user, $password) = ($_[2], $_[3])
129 login_success($self, $tag);
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";
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
147 sub cmd_authenticate ($$$) {
148 my ($self, $tag) = @_; # $method = $_[2], should be "ANONYMOUS"
149 $self->{-login_tag} = $tag;
153 sub cmd_capability ($$) {
154 my ($self, $tag) = @_;
155 '* '.capa($self)."\r\n$tag OK Capability done\r\n";
158 sub cmd_noop ($$) { "$_[1] OK Noop done\r\n" }
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';
166 $self->{-idle_max} = $new;
167 $self->msg_more("* $_ EXISTS\r\n") for (($old + 1)..($new - 1));
168 $self->write(\"* $new EXISTS\r\n");
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;
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";
191 $ibx->unsubscribe_unlock(fileno($self->{sock}));
192 "$idle_tag OK Idle done\r\n";
195 sub ensure_ranges_exist ($$$) {
196 my ($imapd, $ibx, $max) = @_;
197 my $mailboxes = $imapd->{mailboxes};
198 my $mb_top = $ibx->{newsgroup};
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;
206 return unless @created;
207 my $l = $imapd->{inboxlist} or return;
208 push @$l, map { qq[* LIST (\\HasNoChildren) "." $_\r\n] } @created;
211 sub cmd_examine ($$$) {
212 my ($self, $tag, $mailbox) = @_;
213 my ($ibx, $mm, $max);
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);
219 $ibx = $self->{imapd}->{mailboxes}->{lc $mailbox} or
220 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
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};
236 my $uidnext = $max + 1;
238 # XXX: do we need this? RFC 5162/7162
239 my $ret = $self->{ibx} ? "* OK [CLOSED] previous closed\r\n" : '';
245 * OK [PERMANENTFLAGS ()] Read-only mailbox\r
247 * OK [UIDNEXT $uidnext]\r
248 * OK [UIDVALIDITY $ibx->{uidvalidity}]\r
249 $tag OK [READ-ONLY] EXAMINE/SELECT done\r
257 } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string
258 '{' . length($v) . "}\r\n" . $v;
259 } else { # quoted string
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';
269 my @x = $Address->parse($v) or return 'NIL';
271 map { '(' . join(' ',
272 _esc($_->name), 'NIL',
273 _esc($_->user), _esc($_->host)
279 sub eml_envelope ($) {
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')),
297 if ($hash && scalar keys %$hash) {
298 $hash = [ %$hash ]; # flatten hash into 1-dimensional array
299 '(' . join(' ', map { _esc($_) } @$hash) . ')';
305 sub body_disposition ($) {
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});
314 sub body_leaf ($$;$) {
315 my ($eml, $structure, $hold) = @_;
317 $eml->{is_submsg} and # parent was a message/(rfc822|news|global)
318 $buf .= eml_envelope($eml). ' ';
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';
330 # for message/(rfc822|global|news), $hold[0] should have envelope
331 $buf .= ' ' . (@$hold ? join('', @$hold) : 'NIL') if $hold;
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'));
342 sub body_parent ($$$) {
343 my ($eml, $structure, $hold) = @_;
345 my $type = lc($ct->{type});
346 if ($type eq 'multipart') {
348 $buf .= @$hold ? join('', @$hold) : 'NIL';
349 $buf .= ' '._esc($ct->{subtype});
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'));
358 } else { # message/(rfc822|global|news)
359 @$hold = (body_leaf($eml, $structure, $hold));
363 # this is gross, but we need to process the parent part AFTER
364 # the child parts are done
365 sub bodystructure_prep {
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;
373 # for FETCH BODY and FETCH BODYSTRUCTURE
374 sub fetch_body ($;$) {
375 my ($eml, $structure) = @_;
377 $eml->each_part(\&bodystructure_prep, \@q, 0, 1);
381 my ($part, $depth) = splice(@q, -2);
382 my $is_mp_parent = $depth == ($cur_depth - 1);
386 body_parent($part, $structure, \@hold);
388 unshift @hold, body_leaf($part, $structure);
394 sub dummy_message ($$) {
395 my ($self, $seqno) = @_;
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
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
410 sub requeue_once ($) {
412 # COMPRESS users all share the same DEFLATE context.
413 # Flush it here to ensure clients don't see
417 # no recursion, schedule another call ASAP,
418 # but only after all pending writes are done.
420 my $new_size = push(@{$self->{wbuf}}, \&long_step);
422 # wbuf may be populated by $cb, no need to rearm if so:
423 $self->requeue if $new_size == 1;
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});
436 $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid";
439 $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
441 # fixup old bug from import (pre-a0c07cba0e5d8b6a)
442 $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
444 $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
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[]') {
453 $self->msg_more(" $_ {".length($$bref)."}\r\n");
454 $self->msg_more($$bref);
457 my $eml = PublicInbox::Eml->new($bref);
459 $want->{ENVELOPE} and
460 $self->msg_more(' ENVELOPE '.eml_envelope($eml));
462 for ('RFC822.HEADER', 'BODY[HEADER]') {
464 $self->msg_more(" $_ {".length(${$eml->{hdr}})."}\r\n");
465 $self->msg_more(${$eml->{hdr}});
467 for ('RFC822.TEXT', 'BODY[TEXT]') {
469 $self->msg_more(" $_ {".length($$bref)."}\r\n");
470 $self->msg_more($$bref);
472 $want->{BODYSTRUCTURE} and
473 $self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
475 $self->msg_more(' BODY '.fetch_body($eml));
476 if (my $partial = $want->{-partial}) {
477 partial_emit($self, $partial, $eml);
479 $self->msg_more(")\r\n");
483 sub range_step ($$) {
484 my ($self, $range_csv) = @_;
485 my ($beg, $end, $range);
486 if ($$range_csv =~ s/\A([^,]+),//) {
489 $range = $$range_csv;
492 if ($range =~ /\A([0-9]+):([0-9]+)\z/) {
493 ($beg, $end) = ($1 + 0, $2 + 0);
494 } elsif ($range =~ /\A([0-9]+):\*\z/) {
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;
502 return 'BAD fetch range';
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;
509 [ $beg, $end, $$range_csv ];
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;
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
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");
534 git_async_cat($self->{ibx}->git, $msgs->[0]->{blob},
535 \&uid_fetch_cb, \@_);
538 sub cmd_status ($$$;@) {
539 my ($self, $tag, $mailbox, @items) = @_;
540 my $ibx = $self->{imapd}->{mailboxes}->{$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";
548 for my $it (@items) {
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});
558 return "$tag BAD invalid item\r\n";
561 return "$tag BAD no items\r\n" if !@it;
562 "* STATUS $mailbox (".join(' ', @it).")\r\n" .
563 "$tag OK Status done\r\n";
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 =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eig;
575 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
577 \(join('', @$l, "$tag OK List done\r\n"));
580 sub cmd_lsub ($$$$) {
581 my (undef, $tag) = @_; # same args as cmd_list
582 "$tag OK Lsub done\r\n";
585 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
587 my ($eml, undef, $idx) = @$p;
588 if ($idx && lc($eml->ct->{type}) eq 'multipart') {
589 $eml->{imap_bdy} = $eml->{bdy} // \'';
591 $all->{$idx} = $eml; # $idx => Eml
594 # prepares an index for BODY[$SECTION_IDX] fetches
595 sub eml_body_idx ($$) {
596 my ($eml, $section_idx) = @_;
597 my $idx = $eml->{imap_all_parts} //= do {
599 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
600 # top-level of multipart, BODY[0] not allowed (nz-number)
604 $idx->{$section_idx};
607 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
609 my ($eml, $section_idx, $section_name) = @_;
610 if (defined $section_idx) {
611 $eml = eml_body_idx($eml, $section_idx) or return;
613 if (defined $section_name) {
614 if ($section_name eq 'MIME') {
615 # RFC 3501 6.4.5 states:
616 # The MIME part specifier MUST be prefixed
617 # by one or more numeric part specifiers
618 return unless defined $section_idx;
619 return $eml->header_obj->as_string . "\r\n";
621 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
622 $eml = PublicInbox::Eml->new($$bdy);
623 if ($section_name eq 'TEXT') {
624 return $eml->body_raw;
625 } elsif ($section_name eq 'HEADER') {
626 return $eml->header_obj->as_string . "\r\n";
628 die "BUG: bad section_name=$section_name";
631 ${$eml->{bdy} // $eml->{imap_bdy} // \''};
634 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
635 # to avoid OOM with malicious users
636 sub hdrs_regexp ($) {
638 my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
639 qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
640 # continuation lines:
641 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
645 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
646 sub partial_hdr_not {
647 my ($eml, $section_idx, $hdrs_re) = @_;
648 if (defined $section_idx) {
649 $eml = eml_body_idx($eml, $section_idx) or return;
651 my $str = $eml->header_obj->as_string;
652 $str =~ s/$hdrs_re//g;
656 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
657 sub partial_hdr_get {
658 my ($eml, $section_idx, $hdrs_re) = @_;
659 if (defined $section_idx) {
660 $eml = eml_body_idx($eml, $section_idx) or return;
662 my $str = $eml->header_obj->as_string;
663 join('', ($str =~ m/($hdrs_re)/g), "\r\n");
666 sub partial_prepare ($$$) {
667 my ($partial, $want, $att) = @_;
669 # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
670 # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
671 return unless $att =~ /\ABODY\[/s;
672 until (rindex($att, ']') >= 0) {
673 my $next = shift @$want or return;
674 $att .= ' ' . uc($next);
676 if ($att =~ /\ABODY\[([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
677 (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
678 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
679 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
680 } elsif ($att =~ /\ABODY\[(?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
681 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
682 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
683 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
684 my $tmp = $partial->{$att} = [ $2 ? \&partial_hdr_not
687 $tmp->[2] = hdrs_regexp($3);
693 sub partial_emit ($$$) {
694 my ($self, $partial, $eml) = @_;
696 my ($k, $cb, @args) = @$_;
697 my ($offset, $len) = splice(@args, -2);
698 # $cb is partial_body|partial_hdr_get|partial_hdr_not
699 my $str = $cb->($eml, @args) // '';
700 if (defined $offset) {
702 $str = substr($str, $offset, $len);
703 $k =~ s/\.$len>\z/>/ or warn
704 "BUG: unable to remove `.$len>' from `$k'";
706 $str = substr($str, $offset);
712 $self->msg_more(" $k {$len}\r\n");
713 $self->msg_more($str);
717 sub fetch_common ($$$$) {
718 my ($self, $tag, $range_csv, $want) = @_;
719 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
720 if ($want->[0] =~ s/\A\(//s) {
721 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
723 my (%partial, %want);
724 while (defined(my $att = shift @$want)) {
726 $att =~ s/\ABODY\.PEEK\[/BODY\[/; # we're read-only
727 my $x = $FETCH_ATT{$att};
729 %want = (%want, %$x);
730 } elsif (!partial_prepare(\%partial, $want, $att)) {
731 return "$tag BAD param: $att\r\n";
735 # stabilize partial order for consistency and ease-of-debugging:
736 if (scalar keys %partial) {
737 $want{-partial} = [ map {;
738 [ $_, @{$partial{$_}} ]
739 } sort keys %partial ];
741 $range_csv = 'bad' if $range_csv !~ $valid_range;
742 my $range_info = range_step($self, \$range_csv);
743 return "$tag $range_info\r\n" if !ref($range_info);
744 [ $tag, [], $range_info, \%want ];
747 sub cmd_uid_fetch ($$$;@) {
748 my ($self, $tag, $range_csv, @want) = @_;
749 my $args = fetch_common($self, $tag, $range_csv, \@want);
750 ref($args) eq 'ARRAY' ?
751 long_response($self, \&uid_fetch_m, @$args) :
755 sub seq_fetch_m { # long_response
756 my ($self, $tag, $msgs, $range_info, $want) = @_;
757 while (!@$msgs) { # rare
758 if (my $end = refill_range($self, $msgs, $range_info)) {
759 $self->write(\"$tag $end\r\n");
763 my $seq = $want->{-seqno}++;
764 my $cur_num = $msgs->[0]->{num};
765 if ($cur_num == $seq) { # as expected
766 git_async_cat($self->{ibx}->git, $msgs->[0]->{blob},
767 \&uid_fetch_cb, \@_);
768 } elsif ($cur_num > $seq) {
769 # send dummy messages until $seq catches up to $cur_num
770 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
771 unshift @$msgs, $smsg;
772 my $bref = dummy_message($self, $seq);
773 uid_fetch_cb($bref, undef, undef, undef, \@_);
774 $smsg; # blessed response since uid_fetch_cb requeues
775 } else { # should not happen
776 die "BUG: cur_num=$cur_num < seq=$seq";
780 sub cmd_fetch ($$$;@) {
781 my ($self, $tag, $range_csv, @want) = @_;
782 my $args = fetch_common($self, $tag, $range_csv, \@want);
783 ref($args) eq 'ARRAY' ? do {
784 my $want = $args->[-1];
785 $want->{-seqno} = $args->[2]->[0]; # $beg == $range_info->[0];
786 long_response($self, \&seq_fetch_m, @$args)
790 sub uid_search_all { # long_response
791 my ($self, $tag, $num) = @_;
792 my $uids = $self->{ibx}->mm->ids_after($num);
793 if (scalar(@$uids)) {
794 $self->msg_more(join(' ', '', @$uids));
796 $self->write(\"\r\n$tag OK Search done\r\n");
801 sub uid_search_uid_range { # long_response
802 my ($self, $tag, $beg, $end) = @_;
803 my $uids = $self->{ibx}->mm->msg_range($beg, $end, 'num');
805 $self->msg_more(join('', map { " $_->[0]" } @$uids));
807 $self->write(\"\r\n$tag OK Search done\r\n");
812 sub cmd_uid_search ($$$;) {
813 my ($self, $tag, $arg, @rest) = @_;
814 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
816 if ($arg eq 'ALL' && !@rest) {
817 $self->msg_more('* SEARCH');
819 long_response($self, \&uid_search_all, $tag, \$num);
820 } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
821 if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
822 my ($beg, $end) = ($1, $2);
823 $end = $ibx->mm->max if $end eq '*';
824 $self->msg_more('* SEARCH');
825 long_response($self, \&uid_search_uid_range,
827 } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
829 $uid = $ibx->over->get_art($uid) ? " $uid" : '';
830 "* SEARCH$uid\r\n$tag OK Search done\r\n";
832 "$tag BAD Error\r\n";
835 "$tag BAD Error\r\n";
839 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
840 my ($cb, $argc) = @_;
841 my $tot = prototype $cb;
842 my ($nreq, undef) = split(';', $tot);
843 $nreq = ($nreq =~ tr/$//) - 1;
844 $tot = ($tot =~ tr/$//) - 1;
845 ($argc <= $tot && $argc >= $nreq);
848 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
849 sub process_line ($$) {
851 my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
852 pop(@args) if (@args && !defined($args[-1]));
853 if (@args && uc($req) eq 'UID') {
854 $req .= "_".(shift @args);
857 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
858 defined($self->{-idle_tag}) ?
859 "$self->{-idle_tag} BAD expected DONE\r\n" :
860 $cmd->($self, $tag, @args);
861 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
862 cmd_done($self, $tag);
863 } else { # this is weird
864 auth_challenge_ok($self) //
865 "$tag BAD Error in IMAP command $req: ".
866 "Unknown command\r\n";
870 if ($err && $self->{sock}) {
872 err($self, 'error from: %s (%s)', $l, $err);
873 $res = "$tag BAD program fault - command not performed\r\n";
875 return 0 unless defined $res;
881 # wbuf is unset or empty, here; {long} may add to it
882 my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
883 my $more = eval { $cb->($self, @args) };
884 if ($@ || !$self->{sock}) { # something bad happened...
885 delete $self->{long_cb};
886 my $elapsed = now() - $t0;
889 "%s during long response[$fd] - %0.6f",
892 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
894 } elsif ($more) { # $self->{wbuf}:
895 $self->update_idle_time;
897 # control passed to $more may be a GitAsyncCat object
898 requeue_once($self) if !ref($more);
900 delete $self->{long_cb};
901 my $elapsed = now() - $t0;
902 my $fd = fileno($self->{sock});
903 out($self, " deferred[$fd] done - %0.6f", $elapsed);
904 my $wbuf = $self->{wbuf}; # do NOT autovivify
906 $self->requeue unless $wbuf && @$wbuf;
911 my ($self, $fmt, @args) = @_;
912 printf { $self->{imapd}->{err} } $fmt."\n", @args;
916 my ($self, $fmt, @args) = @_;
917 printf { $self->{imapd}->{out} } $fmt."\n", @args;
920 sub long_response ($$;@) {
921 my ($self, $cb, @args) = @_; # cb returns true if more, false if done
923 my $sock = $self->{sock} or return;
924 # make sure we disable reading during a long response,
925 # clients should not be sending us stuff and making us do more
926 # work while we are stream a response to them
927 $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
928 long_step($self); # kick off!
932 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
936 return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
938 $self->update_idle_time;
939 # only read more requests if we've drained the write buffer,
940 # otherwise we can be buffering infinitely w/o backpressure
942 my $rbuf = $self->{rbuf} // \(my $x = '');
943 my $line = index($$rbuf, "\n");
945 return $self->close if length($$rbuf) >= LINE_MAX;
946 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or return;
947 $line = index($$rbuf, "\n");
949 $line = substr($$rbuf, 0, $line + 1, '');
950 $line =~ s/\r?\n\z//s;
951 return $self->close if $line =~ /[[:cntrl:]]/s;
953 my $fd = fileno($self->{sock});
954 my $r = eval { process_line($self, $line) };
955 my $pending = $self->{wbuf} ? ' pending' : '';
956 out($self, "[$fd] %s - %0.6f$pending - $r", $line, now() - $t0);
958 return $self->close if $r < 0;
959 $self->rbuf_idle($rbuf);
960 $self->update_idle_time;
962 # maybe there's more pipelined data, or we'll have
963 # to register it for socket-readiness notifications
964 $self->requeue unless $pending;
967 sub compressed { undef }
969 sub zflush {} # overridden by IMAPdeflate
972 sub cmd_compress ($$$) {
973 my ($self, $tag, $alg) = @_;
974 return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
975 return "$tag BAD COMPRESS active\r\n" if $self->compressed;
977 # CRIME made TLS compression obsolete
978 # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
980 PublicInbox::IMAPdeflate->enable($self, $tag);
985 sub cmd_starttls ($$) {
986 my ($self, $tag) = @_;
987 my $sock = $self->{sock} or return;
988 if ($sock->can('stop_SSL') || $self->compressed) {
989 return "$tag BAD TLS or compression already enabled\r\n";
991 my $opt = $self->{imapd}->{accept_tls} or
992 return "$tag BAD can not initiate TLS negotiation\r\n";
993 $self->write(\"$tag OK begin TLS negotiation now\r\n");
994 $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
995 $self->requeue if PublicInbox::DS::accept_tls_step($self);
999 # for graceful shutdown in PublicInbox::Daemon:
1001 my ($self, $now) = @_;
1002 ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
1007 if (my $ibx = delete $self->{ibx}) {
1008 if (my $sock = $self->{sock}) {;
1009 $ibx->unsubscribe_unlock(fileno($sock));
1012 $self->SUPER::close; # PublicInbox::DS::close
1015 # we're read-only, so SELECT and EXAMINE do the same thing
1017 *cmd_select = \&cmd_examine;