diff options
Diffstat (limited to 'lib/PublicInbox/IMAP.pm')
| -rw-r--r-- | lib/PublicInbox/IMAP.pm | 199 |
1 files changed, 64 insertions, 135 deletions
diff --git a/lib/PublicInbox/IMAP.pm b/lib/PublicInbox/IMAP.pm index d47e4c2f..b12533cb 100644 --- a/lib/PublicInbox/IMAP.pm +++ b/lib/PublicInbox/IMAP.pm @@ -36,18 +36,10 @@ use parent qw(PublicInbox::DS); use PublicInbox::Eml; use PublicInbox::EmlContentFoo qw(parse_content_disposition); use PublicInbox::DS qw(now); -use PublicInbox::Syscall qw(EPOLLIN EPOLLONESHOT); use PublicInbox::GitAsyncCat; use Text::ParseWords qw(parse_line); use Errno qw(EAGAIN); -use PublicInbox::IMAPsearchqp; - -my $Address; -for my $mod (qw(Email::Address::XS Mail::Address)) { - eval "require $mod" or next; - $Address = $mod and last; -} -die "neither Email::Address::XS nor Mail::Address loaded: $@" if !$Address; +use PublicInbox::Address; sub LINE_MAX () { 8000 } # RFC 2683 3.2.1.5 @@ -99,29 +91,15 @@ undef %FETCH_NEED; my $valid_range = '[0-9]+|[0-9]+:[0-9]+|[0-9]+:\*'; $valid_range = qr/\A(?:$valid_range)(?:,(?:$valid_range))*\z/; -sub greet ($) { +sub do_greet { my ($self) = @_; my $capa = capa($self); $self->write(\"* OK [$capa] public-inbox-imapd ready\r\n"); } -sub new ($$$) { - my ($class, $sock, $imapd) = @_; - my $self = bless { imapd => $imapd }, 'PublicInbox::IMAP_preauth'; - my $ev = EPOLLIN; - my $wbuf; - if ($sock->can('accept_SSL') && !$sock->accept_SSL) { - return CORE::close($sock) if $! != EAGAIN; - $ev = PublicInbox::TLS::epollbit() or return CORE::close($sock); - $wbuf = [ \&PublicInbox::DS::accept_tls_step, \&greet ]; - } - $self->SUPER::new($sock, $ev | EPOLLONESHOT); - if ($wbuf) { - $self->{wbuf} = $wbuf; - } else { - greet($self); - } - $self; +sub new { + my (undef, $sock, $imapd) = @_; + (bless { imapd => $imapd }, 'PublicInbox::IMAP_preauth')->greet($sock) } sub logged_in { 1 } @@ -136,7 +114,7 @@ sub capa ($) { $capa .= ' COMPRESS=DEFLATE'; } else { if (!($self->{sock} // $self)->can('accept_SSL') && - $self->{imapd}->{accept_tls}) { + $self->{imapd}->{ssl_ctx_opt}) { $capa .= ' STARTTLS'; } $capa .= ' AUTH=ANONYMOUS'; @@ -153,6 +131,7 @@ sub login_success ($$) { sub auth_challenge_ok ($) { my ($self) = @_; my $tag = delete($self->{-login_tag}) or return; + $self->{anon} = 1; login_success($self, $tag); } @@ -365,21 +344,18 @@ sub idle_done ($$) { "$idle_tag OK Idle done\r\n"; } -sub ensure_slices_exist ($$$) { - my ($imapd, $ibx, $max) = @_; - defined(my $mb_top = $ibx->{newsgroup}) or return; +sub ensure_slices_exist ($$) { + my ($imapd, $ibx) = @_; + my $mb_top = $ibx->{newsgroup} // return; my $mailboxes = $imapd->{mailboxes}; - my @created; - for (my $i = int($max/UID_SLICE); $i >= 0; --$i) { + my $list = $imapd->{mailboxlist}; # may be undef, just autoviv + noop + for (my $i = int($ibx->art_max/UID_SLICE); $i >= 0; --$i) { my $sub_mailbox = "$mb_top.$i"; last if exists $mailboxes->{$sub_mailbox}; $mailboxes->{$sub_mailbox} = $ibx; $sub_mailbox =~ s/\Ainbox\./INBOX./i; # more familiar to users - push @created, $sub_mailbox; + push @$list, qq[* LIST (\\HasNoChildren) "." $sub_mailbox\r\n] } - return unless @created; - my $l = $imapd->{mailboxlist} or return; - push @$l, map { qq[* LIST (\\HasNoChildren) "." $_\r\n] } @created; } sub inbox_lookup ($$;$) { @@ -399,9 +375,11 @@ sub inbox_lookup ($$;$) { $self->{ibx} = $ibx; $self->{uo2m} = uo2m_ary_new($self, \$exists); } else { - $exists = $over->imap_exists; + my $uid_end = $uid_base + UID_SLICE; + $exists = $over->imap_exists($uid_base, $uid_end); } - ensure_slices_exist($self->{imapd}, $ibx, $over->max); + delete $ibx->{-art_max}; + ensure_slices_exist($self->{imapd}, $ibx); } else { if ($examine) { $self->{uid_base} = $uid_base; @@ -410,9 +388,9 @@ sub inbox_lookup ($$;$) { } # if "INBOX.foo.bar" is selected and "INBOX.foo.bar.0", # check for new UID ranges (e.g. "INBOX.foo.bar.1") - if (my $z = $self->{imapd}->{mailboxes}->{"$mailbox.0"}) { - ensure_slices_exist($self->{imapd}, $z, - $z->over(1)->max); + if (my $ibx = $self->{imapd}->{mailboxes}->{"$mailbox.0"}) { + delete $ibx->{-art_max}; + ensure_slices_exist($self->{imapd}, $ibx); } } ($ibx, $exists, $uidmax + 1, $uid_base); @@ -441,8 +419,10 @@ sub _esc ($) { if (!defined($v)) { 'NIL'; } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string + utf8::encode($v); '{' . length($v) . "}\r\n" . $v; } else { # quoted string + utf8::encode($v); qq{"$v"} } } @@ -452,7 +432,7 @@ sub addr_envelope ($$;$) { my $v = $eml->header_raw($x) // ($y ? $eml->header_raw($y) : undef) // return 'NIL'; - my @x = $Address->parse($v) or return 'NIL'; + my @x = PublicInbox::Address::objects($v) or return 'NIL'; '(' . join('', map { '(' . join(' ', _esc($_->name), 'NIL', @@ -577,22 +557,6 @@ sub fetch_body ($;$) { join('', @hold); } -sub requeue_once ($) { - my ($self) = @_; - # COMPRESS users all share the same DEFLATE context. - # Flush it here to ensure clients don't see - # each other's data - $self->zflush; - - # no recursion, schedule another call ASAP, - # but only after all pending writes are done. - # autovivify wbuf: - my $new_size = push(@{$self->{wbuf}}, \&long_step); - - # wbuf may be populated by $cb, no need to rearm if so: - $self->requeue if $new_size == 1; -} - sub fetch_run_ops { my ($self, $smsg, $bref, $ops, $partial) = @_; my $uid = $smsg->{num}; @@ -606,26 +570,37 @@ sub fetch_run_ops { $self->msg_more(")\r\n"); } +sub requeue { # overrides PublicInbox::DS::requeue + my ($self) = @_; + if ($self->{anon}) { # AUTH=ANONYMOUS gets high priority + $self->SUPER::requeue; + } else { # low priority + push(@{$self->{imapd}->{-authed_q}}, $self) == 1 and + PublicInbox::DS::requeue($self->{imapd}); + } +} + sub fetch_blob_cb { # called by git->cat_async via ibx_async_cat my ($bref, $oid, $type, $size, $fetch_arg) = @_; my ($self, undef, $msgs, $range_info, $ops, $partial) = @$fetch_arg; my $ibx = $self->{ibx} or return $self->close; # client disconnected my $smsg = shift @$msgs or die 'BUG: no smsg'; - if (!defined($oid)) { + if (!defined($type)) { + warn "E: git aborted on $oid / $smsg->{blob} $ibx->{inboxdir}"; + return $self->close; + } elsif ($type ne 'blob') { # it's possible to have TOCTOU if an admin runs # public-inbox-(edit|purge), just move onto the next message - warn "E: $smsg->{blob} missing in $ibx->{inboxdir}\n"; - return requeue_once($self); - } else { - $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid"; + warn "E: $smsg->{blob} $type in $ibx->{inboxdir}\n"; + return $self->requeue_once; } + $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid"; my $pre; - if (!$self->{wbuf} && (my $nxt = $msgs->[0])) { - $pre = ibx_async_prefetch($ibx, $nxt->{blob}, + ($self->{anon} && !$self->{wbuf} && $msgs->[0]) and + $pre = ibx_async_prefetch($ibx, $msgs->[0]->{blob}, \&fetch_blob_cb, $fetch_arg); - } fetch_run_ops($self, $smsg, $bref, $ops, $partial); - $pre ? $self->zflush : requeue_once($self); + $pre ? $self->dflush : $self->requeue_once; } sub emit_rfc822 { @@ -683,7 +658,7 @@ sub op_eml_new { $_[4] = PublicInbox::Eml->new($_[3]) } # s/From / fixes old bug from import (pre-a0c07cba0e5d8b6a) sub to_crlf_full { ${$_[0]} =~ s/(?<!\r)\n/\r\n/sg; - ${$_[0]} =~ s/\A[\r\n]*From [^\r\n]*\r\n//s; + PublicInbox::Eml::strip_from(${$_[0]}); } sub op_crlf_bref { to_crlf_full($_[3]) } @@ -1027,7 +1002,7 @@ sub fetch_compile ($) { # stabilize partial order for consistency and ease-of-debugging: if (scalar keys %partial) { $need |= NEED_BLOB; - $r[2] = [ map { [ $_, @{$partial{$_}} ] } sort keys %partial ]; + @{$r[2]} = map { [ $_, @{$partial{$_}} ] } sort keys %partial; } push @op, $OP_EML_NEW if ($need & (EML_HDR|EML_BDY)); @@ -1050,7 +1025,7 @@ sub fetch_compile ($) { # r[1] = [ $key1, $cb1, $key2, $cb2, ... ] use sort 'stable'; # makes output more consistent - $r[1] = [ map { ($_->[2], $_->[1]) } sort { $a->[0] <=> $b->[0] } @op ]; + @{$r[1]} = map { ($_->[2], $_->[1]) } sort { $a->[0] <=> $b->[0] } @op; @r; } @@ -1065,7 +1040,7 @@ sub cmd_uid_fetch ($$$$;@) { my $range_info = range_step($self, \$range_csv); return "$tag $range_info\r\n" if !ref($range_info); uo2m_hibernate($self) if $cb == \&fetch_blob; # slow, save RAM - long_response($self, $cb, $tag, [], $range_info, $ops, $partial); + $self->long_response($cb, $tag, [], $range_info, $ops, $partial); } sub cmd_fetch ($$$$;@) { @@ -1080,7 +1055,7 @@ sub cmd_fetch ($$$$;@) { my $range_info = range_step($self, \$range_csv); return "$tag $range_info\r\n" if !ref($range_info); uo2m_hibernate($self) if $cb == \&fetch_blob; # slow, save RAM - long_response($self, $cb, $tag, [], $range_info, $ops, $partial); + $self->long_response($cb, $tag, [], $range_info, $ops, $partial); } sub msn_convert ($$) { @@ -1106,6 +1081,7 @@ sub search_uid_range { # long_response sub parse_imap_query ($$) { my ($self, $query) = @_; + # IMAPsearchqp gets loaded in IMAPD->refresh_groups my $q = PublicInbox::IMAPsearchqp::parse($self, $query); if (ref($q)) { my $max = $self->{ibx}->over(1)->max; @@ -1124,7 +1100,7 @@ sub search_common { my ($sql, $range_info) = delete @$q{qw(sql range_info)}; if (!scalar(keys %$q)) { # overview.sqlite3 $self->msg_more('* SEARCH'); - long_response($self, \&search_uid_range, + $self->long_response(\&search_uid_range, $tag, $sql, $range_info, $want_msn); } elsif ($q = $q->{xap}) { my $srch = $self->{ibx}->isrch or @@ -1187,46 +1163,11 @@ sub process_line ($$) { my $err = $@; if ($err && $self->{sock}) { $l =~ s/\r?\n//s; - err($self, 'error from: %s (%s)', $l, $err); + warn("error from: $l ($err)\n"); $tag //= '*'; - $res = "$tag BAD program fault - command not performed\r\n"; + $res = \"$tag BAD program fault - command not performed\r\n"; } - return 0 unless defined $res; - $self->write($res); -} - -sub long_step { - my ($self) = @_; - # wbuf is unset or empty, here; {long} may add to it - my ($fd, $cb, $t0, @args) = @{$self->{long_cb}}; - my $more = eval { $cb->($self, @args) }; - if ($@ || !$self->{sock}) { # something bad happened... - delete $self->{long_cb}; - my $elapsed = now() - $t0; - if ($@) { - err($self, - "%s during long response[$fd] - %0.6f", - $@, $elapsed); - } - out($self, " deferred[$fd] aborted - %0.6f", $elapsed); - $self->close; - } elsif ($more) { # $self->{wbuf}: - # control passed to ibx_async_cat if $more == \undef - requeue_once($self) if !ref($more); - } else { # all done! - delete $self->{long_cb}; - my $elapsed = now() - $t0; - my $fd = fileno($self->{sock}); - out($self, " deferred[$fd] done - %0.6f", $elapsed); - my $wbuf = $self->{wbuf}; # do NOT autovivify - - $self->requeue unless $wbuf && @$wbuf; - } -} - -sub err ($$;@) { - my ($self, $fmt, @args) = @_; - printf { $self->{imapd}->{err} } $fmt."\n", @args; + defined($res) ? $self->write($res) : 0; } sub out ($$;@) { @@ -1234,22 +1175,10 @@ sub out ($$;@) { printf { $self->{imapd}->{out} } $fmt."\n", @args; } -sub long_response ($$;@) { - my ($self, $cb, @args) = @_; # cb returns true if more, false if done - - my $sock = $self->{sock} or return; - # make sure we disable reading during a long response, - # clients should not be sending us stuff and making us do more - # work while we are stream a response to them - $self->{long_cb} = [ fileno($sock), $cb, now(), @args ]; - long_step($self); # kick off! - undef; -} - # callback used by PublicInbox::DS for any (e)poll (in/out/hup/err) sub event_step { my ($self) = @_; - + local $SIG{__WARN__} = $self->{imapd}->{warn_cb}; return unless $self->flush_write && $self->{sock} && !$self->{long_cb}; # only read more requests if we've drained the write buffer, @@ -1283,10 +1212,6 @@ sub event_step { $self->requeue unless $pending; } -sub compressed { undef } - -sub zflush {} # overridden by IMAPdeflate - # RFC 4978 sub cmd_compress ($$$) { my ($self, $tag, $alg) = @_; @@ -1296,21 +1221,21 @@ sub cmd_compress ($$$) { # CRIME made TLS compression obsolete # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed; - PublicInbox::IMAPdeflate->enable($self, $tag); + PublicInbox::IMAPdeflate->enable($self) or return + \"$tag BAD failed to activate compression\r\n"; + PublicInbox::DS::write($self, \"$tag OK DEFLATE active\r\n"); $self->requeue; undef } sub cmd_starttls ($$) { my ($self, $tag) = @_; - my $sock = $self->{sock} or return; - if ($sock->can('stop_SSL') || $self->compressed) { + (($self->{sock} // return)->can('stop_SSL') || $self->compressed) and return "$tag BAD TLS or compression already enabled\r\n"; - } - my $opt = $self->{imapd}->{accept_tls} or + $self->{imapd}->{ssl_ctx_opt} or return "$tag BAD can not initiate TLS negotiation\r\n"; $self->write(\"$tag OK begin TLS negotiation now\r\n"); - $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt); + PublicInbox::TLS::start($self->{sock}, $self->{imapd}); $self->requeue if PublicInbox::DS::accept_tls_step($self); undef; } @@ -1342,4 +1267,8 @@ our @ISA = qw(PublicInbox::IMAP); sub logged_in { 0 } +package PublicInbox::IMAPdeflate; +use PublicInbox::DSdeflate; +our @ISA = qw(PublicInbox::DSdeflate PublicInbox::IMAP); + 1; |