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 my $uid_min = UID_BLOCK * int($max/UID_BLOCK) + 1;
201 my $uid_end = $uid_min + UID_BLOCK - 1;
202 while ($uid_min > 0) {
203 my $sub_mailbox = "$mb_top.$uid_min-$uid_end";
204 last if exists $mailboxes->{$sub_mailbox};
205 $mailboxes->{$sub_mailbox} = $ibx;
206 $uid_end -= UID_BLOCK;
207 $uid_min -= UID_BLOCK;
208 push @created, $sub_mailbox;
210 return unless @created;
211 my $l = $imapd->{inboxlist} or return;
212 push @$l, map { qq[* LIST (\\HasNoChildren) "." $_\r\n] } @created;
215 sub cmd_examine ($$$) {
216 my ($self, $tag, $mailbox) = @_;
217 my ($ibx, $mm, $max);
219 if ($mailbox =~ /\A(.+)\.([0-9]+)-([0-9]+)\z/) {
220 # old mail: inbox.comp.foo.$uid_min-$uid_end
221 my ($mb_top, $uid_min, $uid_end) = ($1, $2 + 0, $3 + 0);
223 $ibx = $self->{imapd}->{mailboxes}->{lc $mailbox} or
224 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
227 $max = $mm->max // 0;
228 $self->{uid_min} = $uid_min;
229 ensure_ranges_exist($self->{imapd}, $ibx, $max);
230 $max = $uid_end if $max > $uid_end;
231 } else { # check for dummy inboxes
232 $ibx = $self->{imapd}->{mailboxes}->{lc $mailbox} or
233 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
234 delete $self->{uid_min};
239 my $uidnext = $max + 1;
241 # XXX: do we need this? RFC 5162/7162
242 my $ret = $self->{ibx} ? "* OK [CLOSED] previous closed\r\n" : '';
248 * OK [PERMANENTFLAGS ()] Read-only mailbox\r
250 * OK [UIDNEXT $uidnext]\r
251 * OK [UIDVALIDITY $ibx->{uidvalidity}]\r
252 $tag OK [READ-ONLY] EXAMINE/SELECT done\r
260 } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string
261 '{' . length($v) . "}\r\n" . $v;
262 } else { # quoted string
267 sub addr_envelope ($$;$) {
268 my ($eml, $x, $y) = @_;
269 my $v = $eml->header_raw($x) //
270 ($y ? $eml->header_raw($y) : undef) // return 'NIL';
272 my @x = $Address->parse($v) or return 'NIL';
274 map { '(' . join(' ',
275 _esc($_->name), 'NIL',
276 _esc($_->user), _esc($_->host)
282 sub eml_envelope ($) {
285 _esc($eml->header_raw('Date')),
286 _esc($eml->header_raw('Subject')),
287 addr_envelope($eml, 'From'),
288 addr_envelope($eml, 'Sender', 'From'),
289 addr_envelope($eml, 'Reply-To', 'From'),
290 addr_envelope($eml, 'To'),
291 addr_envelope($eml, 'Cc'),
292 addr_envelope($eml, 'Bcc'),
293 _esc($eml->header_raw('In-Reply-To')),
294 _esc($eml->header_raw('Message-ID')),
300 if ($hash && scalar keys %$hash) {
301 $hash = [ %$hash ]; # flatten hash into 1-dimensional array
302 '(' . join(' ', map { _esc($_) } @$hash) . ')';
308 sub body_disposition ($) {
310 my $cd = $eml->header_raw('Content-Disposition') or return 'NIL';
311 $cd = parse_content_disposition($cd);
312 my $buf = '('._esc($cd->{type});
313 $buf .= ' ' . _esc_hash(delete $cd->{attributes});
317 sub body_leaf ($$;$) {
318 my ($eml, $structure, $hold) = @_;
320 $eml->{is_submsg} and # parent was a message/(rfc822|news|global)
321 $buf .= eml_envelope($eml). ' ';
323 $buf .= '('._esc($ct->{type}).' ';
324 $buf .= _esc($ct->{subtype});
325 $buf .= ' ' . _esc_hash(delete $ct->{attributes});
326 $buf .= ' ' . _esc($eml->header_raw('Content-ID'));
327 $buf .= ' ' . _esc($eml->header_raw('Content-Description'));
328 my $cte = $eml->header_raw('Content-Transfer-Encoding') // '7bit';
329 $buf .= ' ' . _esc($cte);
330 $buf .= ' ' . $eml->{imap_body_len};
331 $buf .= ' '.($eml->body_raw =~ tr/\n/\n/) if lc($ct->{type}) eq 'text';
333 # for message/(rfc822|global|news), $hold[0] should have envelope
334 $buf .= ' ' . (@$hold ? join('', @$hold) : 'NIL') if $hold;
337 $buf .= ' '._esc($eml->header_raw('Content-MD5'));
338 $buf .= ' '. body_disposition($eml);
339 $buf .= ' '._esc($eml->header_raw('Content-Language'));
340 $buf .= ' '._esc($eml->header_raw('Content-Location'));
345 sub body_parent ($$$) {
346 my ($eml, $structure, $hold) = @_;
348 my $type = lc($ct->{type});
349 if ($type eq 'multipart') {
351 $buf .= @$hold ? join('', @$hold) : 'NIL';
352 $buf .= ' '._esc($ct->{subtype});
354 $buf .= ' '._esc_hash(delete $ct->{attributes});
355 $buf .= ' '.body_disposition($eml);
356 $buf .= ' '._esc($eml->header_raw('Content-Language'));
357 $buf .= ' '._esc($eml->header_raw('Content-Location'));
361 } else { # message/(rfc822|global|news)
362 @$hold = (body_leaf($eml, $structure, $hold));
366 # this is gross, but we need to process the parent part AFTER
367 # the child parts are done
368 sub bodystructure_prep {
370 my ($eml, $depth) = @$p; # ignore idx
371 # set length here, as $eml->{bdy} gets deleted for message/rfc822
372 $eml->{imap_body_len} = length($eml->body_raw);
373 push @$q, $eml, $depth;
376 # for FETCH BODY and FETCH BODYSTRUCTURE
377 sub fetch_body ($;$) {
378 my ($eml, $structure) = @_;
380 $eml->each_part(\&bodystructure_prep, \@q, 0, 1);
384 my ($part, $depth) = splice(@q, -2);
385 my $is_mp_parent = $depth == ($cur_depth - 1);
389 body_parent($part, $structure, \@hold);
391 unshift @hold, body_leaf($part, $structure);
397 sub dummy_message ($$) {
398 my ($self, $seqno) = @_;
400 From: nobody\@localhost\r
401 To: nobody\@localhost\r
402 Date: Thu, 01 Jan 1970 00:00:00 +0000\r
403 Message-ID: <dummy-$seqno\@$self->{ibx}->{newsgroup}>\r
404 Subject: dummy message #$seqno\r
406 You're seeing this message because your IMAP client didn't use UIDs.\r
407 The message which used to use this sequence number was likely spam\r
408 and removed by the administrator.\r
413 sub requeue_once ($) {
415 # COMPRESS users all share the same DEFLATE context.
416 # Flush it here to ensure clients don't see
420 # no recursion, schedule another call ASAP,
421 # but only after all pending writes are done.
423 my $new_size = push(@{$self->{wbuf}}, \&long_step);
425 # wbuf may be populated by $cb, no need to rearm if so:
426 $self->requeue if $new_size == 1;
429 sub uid_fetch_cb { # called by git->cat_async via git_async_cat
430 my ($bref, $oid, $type, $size, $fetch_m_arg) = @_;
431 my ($self, undef, $msgs, undef, $want) = @$fetch_m_arg;
432 my $smsg = shift @$msgs or die 'BUG: no smsg';
433 if (!defined($oid)) {
434 # it's possible to have TOCTOU if an admin runs
435 # public-inbox-(edit|purge), just move onto the next message
436 return requeue_once($self) unless defined $want->{-seqno};
437 $bref = dummy_message($self, $smsg->{num});
439 $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid";
442 $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
444 # fixup old bug from import (pre-a0c07cba0e5d8b6a)
445 $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
447 $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
449 $want->{'RFC822.SIZE'} and
450 $self->msg_more(' RFC822.SIZE '.length($$bref));
451 $want->{INTERNALDATE} and
452 $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
453 $want->{FLAGS} and $self->msg_more(' FLAGS ()');
454 for ('RFC822', 'BODY[]') {
456 $self->msg_more(" $_ {".length($$bref)."}\r\n");
457 $self->msg_more($$bref);
460 my $eml = PublicInbox::Eml->new($bref);
462 $want->{ENVELOPE} and
463 $self->msg_more(' ENVELOPE '.eml_envelope($eml));
465 for ('RFC822.HEADER', 'BODY[HEADER]') {
467 $self->msg_more(" $_ {".length(${$eml->{hdr}})."}\r\n");
468 $self->msg_more(${$eml->{hdr}});
470 for ('RFC822.TEXT', 'BODY[TEXT]') {
472 $self->msg_more(" $_ {".length($$bref)."}\r\n");
473 $self->msg_more($$bref);
475 $want->{BODYSTRUCTURE} and
476 $self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
478 $self->msg_more(' BODY '.fetch_body($eml));
479 if (my $partial = $want->{-partial}) {
480 partial_emit($self, $partial, $eml);
482 $self->msg_more(")\r\n");
486 sub range_step ($$) {
487 my ($self, $range_csv) = @_;
488 my ($beg, $end, $range);
489 if ($$range_csv =~ s/\A([^,]+),//) {
492 $range = $$range_csv;
495 if ($range =~ /\A([0-9]+):([0-9]+)\z/) {
496 ($beg, $end) = ($1 + 0, $2 + 0);
497 } elsif ($range =~ /\A([0-9]+):\*\z/) {
499 $end = $self->{ibx}->mm->max // 0;
500 $beg = $end if $beg > $end;
501 } elsif ($range =~ /\A[0-9]+\z/) {
502 $beg = $end = $range + 0;
505 return 'BAD fetch range';
507 if (defined($range) && (my $uid_min = $self->{uid_min})) {
508 my $uid_end = $uid_min + UID_BLOCK - 1;
509 $beg = $uid_min if $beg < $uid_min;
510 $end = $uid_end if $end > $uid_end;
512 [ $beg, $end, $$range_csv ];
515 sub refill_range ($$$) {
516 my ($self, $msgs, $range_info) = @_;
517 my ($beg, $end, $range_csv) = @$range_info;
518 if (scalar(@$msgs = @{$self->{ibx}->over->query_xover($beg, $end)})) {
519 $range_info->[0] = $msgs->[-1]->{num} + 1;
522 return 'OK Fetch done' if !$range_csv;
523 my $next_range = range_step($self, \$range_csv);
524 return $next_range if !ref($next_range); # error
525 @$range_info = @$next_range;
526 undef; # keep looping
529 sub uid_fetch_m { # long_response
530 my ($self, $tag, $msgs, $range_info, $want) = @_;
531 while (!@$msgs) { # rare
532 if (my $end = refill_range($self, $msgs, $range_info)) {
533 $self->write(\"$tag $end\r\n");
537 git_async_cat($self->{ibx}->git, $msgs->[0]->{blob},
538 \&uid_fetch_cb, \@_);
541 sub cmd_status ($$$;@) {
542 my ($self, $tag, $mailbox, @items) = @_;
543 my $ibx = $self->{imapd}->{mailboxes}->{$mailbox} or
544 return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
545 return "$tag BAD no items\r\n" if !scalar(@items);
546 ($items[0] !~ s/\A\(//s || $items[-1] !~ s/\)\z//s) and
547 return "$tag BAD invalid args\r\n";
551 for my $it (@items) {
554 if ($it =~ /\A(?:MESSAGES|UNSEEN|RECENT)\z/) {
555 push(@it, ($max //= $mm->max // 0));
556 } elsif ($it eq 'UIDNEXT') {
557 push(@it, ($max //= $mm->max // 0) + 1);
558 } elsif ($it eq 'UIDVALIDITY') {
559 push(@it, $ibx->{uidvalidity});
561 return "$tag BAD invalid item\r\n";
564 return "$tag BAD no items\r\n" if !@it;
565 "* STATUS $mailbox (".join(' ', @it).")\r\n" .
566 "$tag OK Status done\r\n";
569 my %patmap = ('*' => '.*', '%' => '[^\.]*');
570 sub cmd_list ($$$$) {
571 my ($self, $tag, $refname, $wildcard) = @_;
572 my $l = $self->{imapd}->{inboxlist};
573 if ($refname eq '' && $wildcard eq '') {
574 # request for hierarchy delimiter
575 $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
576 } elsif ($refname ne '' || $wildcard ne '*') {
577 $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eig;
578 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
580 \(join('', @$l, "$tag OK List done\r\n"));
583 sub cmd_lsub ($$$$) {
584 my (undef, $tag) = @_; # same args as cmd_list
585 "$tag OK Lsub done\r\n";
588 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
590 my ($eml, undef, $idx) = @$p;
591 if ($idx && lc($eml->ct->{type}) eq 'multipart') {
592 $eml->{imap_bdy} = $eml->{bdy} // \'';
594 $all->{$idx} = $eml; # $idx => Eml
597 # prepares an index for BODY[$SECTION_IDX] fetches
598 sub eml_body_idx ($$) {
599 my ($eml, $section_idx) = @_;
600 my $idx = $eml->{imap_all_parts} //= do {
602 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
603 # top-level of multipart, BODY[0] not allowed (nz-number)
607 $idx->{$section_idx};
610 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
612 my ($eml, $section_idx, $section_name) = @_;
613 if (defined $section_idx) {
614 $eml = eml_body_idx($eml, $section_idx) or return;
616 if (defined $section_name) {
617 if ($section_name eq 'MIME') {
618 # RFC 3501 6.4.5 states:
619 # The MIME part specifier MUST be prefixed
620 # by one or more numeric part specifiers
621 return unless defined $section_idx;
622 return $eml->header_obj->as_string . "\r\n";
624 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
625 $eml = PublicInbox::Eml->new($$bdy);
626 if ($section_name eq 'TEXT') {
627 return $eml->body_raw;
628 } elsif ($section_name eq 'HEADER') {
629 return $eml->header_obj->as_string . "\r\n";
631 die "BUG: bad section_name=$section_name";
634 ${$eml->{bdy} // $eml->{imap_bdy} // \''};
637 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
638 # to avoid OOM with malicious users
639 sub hdrs_regexp ($) {
641 my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
642 qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
643 # continuation lines:
644 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
648 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
649 sub partial_hdr_not {
650 my ($eml, $section_idx, $hdrs_re) = @_;
651 if (defined $section_idx) {
652 $eml = eml_body_idx($eml, $section_idx) or return;
654 my $str = $eml->header_obj->as_string;
655 $str =~ s/$hdrs_re//g;
659 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
660 sub partial_hdr_get {
661 my ($eml, $section_idx, $hdrs_re) = @_;
662 if (defined $section_idx) {
663 $eml = eml_body_idx($eml, $section_idx) or return;
665 my $str = $eml->header_obj->as_string;
666 join('', ($str =~ m/($hdrs_re)/g), "\r\n");
669 sub partial_prepare ($$$) {
670 my ($partial, $want, $att) = @_;
672 # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
673 # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
674 return unless $att =~ /\ABODY\[/s;
675 until (rindex($att, ']') >= 0) {
676 my $next = shift @$want or return;
677 $att .= ' ' . uc($next);
679 if ($att =~ /\ABODY\[([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
680 (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
681 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
682 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
683 } elsif ($att =~ /\ABODY\[(?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
684 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
685 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
686 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
687 my $tmp = $partial->{$att} = [ $2 ? \&partial_hdr_not
690 $tmp->[2] = hdrs_regexp($3);
696 sub partial_emit ($$$) {
697 my ($self, $partial, $eml) = @_;
699 my ($k, $cb, @args) = @$_;
700 my ($offset, $len) = splice(@args, -2);
701 # $cb is partial_body|partial_hdr_get|partial_hdr_not
702 my $str = $cb->($eml, @args) // '';
703 if (defined $offset) {
705 $str = substr($str, $offset, $len);
706 $k =~ s/\.$len>\z/>/ or warn
707 "BUG: unable to remove `.$len>' from `$k'";
709 $str = substr($str, $offset);
715 $self->msg_more(" $k {$len}\r\n");
716 $self->msg_more($str);
720 sub fetch_common ($$$$) {
721 my ($self, $tag, $range_csv, $want) = @_;
722 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
723 if ($want->[0] =~ s/\A\(//s) {
724 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
726 my (%partial, %want);
727 while (defined(my $att = shift @$want)) {
729 $att =~ s/\ABODY\.PEEK\[/BODY\[/; # we're read-only
730 my $x = $FETCH_ATT{$att};
732 %want = (%want, %$x);
733 } elsif (!partial_prepare(\%partial, $want, $att)) {
734 return "$tag BAD param: $att\r\n";
738 # stabilize partial order for consistency and ease-of-debugging:
739 if (scalar keys %partial) {
740 $want{-partial} = [ map {;
741 [ $_, @{$partial{$_}} ]
742 } sort keys %partial ];
744 $range_csv = 'bad' if $range_csv !~ $valid_range;
745 my $range_info = range_step($self, \$range_csv);
746 return "$tag $range_info\r\n" if !ref($range_info);
747 [ $tag, [], $range_info, \%want ];
750 sub cmd_uid_fetch ($$$;@) {
751 my ($self, $tag, $range_csv, @want) = @_;
752 my $args = fetch_common($self, $tag, $range_csv, \@want);
753 ref($args) eq 'ARRAY' ?
754 long_response($self, \&uid_fetch_m, @$args) :
758 sub seq_fetch_m { # long_response
759 my ($self, $tag, $msgs, $range_info, $want) = @_;
760 while (!@$msgs) { # rare
761 if (my $end = refill_range($self, $msgs, $range_info)) {
762 $self->write(\"$tag $end\r\n");
766 my $seq = $want->{-seqno}++;
767 my $cur_num = $msgs->[0]->{num};
768 if ($cur_num == $seq) { # as expected
769 git_async_cat($self->{ibx}->git, $msgs->[0]->{blob},
770 \&uid_fetch_cb, \@_);
771 } elsif ($cur_num > $seq) {
772 # send dummy messages until $seq catches up to $cur_num
773 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
774 unshift @$msgs, $smsg;
775 my $bref = dummy_message($self, $seq);
776 uid_fetch_cb($bref, undef, undef, undef, \@_);
777 $smsg; # blessed response since uid_fetch_cb requeues
778 } else { # should not happen
779 die "BUG: cur_num=$cur_num < seq=$seq";
783 sub cmd_fetch ($$$;@) {
784 my ($self, $tag, $range_csv, @want) = @_;
785 my $args = fetch_common($self, $tag, $range_csv, \@want);
786 ref($args) eq 'ARRAY' ? do {
787 my $want = $args->[-1];
788 $want->{-seqno} = $args->[2]->[0]; # $beg == $range_info->[0];
789 long_response($self, \&seq_fetch_m, @$args)
793 sub uid_search_all { # long_response
794 my ($self, $tag, $num) = @_;
795 my $uids = $self->{ibx}->mm->ids_after($num);
796 if (scalar(@$uids)) {
797 $self->msg_more(join(' ', '', @$uids));
799 $self->write(\"\r\n$tag OK Search done\r\n");
804 sub uid_search_uid_range { # long_response
805 my ($self, $tag, $beg, $end) = @_;
806 my $uids = $self->{ibx}->mm->msg_range($beg, $end, 'num');
808 $self->msg_more(join('', map { " $_->[0]" } @$uids));
810 $self->write(\"\r\n$tag OK Search done\r\n");
815 sub cmd_uid_search ($$$;) {
816 my ($self, $tag, $arg, @rest) = @_;
817 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
819 if ($arg eq 'ALL' && !@rest) {
820 $self->msg_more('* SEARCH');
822 long_response($self, \&uid_search_all, $tag, \$num);
823 } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
824 if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
825 my ($beg, $end) = ($1, $2);
826 $end = $ibx->mm->max if $end eq '*';
827 $self->msg_more('* SEARCH');
828 long_response($self, \&uid_search_uid_range,
830 } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
832 $uid = $ibx->over->get_art($uid) ? " $uid" : '';
833 "* SEARCH$uid\r\n$tag OK Search done\r\n";
835 "$tag BAD Error\r\n";
838 "$tag BAD Error\r\n";
842 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
843 my ($cb, $argc) = @_;
844 my $tot = prototype $cb;
845 my ($nreq, undef) = split(';', $tot);
846 $nreq = ($nreq =~ tr/$//) - 1;
847 $tot = ($tot =~ tr/$//) - 1;
848 ($argc <= $tot && $argc >= $nreq);
851 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
852 sub process_line ($$) {
854 my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
855 pop(@args) if (@args && !defined($args[-1]));
856 if (@args && uc($req) eq 'UID') {
857 $req .= "_".(shift @args);
860 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
861 defined($self->{-idle_tag}) ?
862 "$self->{-idle_tag} BAD expected DONE\r\n" :
863 $cmd->($self, $tag, @args);
864 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
865 cmd_done($self, $tag);
866 } else { # this is weird
867 auth_challenge_ok($self) //
868 "$tag BAD Error in IMAP command $req: ".
869 "Unknown command\r\n";
873 if ($err && $self->{sock}) {
875 err($self, 'error from: %s (%s)', $l, $err);
876 $res = "$tag BAD program fault - command not performed\r\n";
878 return 0 unless defined $res;
884 # wbuf is unset or empty, here; {long} may add to it
885 my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
886 my $more = eval { $cb->($self, @args) };
887 if ($@ || !$self->{sock}) { # something bad happened...
888 delete $self->{long_cb};
889 my $elapsed = now() - $t0;
892 "%s during long response[$fd] - %0.6f",
895 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
897 } elsif ($more) { # $self->{wbuf}:
898 $self->update_idle_time;
900 # control passed to $more may be a GitAsyncCat object
901 requeue_once($self) if !ref($more);
903 delete $self->{long_cb};
904 my $elapsed = now() - $t0;
905 my $fd = fileno($self->{sock});
906 out($self, " deferred[$fd] done - %0.6f", $elapsed);
907 my $wbuf = $self->{wbuf}; # do NOT autovivify
909 $self->requeue unless $wbuf && @$wbuf;
914 my ($self, $fmt, @args) = @_;
915 printf { $self->{imapd}->{err} } $fmt."\n", @args;
919 my ($self, $fmt, @args) = @_;
920 printf { $self->{imapd}->{out} } $fmt."\n", @args;
923 sub long_response ($$;@) {
924 my ($self, $cb, @args) = @_; # cb returns true if more, false if done
926 my $sock = $self->{sock} or return;
927 # make sure we disable reading during a long response,
928 # clients should not be sending us stuff and making us do more
929 # work while we are stream a response to them
930 $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
931 long_step($self); # kick off!
935 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
939 return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
941 $self->update_idle_time;
942 # only read more requests if we've drained the write buffer,
943 # otherwise we can be buffering infinitely w/o backpressure
945 my $rbuf = $self->{rbuf} // \(my $x = '');
946 my $line = index($$rbuf, "\n");
948 return $self->close if length($$rbuf) >= LINE_MAX;
949 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or return;
950 $line = index($$rbuf, "\n");
952 $line = substr($$rbuf, 0, $line + 1, '');
953 $line =~ s/\r?\n\z//s;
954 return $self->close if $line =~ /[[:cntrl:]]/s;
956 my $fd = fileno($self->{sock});
957 my $r = eval { process_line($self, $line) };
958 my $pending = $self->{wbuf} ? ' pending' : '';
959 out($self, "[$fd] %s - %0.6f$pending - $r", $line, now() - $t0);
961 return $self->close if $r < 0;
962 $self->rbuf_idle($rbuf);
963 $self->update_idle_time;
965 # maybe there's more pipelined data, or we'll have
966 # to register it for socket-readiness notifications
967 $self->requeue unless $pending;
970 sub compressed { undef }
972 sub zflush {} # overridden by IMAPdeflate
975 sub cmd_compress ($$$) {
976 my ($self, $tag, $alg) = @_;
977 return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
978 return "$tag BAD COMPRESS active\r\n" if $self->compressed;
980 # CRIME made TLS compression obsolete
981 # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
983 PublicInbox::IMAPdeflate->enable($self, $tag);
988 sub cmd_starttls ($$) {
989 my ($self, $tag) = @_;
990 my $sock = $self->{sock} or return;
991 if ($sock->can('stop_SSL') || $self->compressed) {
992 return "$tag BAD TLS or compression already enabled\r\n";
994 my $opt = $self->{imapd}->{accept_tls} or
995 return "$tag BAD can not initiate TLS negotiation\r\n";
996 $self->write(\"$tag OK begin TLS negotiation now\r\n");
997 $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
998 $self->requeue if PublicInbox::DS::accept_tls_step($self);
1002 # for graceful shutdown in PublicInbox::Daemon:
1004 my ($self, $now) = @_;
1005 ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
1010 if (my $ibx = delete $self->{ibx}) {
1011 if (my $sock = $self->{sock}) {;
1012 $ibx->unsubscribe_unlock(fileno($sock));
1015 $self->SUPER::close; # PublicInbox::DS::close
1018 # we're read-only, so SELECT and EXAMINE do the same thing
1020 *cmd_select = \&cmd_examine;