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);
27 use Time::Local qw(timegm);
28 use POSIX qw(strftime);
31 for my $mod (qw(Email::Address::XS Mail::Address)) {
32 eval "require $mod" or next;
33 $Address = $mod and last;
35 die "neither Email::Address::XS nor Mail::Address loaded: $@" if !$Address;
37 sub LINE_MAX () { 512 } # does RFC 3501 have a limit like RFC 977?
39 # changing this will cause grief for clients which cache
40 sub UID_BLOCK () { 50_000 }
42 my %FETCH_NEED_BLOB = ( # for future optimization
47 'RFC822.SIZE' => 1, # needs CRLF conversion :<
57 my %FETCH_ATT = map { $_ => [ $_ ] } keys %FETCH_NEED_BLOB;
59 # aliases (RFC 3501 section 6.4.5)
60 $FETCH_ATT{FAST} = [ qw(FLAGS INTERNALDATE RFC822.SIZE) ];
61 $FETCH_ATT{ALL} = [ @{$FETCH_ATT{FAST}}, 'ENVELOPE' ];
62 $FETCH_ATT{FULL} = [ @{$FETCH_ATT{ALL}}, 'BODY' ];
64 for my $att (keys %FETCH_ATT) {
65 my %h = map { $_ => 1 } @{$FETCH_ATT{$att}};
66 $FETCH_ATT{$att} = \%h;
69 my $valid_range = '[0-9]+|[0-9]+:[0-9]+|[0-9]+:\*';
70 $valid_range = qr/\A(?:$valid_range)(?:,(?:$valid_range))*\z/;
72 my @MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
78 my $capa = capa($self);
79 $self->write(\"* OK [$capa] public-inbox-imapd ready\r\n");
83 my ($class, $sock, $imapd) = @_;
84 my $self = fields::new($class);
87 if ($sock->can('accept_SSL') && !$sock->accept_SSL) {
88 return CORE::close($sock) if $! != EAGAIN;
89 $ev = PublicInbox::TLS::epollbit();
90 $wbuf = [ \&PublicInbox::DS::accept_tls_step, \&greet ];
92 $self->SUPER::new($sock, $ev | EPOLLONESHOT);
93 $self->{imapd} = $imapd;
95 $self->{wbuf} = $wbuf;
99 $self->update_idle_time;
106 # dovecot advertises IDLE pre-login; perhaps because some clients
107 # depend on it, so we'll do the same
108 my $capa = 'CAPABILITY IMAP4rev1 IDLE';
109 if ($self->{logged_in}) {
110 $capa .= ' COMPRESS=DEFLATE';
112 if (!($self->{sock} // $self)->can('accept_SSL') &&
113 $self->{imapd}->{accept_tls}) {
114 $capa .= ' STARTTLS';
116 $capa .= ' AUTH=ANONYMOUS';
120 sub login_success ($$) {
121 my ($self, $tag) = @_;
122 $self->{logged_in} = 1;
123 my $capa = capa($self);
124 "$tag OK [$capa] Logged in\r\n";
127 sub auth_challenge_ok ($) {
129 my $tag = delete($self->{-login_tag}) or return;
130 login_success($self, $tag);
133 sub cmd_login ($$$$) {
134 my ($self, $tag) = @_; # ignore ($user, $password) = ($_[2], $_[3])
135 login_success($self, $tag);
139 my ($self, $tag) = @_;
140 delete $self->{uid_min};
141 delete $self->{ibx} ? "$tag OK Close done\r\n"
142 : "$tag BAD No mailbox\r\n";
145 sub cmd_logout ($$) {
146 my ($self, $tag) = @_;
147 delete $self->{logged_in};
148 $self->write(\"* BYE logging out\r\n$tag OK Logout done\r\n");
149 $self->shutdn; # PublicInbox::DS::shutdn
153 sub cmd_authenticate ($$$) {
154 my ($self, $tag) = @_; # $method = $_[2], should be "ANONYMOUS"
155 $self->{-login_tag} = $tag;
159 sub cmd_capability ($$) {
160 my ($self, $tag) = @_;
161 '* '.capa($self)."\r\n$tag OK Capability done\r\n";
164 sub cmd_noop ($$) { "$_[1] OK Noop done\r\n" }
166 # called by PublicInbox::InboxIdle
167 sub on_inbox_unlock {
168 my ($self, $ibx) = @_;
169 my $new = $ibx->mm->max;
170 defined(my $old = $self->{-idle_max}) or die 'BUG: -idle_max unset';
172 $self->{-idle_max} = $new;
173 $self->msg_more("* $_ EXISTS\r\n") for (($old + 1)..($new - 1));
174 $self->write(\"* $new EXISTS\r\n");
179 my ($self, $tag) = @_;
180 # IDLE seems allowed by dovecot w/o a mailbox selected *shrug*
181 my $ibx = $self->{ibx} or return "$tag BAD no mailbox selected\r\n";
182 $ibx->subscribe_unlock(fileno($self->{sock}), $self);
183 $self->{imapd}->idler_start;
184 $self->{-idle_tag} = $tag;
185 $self->{-idle_max} = $ibx->mm->max // 0;
190 my ($self, $tag) = @_; # $tag is "DONE" (case-insensitive)
191 defined(my $idle_tag = delete $self->{-idle_tag}) or
192 return "$tag BAD not idle\r\n";
193 my $ibx = $self->{ibx} or do {
194 warn "BUG: idle_tag set w/o inbox";
195 return "$tag BAD internal bug\r\n";
197 $ibx->unsubscribe_unlock(fileno($self->{sock}));
198 "$idle_tag OK Idle done\r\n";
201 sub ensure_ranges_exist ($$$) {
202 my ($imapd, $ibx, $max) = @_;
203 my $mailboxes = $imapd->{mailboxes};
204 my $mb_top = $ibx->{newsgroup};
206 for (my $i = int($max/UID_BLOCK); $i >= 0; --$i) {
207 my $sub_mailbox = "$mb_top.$i";
208 last if exists $mailboxes->{$sub_mailbox};
209 $mailboxes->{$sub_mailbox} = $ibx;
210 push @created, $sub_mailbox;
212 return unless @created;
213 my $l = $imapd->{inboxlist} or return;
214 push @$l, map { qq[* LIST (\\HasNoChildren) "." $_\r\n] } @created;
217 sub inbox_lookup ($$) {
218 my ($self, $mailbox) = @_;
219 my ($ibx, $exists, $uidnext);
220 if ($mailbox =~ /\A(.+)\.([0-9]+)\z/) {
221 # old mail: inbox.comp.foo.$uid_block_idx
222 my ($mb_top, $uid_min) = ($1, $2 * UID_BLOCK + 1);
224 $ibx = $self->{imapd}->{mailboxes}->{lc $mailbox} or return;
225 $exists = $ibx->mm->max // 0;
226 $self->{uid_min} = $uid_min;
227 ensure_ranges_exist($self->{imapd}, $ibx, $exists);
228 my $uid_end = $uid_min + UID_BLOCK - 1;
229 $exists = $uid_end if $exists > $uid_end;
230 $uidnext = $exists + 1;
231 } else { # check for dummy inboxes
232 $ibx = $self->{imapd}->{mailboxes}->{lc $mailbox} or return;
233 delete $self->{uid_min};
237 ($ibx, $exists, $uidnext);
240 sub cmd_examine ($$$) {
241 my ($self, $tag, $mailbox) = @_;
242 my ($ibx, $exists, $uidnext) = inbox_lookup($self, $mailbox);
243 return "$tag NO Mailbox doesn't exist: $mailbox\r\n" if !$ibx;
245 # XXX: do we need this? RFC 5162/7162
246 my $ret = $self->{ibx} ? "* OK [CLOSED] previous closed\r\n" : '';
252 * OK [PERMANENTFLAGS ()] Read-only mailbox\r
253 * OK [UNSEEN $exists]\r
254 * OK [UIDNEXT $uidnext]\r
255 * OK [UIDVALIDITY $ibx->{uidvalidity}]\r
256 $tag OK [READ-ONLY] EXAMINE/SELECT done\r
264 } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string
265 '{' . length($v) . "}\r\n" . $v;
266 } else { # quoted string
271 sub addr_envelope ($$;$) {
272 my ($eml, $x, $y) = @_;
273 my $v = $eml->header_raw($x) //
274 ($y ? $eml->header_raw($y) : undef) // return 'NIL';
276 my @x = $Address->parse($v) or return 'NIL';
278 map { '(' . join(' ',
279 _esc($_->name), 'NIL',
280 _esc($_->user), _esc($_->host)
286 sub eml_envelope ($) {
289 _esc($eml->header_raw('Date')),
290 _esc($eml->header_raw('Subject')),
291 addr_envelope($eml, 'From'),
292 addr_envelope($eml, 'Sender', 'From'),
293 addr_envelope($eml, 'Reply-To', 'From'),
294 addr_envelope($eml, 'To'),
295 addr_envelope($eml, 'Cc'),
296 addr_envelope($eml, 'Bcc'),
297 _esc($eml->header_raw('In-Reply-To')),
298 _esc($eml->header_raw('Message-ID')),
304 if ($hash && scalar keys %$hash) {
305 $hash = [ %$hash ]; # flatten hash into 1-dimensional array
306 '(' . join(' ', map { _esc($_) } @$hash) . ')';
312 sub body_disposition ($) {
314 my $cd = $eml->header_raw('Content-Disposition') or return 'NIL';
315 $cd = parse_content_disposition($cd);
316 my $buf = '('._esc($cd->{type});
317 $buf .= ' ' . _esc_hash(delete $cd->{attributes});
321 sub body_leaf ($$;$) {
322 my ($eml, $structure, $hold) = @_;
324 $eml->{is_submsg} and # parent was a message/(rfc822|news|global)
325 $buf .= eml_envelope($eml). ' ';
327 $buf .= '('._esc($ct->{type}).' ';
328 $buf .= _esc($ct->{subtype});
329 $buf .= ' ' . _esc_hash(delete $ct->{attributes});
330 $buf .= ' ' . _esc($eml->header_raw('Content-ID'));
331 $buf .= ' ' . _esc($eml->header_raw('Content-Description'));
332 my $cte = $eml->header_raw('Content-Transfer-Encoding') // '7bit';
333 $buf .= ' ' . _esc($cte);
334 $buf .= ' ' . $eml->{imap_body_len};
335 $buf .= ' '.($eml->body_raw =~ tr/\n/\n/) if lc($ct->{type}) eq 'text';
337 # for message/(rfc822|global|news), $hold[0] should have envelope
338 $buf .= ' ' . (@$hold ? join('', @$hold) : 'NIL') if $hold;
341 $buf .= ' '._esc($eml->header_raw('Content-MD5'));
342 $buf .= ' '. body_disposition($eml);
343 $buf .= ' '._esc($eml->header_raw('Content-Language'));
344 $buf .= ' '._esc($eml->header_raw('Content-Location'));
349 sub body_parent ($$$) {
350 my ($eml, $structure, $hold) = @_;
352 my $type = lc($ct->{type});
353 if ($type eq 'multipart') {
355 $buf .= @$hold ? join('', @$hold) : 'NIL';
356 $buf .= ' '._esc($ct->{subtype});
358 $buf .= ' '._esc_hash(delete $ct->{attributes});
359 $buf .= ' '.body_disposition($eml);
360 $buf .= ' '._esc($eml->header_raw('Content-Language'));
361 $buf .= ' '._esc($eml->header_raw('Content-Location'));
365 } else { # message/(rfc822|global|news)
366 @$hold = (body_leaf($eml, $structure, $hold));
370 # this is gross, but we need to process the parent part AFTER
371 # the child parts are done
372 sub bodystructure_prep {
374 my ($eml, $depth) = @$p; # ignore idx
375 # set length here, as $eml->{bdy} gets deleted for message/rfc822
376 $eml->{imap_body_len} = length($eml->body_raw);
377 push @$q, $eml, $depth;
380 # for FETCH BODY and FETCH BODYSTRUCTURE
381 sub fetch_body ($;$) {
382 my ($eml, $structure) = @_;
384 $eml->each_part(\&bodystructure_prep, \@q, 0, 1);
388 my ($part, $depth) = splice(@q, -2);
389 my $is_mp_parent = $depth == ($cur_depth - 1);
393 body_parent($part, $structure, \@hold);
395 unshift @hold, body_leaf($part, $structure);
401 sub dummy_message ($$) {
402 my ($self, $seqno) = @_;
404 From: nobody\@localhost\r
405 To: nobody\@localhost\r
406 Date: Thu, 01 Jan 1970 00:00:00 +0000\r
407 Message-ID: <dummy-$seqno\@$self->{ibx}->{newsgroup}>\r
408 Subject: dummy message #$seqno\r
410 You're seeing this message because your IMAP client didn't use UIDs.\r
411 The message which used to use this sequence number was likely spam\r
412 and removed by the administrator.\r
417 sub requeue_once ($) {
419 # COMPRESS users all share the same DEFLATE context.
420 # Flush it here to ensure clients don't see
424 # no recursion, schedule another call ASAP,
425 # but only after all pending writes are done.
427 my $new_size = push(@{$self->{wbuf}}, \&long_step);
429 # wbuf may be populated by $cb, no need to rearm if so:
430 $self->requeue if $new_size == 1;
433 sub uid_fetch_cb { # called by git->cat_async via git_async_cat
434 my ($bref, $oid, $type, $size, $fetch_m_arg) = @_;
435 my ($self, undef, $msgs, undef, $want) = @$fetch_m_arg;
436 my $smsg = shift @$msgs or die 'BUG: no smsg';
437 if (!defined($oid)) {
438 # it's possible to have TOCTOU if an admin runs
439 # public-inbox-(edit|purge), just move onto the next message
440 return requeue_once($self) unless defined $want->{-seqno};
441 $bref = dummy_message($self, $smsg->{num});
443 $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid";
446 $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
448 # fixup old bug from import (pre-a0c07cba0e5d8b6a)
449 $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
451 $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
453 $want->{'RFC822.SIZE'} and
454 $self->msg_more(' RFC822.SIZE '.length($$bref));
455 $want->{INTERNALDATE} and
456 $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
457 $want->{FLAGS} and $self->msg_more(' FLAGS ()');
458 for ('RFC822', 'BODY[]') {
460 $self->msg_more(" $_ {".length($$bref)."}\r\n");
461 $self->msg_more($$bref);
464 my $eml = PublicInbox::Eml->new($bref);
466 $want->{ENVELOPE} and
467 $self->msg_more(' ENVELOPE '.eml_envelope($eml));
469 for ('RFC822.HEADER', 'BODY[HEADER]') {
471 $self->msg_more(" $_ {".length(${$eml->{hdr}})."}\r\n");
472 $self->msg_more(${$eml->{hdr}});
474 for ('RFC822.TEXT', 'BODY[TEXT]') {
476 $self->msg_more(" $_ {".length($$bref)."}\r\n");
477 $self->msg_more($$bref);
479 $want->{BODYSTRUCTURE} and
480 $self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
482 $self->msg_more(' BODY '.fetch_body($eml));
483 if (my $partial = $want->{-partial}) {
484 partial_emit($self, $partial, $eml);
486 $self->msg_more(")\r\n");
490 sub range_step ($$) {
491 my ($self, $range_csv) = @_;
492 my ($beg, $end, $range);
493 if ($$range_csv =~ s/\A([^,]+),//) {
496 $range = $$range_csv;
499 if ($range =~ /\A([0-9]+):([0-9]+)\z/) {
500 ($beg, $end) = ($1 + 0, $2 + 0);
501 } elsif ($range =~ /\A([0-9]+):\*\z/) {
503 $end = $self->{ibx}->mm->max // 0;
504 $beg = $end if $beg > $end;
505 } elsif ($range =~ /\A[0-9]+\z/) {
506 $beg = $end = $range + 0;
509 return 'BAD fetch range';
511 if (defined($range) && (my $uid_min = $self->{uid_min})) {
512 my $uid_end = $uid_min + UID_BLOCK - 1;
513 $beg = $uid_min if $beg < $uid_min;
514 $end = $uid_end if $end > $uid_end;
516 [ $beg, $end, $$range_csv ];
519 sub refill_range ($$$) {
520 my ($self, $msgs, $range_info) = @_;
521 my ($beg, $end, $range_csv) = @$range_info;
522 if (scalar(@$msgs = @{$self->{ibx}->over->query_xover($beg, $end)})) {
523 $range_info->[0] = $msgs->[-1]->{num} + 1;
526 return 'OK Fetch done' if !$range_csv;
527 my $next_range = range_step($self, \$range_csv);
528 return $next_range if !ref($next_range); # error
529 @$range_info = @$next_range;
530 undef; # keep looping
533 sub uid_fetch_m { # long_response
534 my ($self, $tag, $msgs, $range_info, $want) = @_;
535 while (!@$msgs) { # rare
536 if (my $end = refill_range($self, $msgs, $range_info)) {
537 $self->write(\"$tag $end\r\n");
541 git_async_cat($self->{ibx}->git, $msgs->[0]->{blob},
542 \&uid_fetch_cb, \@_);
545 sub cmd_status ($$$;@) {
546 my ($self, $tag, $mailbox, @items) = @_;
547 return "$tag BAD no items\r\n" if !scalar(@items);
548 ($items[0] !~ s/\A\(//s || $items[-1] !~ s/\)\z//s) and
549 return "$tag BAD invalid args\r\n";
550 my ($ibx, $exists, $uidnext) = inbox_lookup($self, $mailbox);
551 return "$tag NO Mailbox doesn't exist: $mailbox\r\n" if !$ibx;
553 for my $it (@items) {
556 if ($it =~ /\A(?:MESSAGES|UNSEEN|RECENT)\z/) {
558 } elsif ($it eq 'UIDNEXT') {
560 } elsif ($it eq 'UIDVALIDITY') {
561 push @it, $ibx->{uidvalidity};
563 return "$tag BAD invalid item\r\n";
566 return "$tag BAD no items\r\n" if !@it;
567 "* STATUS $mailbox (".join(' ', @it).")\r\n" .
568 "$tag OK Status done\r\n";
571 my %patmap = ('*' => '.*', '%' => '[^\.]*');
572 sub cmd_list ($$$$) {
573 my ($self, $tag, $refname, $wildcard) = @_;
574 my $l = $self->{imapd}->{inboxlist};
575 if ($refname eq '' && $wildcard eq '') {
576 # request for hierarchy delimiter
577 $l = [ qq[* LIST (\\Noselect) "." ""\r\n] ];
578 } elsif ($refname ne '' || $wildcard ne '*') {
579 $wildcard = lc $wildcard;
580 $wildcard =~ s!([^a-z0-9_])!$patmap{$1} // "\Q$1"!eg;
581 $l = [ grep(/ \Q$refname\E$wildcard\r\n\z/s, @$l) ];
583 \(join('', @$l, "$tag OK List done\r\n"));
586 sub cmd_lsub ($$$$) {
587 my (undef, $tag) = @_; # same args as cmd_list
588 "$tag OK Lsub done\r\n";
591 sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
593 my ($eml, undef, $idx) = @$p;
594 if ($idx && lc($eml->ct->{type}) eq 'multipart') {
595 $eml->{imap_bdy} = $eml->{bdy} // \'';
597 $all->{$idx} = $eml; # $idx => Eml
600 # prepares an index for BODY[$SECTION_IDX] fetches
601 sub eml_body_idx ($$) {
602 my ($eml, $section_idx) = @_;
603 my $idx = $eml->{imap_all_parts} //= do {
605 $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
606 # top-level of multipart, BODY[0] not allowed (nz-number)
610 $idx->{$section_idx};
613 # BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
615 my ($eml, $section_idx, $section_name) = @_;
616 if (defined $section_idx) {
617 $eml = eml_body_idx($eml, $section_idx) or return;
619 if (defined $section_name) {
620 if ($section_name eq 'MIME') {
621 # RFC 3501 6.4.5 states:
622 # The MIME part specifier MUST be prefixed
623 # by one or more numeric part specifiers
624 return unless defined $section_idx;
625 return $eml->header_obj->as_string . "\r\n";
627 my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
628 $eml = PublicInbox::Eml->new($$bdy);
629 if ($section_name eq 'TEXT') {
630 return $eml->body_raw;
631 } elsif ($section_name eq 'HEADER') {
632 return $eml->header_obj->as_string . "\r\n";
634 die "BUG: bad section_name=$section_name";
637 ${$eml->{bdy} // $eml->{imap_bdy} // \''};
640 # similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
641 # to avoid OOM with malicious users
642 sub hdrs_regexp ($) {
644 my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
645 qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
646 # continuation lines:
647 (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
651 # BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
652 sub partial_hdr_not {
653 my ($eml, $section_idx, $hdrs_re) = @_;
654 if (defined $section_idx) {
655 $eml = eml_body_idx($eml, $section_idx) or return;
657 my $str = $eml->header_obj->as_string;
658 $str =~ s/$hdrs_re//g;
662 # BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
663 sub partial_hdr_get {
664 my ($eml, $section_idx, $hdrs_re) = @_;
665 if (defined $section_idx) {
666 $eml = eml_body_idx($eml, $section_idx) or return;
668 my $str = $eml->header_obj->as_string;
669 join('', ($str =~ m/($hdrs_re)/g), "\r\n");
672 sub partial_prepare ($$$) {
673 my ($partial, $want, $att) = @_;
675 # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
676 # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
677 return unless $att =~ /\ABODY\[/s;
678 until (rindex($att, ']') >= 0) {
679 my $next = shift @$want or return;
680 $att .= ' ' . uc($next);
682 if ($att =~ /\ABODY\[([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
683 (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
684 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
685 $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
686 } elsif ($att =~ /\ABODY\[(?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
687 (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
688 \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
689 \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
690 my $tmp = $partial->{$att} = [ $2 ? \&partial_hdr_not
693 $tmp->[2] = hdrs_regexp($3);
699 sub partial_emit ($$$) {
700 my ($self, $partial, $eml) = @_;
702 my ($k, $cb, @args) = @$_;
703 my ($offset, $len) = splice(@args, -2);
704 # $cb is partial_body|partial_hdr_get|partial_hdr_not
705 my $str = $cb->($eml, @args) // '';
706 if (defined $offset) {
708 $str = substr($str, $offset, $len);
709 $k =~ s/\.$len>\z/>/ or warn
710 "BUG: unable to remove `.$len>' from `$k'";
712 $str = substr($str, $offset);
718 $self->msg_more(" $k {$len}\r\n");
719 $self->msg_more($str);
723 sub fetch_common ($$$$) {
724 my ($self, $tag, $range_csv, $want) = @_;
725 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
726 if ($want->[0] =~ s/\A\(//s) {
727 $want->[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
729 my (%partial, %want);
730 while (defined(my $att = shift @$want)) {
732 $att =~ s/\ABODY\.PEEK\[/BODY\[/; # we're read-only
733 my $x = $FETCH_ATT{$att};
735 %want = (%want, %$x);
736 } elsif (!partial_prepare(\%partial, $want, $att)) {
737 return "$tag BAD param: $att\r\n";
741 # stabilize partial order for consistency and ease-of-debugging:
742 if (scalar keys %partial) {
743 $want{-partial} = [ map {;
744 [ $_, @{$partial{$_}} ]
745 } sort keys %partial ];
747 $range_csv = 'bad' if $range_csv !~ $valid_range;
748 my $range_info = range_step($self, \$range_csv);
749 return "$tag $range_info\r\n" if !ref($range_info);
750 [ $tag, [], $range_info, \%want ];
753 sub cmd_uid_fetch ($$$;@) {
754 my ($self, $tag, $range_csv, @want) = @_;
755 my $args = fetch_common($self, $tag, $range_csv, \@want);
756 ref($args) eq 'ARRAY' ?
757 long_response($self, \&uid_fetch_m, @$args) :
761 sub seq_fetch_m { # long_response
762 my ($self, $tag, $msgs, $range_info, $want) = @_;
763 while (!@$msgs) { # rare
764 if (my $end = refill_range($self, $msgs, $range_info)) {
765 $self->write(\"$tag $end\r\n");
769 my $seq = $want->{-seqno}++;
770 my $cur_num = $msgs->[0]->{num};
771 if ($cur_num == $seq) { # as expected
772 git_async_cat($self->{ibx}->git, $msgs->[0]->{blob},
773 \&uid_fetch_cb, \@_);
774 } elsif ($cur_num > $seq) {
775 # send dummy messages until $seq catches up to $cur_num
776 my $smsg = bless { num => $seq, ts => 0 }, 'PublicInbox::Smsg';
777 unshift @$msgs, $smsg;
778 my $bref = dummy_message($self, $seq);
779 uid_fetch_cb($bref, undef, undef, undef, \@_);
780 $smsg; # blessed response since uid_fetch_cb requeues
781 } else { # should not happen
782 die "BUG: cur_num=$cur_num < seq=$seq";
786 sub cmd_fetch ($$$;@) {
787 my ($self, $tag, $range_csv, @want) = @_;
788 my $args = fetch_common($self, $tag, $range_csv, \@want);
789 ref($args) eq 'ARRAY' ? do {
790 my $want = $args->[-1];
791 $want->{-seqno} = $args->[2]->[0]; # $beg == $range_info->[0];
792 long_response($self, \&seq_fetch_m, @$args)
797 sub parse_date ($) { # 02-Oct-1993
798 my ($date_text) = @_;
799 my ($dd, $mon, $yyyy) = split(/-/, $_[0], 3);
800 defined($yyyy) or return;
801 my $mm = $MoY{$mon} // return;
802 $dd =~ /\A[0123]?[0-9]\z/ or return;
803 $yyyy =~ /\A[0-9]{4,}\z/ or return; # Y10K-compatible!
804 timegm(0, 0, 0, $dd, $mm, $yyyy);
807 sub uid_search_all { # long_response
808 my ($self, $tag, $num) = @_;
809 my $uids = $self->{ibx}->mm->ids_after($num);
810 if (scalar(@$uids)) {
811 $self->msg_more(join(' ', '', @$uids));
813 $self->write(\"\r\n$tag OK Search done\r\n");
818 sub uid_search_uid_range { # long_response
819 my ($self, $tag, $beg, $end) = @_;
820 my $uids = $self->{ibx}->mm->msg_range($beg, $end, 'num');
822 $self->msg_more(join('', map { " $_->[0]" } @$uids));
824 $self->write(\"\r\n$tag OK Search done\r\n");
830 my ($q, $k, $d) = @_;
834 if ($k eq 'SENTON') {
835 my $end = $d + 86399; # no leap day...
836 my $da = strftime('%Y%m%d%H%M%S', gmtime($d));
837 my $db = strftime('%Y%m%d%H%M%S', gmtime($end));
838 $q->{xap} .= " dt:$da..$db";
839 $$sql .= " AND ds >= $d AND ds <= $end" if defined($sql);
840 } elsif ($k eq 'SENTBEFORE') {
841 $q->{xap} .= ' d:..'.strftime('%Y%m%d', gmtime($d));
842 $$sql .= " AND ds <= $d" if defined($sql);
843 } elsif ($k eq 'SENTSINCE') {
844 $q->{xap} .= ' d:'.strftime('%Y%m%d', gmtime($d)).'..';
845 $$sql .= " AND ds >= $d" if defined($sql);
847 # INTERNALDATE (Received)
848 } elsif ($k eq 'ON') {
849 my $end = $d + 86399; # no leap day...
850 $q->{xap} .= " ts:$d..$end";
851 $$sql .= " AND ts >= $d AND ts <= $end" if defined($sql);
852 } elsif ($k eq 'BEFORE') {
853 $q->{xap} .= " ts:..$d";
854 $$sql .= " AND ts <= $d" if defined($sql);
855 } elsif ($k eq 'SINCE') {
856 $q->{xap} .= " ts:$d..";
857 $$sql .= " AND ts >= $d" if defined($sql);
859 die "BUG: $k not recognized";
863 # IMAP to Xapian search key mapping
868 TEXT => '', # n.b. does not include all headers
871 # BCC => 'bcc:', # TODO
872 # KEYWORD # TODO ? dfpre,dfpost,...
876 my ($self, $rest) = @_;
877 if (uc($rest->[0]) eq 'CHARSET') {
879 defined(my $c = shift @$rest) or return 'BAD missing charset';
880 $c =~ /\A(?:UTF-8|US-ASCII)\z/ or return 'NO [BADCHARSET]';
883 my $sql = ''; # date conditions, {sql} deleted if Xapian is needed
884 my $q = { xap => '', sql => \$sql };
886 my $k = uc(shift @$rest);
888 next if $k =~ /\A(?:ALL|RECENT|UNSEEN|NEW)\z/;
889 next if $k eq 'AND'; # the default, until we support OR
890 if ($k =~ $valid_range) { # sequence numbers == UIDs
891 push @{$q->{uid}}, $k;
892 } elsif ($k eq 'UID') {
893 $k = shift(@$rest) // '';
894 $k =~ $valid_range or return 'BAD UID range';
895 push @{$q->{uid}}, $k;
896 } elsif ($k =~ /\A(?:SENT)?(?:SINCE|ON|BEFORE)\z/) {
897 my $d = parse_date(shift(@$rest) // '');
898 defined $d or return "BAD $k date format";
899 date_search($q, $k, $d);
900 } elsif ($k =~ /\A(?:SMALLER|LARGER)\z/) {
901 delete $q->{sql}; # can't use over.sqlite3
902 my $bytes = shift(@$rest) // '';
903 $bytes =~ /\A[0-9]+\z/ or return "BAD $k not a number";
904 $q->{xap} .= ' bytes:' . ($k eq 'SMALLER' ?
907 } elsif (defined(my $xk = $I2X{$k})) {
908 delete $q->{sql}; # can't use over.sqlite3
909 my $arg = shift @$rest;
910 defined($arg) or return "BAD $k no arg";
912 # Xapian can't handle [*"] in probabilistic terms
914 $q->{xap} .= qq[ $xk:"$arg"];
916 # TODO: parentheses, OR, NOT ...
917 return "BAD $k not supported (yet?)";
921 # favor using over.sqlite3 if possible, since Xapian is optional
922 if (exists $q->{sql}) {
924 delete($q->{sql}) if $sql eq '';
925 } elsif (!$self->{ibx}->search) {
926 return 'BAD Xapian not configured for mailbox';
929 if (my $uid = $q->{uid}) {
930 ((@$uid > 1) || $uid->[0] =~ /,/) and
931 return 'BAD multiple ranges not supported, yet';
932 ($q->{sql} // $q->{xap}) and
933 return 'BAD ranges and queries do not mix, yet';
934 $q->{uid} = join(',', @$uid); # TODO: multiple ranges
939 sub cmd_uid_search ($$$;) {
940 my ($self, $tag) = splice(@_, 0, 2);
941 my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
942 my $q = parse_query($self, \@_);
943 return "$tag $q\r\n" if !ref($q);
945 if (!scalar(keys %$q)) {
946 $self->msg_more('* SEARCH');
948 long_response($self, \&uid_search_all, $tag, \$num);
949 } elsif (my $uid = $q->{uid}) {
950 if ($uid =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
951 my ($beg, $end) = ($1, $2);
952 $end = $ibx->mm->max if $end eq '*';
953 $self->msg_more('* SEARCH');
954 long_response($self, \&uid_search_uid_range,
956 } elsif ($uid =~ /\A[0-9]+\z/s) {
957 $uid = $ibx->over->get_art($uid) ? " $uid" : '';
958 "* SEARCH$uid\r\n$tag OK Search done\r\n";
960 "$tag BAD Error\r\n";
963 "$tag BAD Error\r\n";
967 sub args_ok ($$) { # duplicated from PublicInbox::NNTP
968 my ($cb, $argc) = @_;
969 my $tot = prototype $cb;
970 my ($nreq, undef) = split(';', $tot);
971 $nreq = ($nreq =~ tr/$//) - 1;
972 $tot = ($tot =~ tr/$//) - 1;
973 ($argc <= $tot && $argc >= $nreq);
976 # returns 1 if we can continue, 0 if not due to buffered writes or disconnect
977 sub process_line ($$) {
979 my ($tag, $req, @args) = parse_line('[ \t]+', 0, $l);
980 pop(@args) if (@args && !defined($args[-1]));
981 if (@args && uc($req) eq 'UID') {
982 $req .= "_".(shift @args);
985 if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
986 defined($self->{-idle_tag}) ?
987 "$self->{-idle_tag} BAD expected DONE\r\n" :
988 $cmd->($self, $tag, @args);
989 } elsif (uc($tag // '') eq 'DONE' && !defined($req)) {
990 cmd_done($self, $tag);
991 } else { # this is weird
992 auth_challenge_ok($self) //
994 ' BAD Error in IMAP command '.
996 ": Unknown command\r\n";
1000 if ($err && $self->{sock}) {
1002 err($self, 'error from: %s (%s)', $l, $err);
1004 $res = "$tag BAD program fault - command not performed\r\n";
1006 return 0 unless defined $res;
1012 # wbuf is unset or empty, here; {long} may add to it
1013 my ($fd, $cb, $t0, @args) = @{$self->{long_cb}};
1014 my $more = eval { $cb->($self, @args) };
1015 if ($@ || !$self->{sock}) { # something bad happened...
1016 delete $self->{long_cb};
1017 my $elapsed = now() - $t0;
1020 "%s during long response[$fd] - %0.6f",
1023 out($self, " deferred[$fd] aborted - %0.6f", $elapsed);
1025 } elsif ($more) { # $self->{wbuf}:
1026 $self->update_idle_time;
1028 # control passed to $more may be a GitAsyncCat object
1029 requeue_once($self) if !ref($more);
1030 } else { # all done!
1031 delete $self->{long_cb};
1032 my $elapsed = now() - $t0;
1033 my $fd = fileno($self->{sock});
1034 out($self, " deferred[$fd] done - %0.6f", $elapsed);
1035 my $wbuf = $self->{wbuf}; # do NOT autovivify
1037 $self->requeue unless $wbuf && @$wbuf;
1042 my ($self, $fmt, @args) = @_;
1043 printf { $self->{imapd}->{err} } $fmt."\n", @args;
1047 my ($self, $fmt, @args) = @_;
1048 printf { $self->{imapd}->{out} } $fmt."\n", @args;
1051 sub long_response ($$;@) {
1052 my ($self, $cb, @args) = @_; # cb returns true if more, false if done
1054 my $sock = $self->{sock} or return;
1055 # make sure we disable reading during a long response,
1056 # clients should not be sending us stuff and making us do more
1057 # work while we are stream a response to them
1058 $self->{long_cb} = [ fileno($sock), $cb, now(), @args ];
1059 long_step($self); # kick off!
1063 # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err)
1067 return unless $self->flush_write && $self->{sock} && !$self->{long_cb};
1069 $self->update_idle_time;
1070 # only read more requests if we've drained the write buffer,
1071 # otherwise we can be buffering infinitely w/o backpressure
1073 my $rbuf = $self->{rbuf} // \(my $x = '');
1074 my $line = index($$rbuf, "\n");
1076 return $self->close if length($$rbuf) >= LINE_MAX;
1077 $self->do_read($rbuf, LINE_MAX, length($$rbuf)) or return;
1078 $line = index($$rbuf, "\n");
1080 $line = substr($$rbuf, 0, $line + 1, '');
1081 $line =~ s/\r?\n\z//s;
1082 return $self->close if $line =~ /[[:cntrl:]]/s;
1084 my $fd = fileno($self->{sock});
1085 my $r = eval { process_line($self, $line) };
1086 my $pending = $self->{wbuf} ? ' pending' : '';
1087 out($self, "[$fd] %s - %0.6f$pending - $r", $line, now() - $t0);
1089 return $self->close if $r < 0;
1090 $self->rbuf_idle($rbuf);
1091 $self->update_idle_time;
1093 # maybe there's more pipelined data, or we'll have
1094 # to register it for socket-readiness notifications
1095 $self->requeue unless $pending;
1098 sub compressed { undef }
1100 sub zflush {} # overridden by IMAPdeflate
1103 sub cmd_compress ($$$) {
1104 my ($self, $tag, $alg) = @_;
1105 return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
1106 return "$tag BAD COMPRESS active\r\n" if $self->compressed;
1108 # CRIME made TLS compression obsolete
1109 # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
1111 PublicInbox::IMAPdeflate->enable($self, $tag);
1116 sub cmd_starttls ($$) {
1117 my ($self, $tag) = @_;
1118 my $sock = $self->{sock} or return;
1119 if ($sock->can('stop_SSL') || $self->compressed) {
1120 return "$tag BAD TLS or compression already enabled\r\n";
1122 my $opt = $self->{imapd}->{accept_tls} or
1123 return "$tag BAD can not initiate TLS negotiation\r\n";
1124 $self->write(\"$tag OK begin TLS negotiation now\r\n");
1125 $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
1126 $self->requeue if PublicInbox::DS::accept_tls_step($self);
1130 # for graceful shutdown in PublicInbox::Daemon:
1132 my ($self, $now) = @_;
1133 ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
1138 if (my $ibx = delete $self->{ibx}) {
1139 if (my $sock = $self->{sock}) {;
1140 $ibx->unsubscribe_unlock(fileno($sock));
1143 $self->SUPER::close; # PublicInbox::DS::close
1146 # we're read-only, so SELECT and EXAMINE do the same thing
1148 *cmd_select = \&cmd_examine;