--- /dev/null
+=head1 NAME
+
+public-inbox-imapd - IMAP server for sharing public-inboxes
+
+=head1 SYNOPSIS
+
+B<public-inbox-imapd> [OPTIONS]
+
+=head1 DESCRIPTION
+
+public-inbox-imapd provides a read-only IMAP daemon for
+public-inbox. It uses options and environment variables common
+to all L<public-inbox-daemon(8)> implementations.
+
+Like L<public-inbox-nntpd(1)> and L<public-inbox-httpd(1)>,
+C<public-inbox-imapd> will never require write access
+to the directory where the public-inboxes are stored, so it
+may be run as a different user than the user running
+L<public-inbox-watch(1)>, L<public-inbox-mda(1)>, or
+L<git-fetch(1)>.
+
+=head1 OPTIONS
+
+See common options in L<public-inbox-daemon(8)/OPTIONS>.
+Additionally, IMAP-specific behavior for certain options
+are supported and documented below.
+
+=over
+
+=item -l, --listen PROTO://ADDRESS/?cert=/path/to/cert,key=/path/to/key
+
+In addition to the normal C<-l>/C<--listen> switch described in
+L<public-inbox-daemon(8)>, the C<PROTO> prefix (e.g. C<imap://> or
+C<imaps://>) may be specified to force a given protocol.
+
+For STARTTLS and IMAPS support, the C<cert> and C<key> may be specified
+on a per-listener basis after a C<?> character and separated by C<,>.
+These directives are per-directive, and it's possible to use a different
+cert for every listener.
+
+=item --cert /path/to/cert
+
+The default TLS certificate for optional STARTTLS and IMAPS support
+if the C<cert> option is not given with C<--listen>.
+
+If using systemd-compatible socket activation and a TCP listener on port
+993 is inherited, it is automatically IMAPS when this option is given.
+When a listener on port 143 is inherited and this option is given, it
+automatically gets STARTTLS support.
+
+=item --key /path/to/key
+
+The default private TLS certificate key for optional STARTTLS and IMAPS
+support if the C<key> option is not given with C<--listen>. The private
+key may concatenated into the path used by C<--cert>, in which case this
+option is not needed.
+
+=back
+
+=head1 CONFIGURATION
+
+C<public-inbox-imapd> uses the same configuration knobs
+as L<public-inbox-nntpd(1)>, see L<public-inbox-nntpd(1)>
+and L<public-inbox-config(5)>.
+
+=over 8
+
+=item publicinbox.<name>.newsgroup
+
+The newsgroup name maps to an IMAP folder name.
+
+=back
+
+=head1 CONTACT
+
+Feedback welcome via plain-text mail to L<mailto:meta@public-inbox.org>
+
+The mail archives are hosted at L<https://public-inbox.org/meta/>,
+L<nntp://news.public-inbox.org/inbox.comp.mail.public-inbox.meta>,
+L<nntp://hjrcffqmbrq6wope.onion/inbox.comp.mail.public-inbox.meta>
+
+=head1 COPYRIGHT
+
+Copyright 2020 all contributors L<mailto:meta@public-inbox.org>
+
+License: AGPL-3.0+ L<https://www.gnu.org/licenses/agpl-3.0.txt>
+
+=head1 SEE ALSO
+
+L<git(1)>, L<git-config(1)>, L<public-inbox-daemon(8)>,
+L<public-inbox-config(5)>, L<public-inbox-nntpd(1)>
Documentation/public-inbox-daemon.pod
Documentation/public-inbox-edit.pod
Documentation/public-inbox-httpd.pod
+Documentation/public-inbox-imapd.pod
Documentation/public-inbox-index.pod
Documentation/public-inbox-init.pod
Documentation/public-inbox-learn.pod
lib/PublicInbox/HTTPD/Async.pm
lib/PublicInbox/HlMod.pm
lib/PublicInbox/Hval.pm
+lib/PublicInbox/IMAP.pm
+lib/PublicInbox/IMAPD.pm
+lib/PublicInbox/IMAPdeflate.pm
lib/PublicInbox/Import.pm
lib/PublicInbox/Inbox.pm
lib/PublicInbox/InboxWritable.pm
script/public-inbox-convert
script/public-inbox-edit
script/public-inbox-httpd
+script/public-inbox-imapd
script/public-inbox-index
script/public-inbox-init
script/public-inbox-learn
t/httpd-unix.t
t/httpd.t
t/hval.t
+t/imapd-tls.t
+t/imapd.t
t/import.t
t/inbox.t
t/index-git-times.t
# Copyright (C) 2015-2020 all contributors <meta@public-inbox.org>
# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
-# contains common daemon code for the nntpd and httpd servers.
+# contains common daemon code for the httpd, imapd, and nntpd servers.
# This may be used for read-only IMAP server if we decide to implement it.
package PublicInbox::Daemon;
use strict;
my $reexec_pid;
my ($uid, $gid);
my ($default_cert, $default_key);
-my %KNOWN_TLS = ( 443 => 'https', 563 => 'nntps' );
-my %KNOWN_STARTTLS = ( 119 => 'nntp' );
+my %KNOWN_TLS = ( 443 => 'https', 563 => 'nntps', 993 => 'imaps' );
+my %KNOWN_STARTTLS = ( 119 => 'nntp', 143 => 'imap' );
sub accept_tls_opt ($) {
my ($opt_str) = @_;
$tls_opt{"$scheme://$l"} = accept_tls_opt($1);
} elsif (defined($default_cert)) {
$tls_opt{"$scheme://$l"} = accept_tls_opt('');
- } elsif ($scheme =~ /\A(?:nntps|https)\z/) {
+ } elsif ($scheme =~ /\A(?:https|imaps|imaps)\z/) {
die "$orig specified w/o cert=\n";
}
# TODO: use scheme to load either NNTP.pm or HTTP.pm
}
sub daemon_loop ($$$$) {
- my ($refresh, $post_accept, $nntpd, $af_default) = @_;
+ my ($refresh, $post_accept, $tlsd, $af_default) = @_;
my %post_accept;
while (my ($k, $v) = each %tls_opt) {
- if ($k =~ s!\A(?:nntps|https)://!!) {
+ if ($k =~ s!\A(?:https|imaps|nntps)://!!) {
$post_accept{$k} = tls_start_cb($v, $post_accept);
- } elsif ($nntpd) { # STARTTLS, $k eq '' is OK
- $nntpd->{accept_tls} = $v;
+ } elsif ($tlsd) { # STARTTLS, $k eq '' is OK
+ $tlsd->{accept_tls} = $v;
}
}
my $sig = {
@listeners = map {;
my $tls_cb = $post_accept{sockname($_)};
- # NNTPS, HTTPS, HTTP, and POP3S are client-first traffic
- # NNTP and POP3 are server-first
+ # NNTPS, HTTPS, HTTP, IMAPS and POP3S are client-first traffic
+ # IMAP, NNTP and POP3 are server-first
defer_accept($_, $tls_cb ? 'dataready' : $af_default);
# this calls epoll_create:
}
sub run ($$$;$) {
- my ($default, $refresh, $post_accept, $nntpd) = @_;
+ my ($default, $refresh, $post_accept, $tlsd) = @_;
local $SIG{PIPE} = 'IGNORE';
daemon_prepare($default);
my $af_default = $default =~ /:8080\z/ ? 'httpready' : undef;
my $for_destroy = daemonize();
- daemon_loop($refresh, $post_accept, $nntpd, $af_default);
+ daemon_loop($refresh, $post_accept, $tlsd, $af_default);
PublicInbox::DS->Reset;
# ->DESTROY runs when $for_destroy goes out-of-scope
}
--- /dev/null
+# Copyright (C) 2020 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+#
+# Each instance of this represents an IMAP client connected to
+# public-inbox-imapd. Much of this was taken from NNTP, but
+# further refined while experimenting on future ideas to handle
+# slow storage.
+#
+# data notes:
+# * NNTP article numbers are UIDs and message sequence numbers (MSNs)
+# * Message sequence numbers (MSNs) can be stable since we're read-only.
+# Most IMAP clients use UIDs (I hope), and we can return a dummy
+# message if a client requests a non-existent MSN.
+
+package PublicInbox::IMAP;
+use strict;
+use base qw(PublicInbox::DS);
+use fields qw(imapd logged_in ibx long_cb -login_tag);
+use PublicInbox::Eml;
+use PublicInbox::DS qw(now);
+use PublicInbox::Syscall qw(EPOLLIN EPOLLONESHOT);
+use Errno qw(EAGAIN);
+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;
+
+sub LINE_MAX () { 512 } # does RFC 3501 have a limit like RFC 977?
+
+my %FETCH_NEED_BLOB = ( # for future optimization
+ 'BODY.PEEK[HEADER]' => 1,
+ 'BODY.PEEK[TEXT]' => 1,
+ 'BODY.PEEK[]' => 1,
+ 'BODY[HEADER]' => 1,
+ 'BODY[TEXT]' => 1,
+ 'BODY[]' => 1,
+ 'RFC822.HEADER' => 1,
+ 'RFC822.SIZE' => 1, # needs CRLF conversion :<
+ 'RFC822.TEXT' => 1,
+ BODY => 1,
+ BODYSTRUCTURE => 1,
+ ENVELOPE => 1,
+ FLAGS => 0,
+ INTERNALDATE => 0,
+ RFC822 => 1,
+ UID => 0,
+);
+my %FETCH_ATT = map { $_ => [ $_ ] } keys %FETCH_NEED_BLOB;
+
+# aliases (RFC 3501 section 6.4.5)
+$FETCH_ATT{FAST} = [ qw(FLAGS INTERNALDATE RFC822.SIZE) ];
+$FETCH_ATT{ALL} = [ @{$FETCH_ATT{FAST}}, 'ENVELOPE' ];
+$FETCH_ATT{FULL} = [ @{$FETCH_ATT{ALL}}, 'BODY' ];
+
+for my $att (keys %FETCH_ATT) {
+ my %h = map { $_ => 1 } @{$FETCH_ATT{$att}};
+ $FETCH_ATT{$att} = \%h;
+}
+
+sub 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 = fields::new($class);
+ my $ev = EPOLLIN;
+ my $wbuf;
+ if ($sock->can('accept_SSL') && !$sock->accept_SSL) {
+ return CORE::close($sock) if $! != EAGAIN;
+ $ev = PublicInbox::TLS::epollbit();
+ $wbuf = [ \&PublicInbox::DS::accept_tls_step, \&greet ];
+ }
+ $self->SUPER::new($sock, $ev | EPOLLONESHOT);
+ $self->{imapd} = $imapd;
+ if ($wbuf) {
+ $self->{wbuf} = $wbuf;
+ } else {
+ greet($self);
+ }
+ $self->update_idle_time;
+ $self;
+}
+
+sub capa ($) {
+ my ($self) = @_;
+ my $capa = 'CAPABILITY IMAP4rev1';
+ if ($self->{logged_in}) {
+ $capa .= ' COMPRESS=DEFLATE';
+ } else {
+ if (!($self->{sock} // $self)->can('accept_SSL') &&
+ $self->{imapd}->{accept_tls}) {
+ $capa .= ' STARTTLS';
+ }
+ $capa .= ' AUTH=ANONYMOUS';
+ }
+}
+
+sub login_success ($$) {
+ my ($self, $tag) = @_;
+ $self->{logged_in} = 1;
+ my $capa = capa($self);
+ "$tag OK [$capa] Logged in\r\n";
+}
+
+sub auth_challenge_ok ($) {
+ my ($self) = @_;
+ my $tag = delete($self->{-login_tag}) or return;
+ login_success($self, $tag);
+}
+
+sub cmd_login ($$$$) {
+ my ($self, $tag) = @_; # ignore ($user, $password) = ($_[2], $_[3])
+ login_success($self, $tag);
+}
+
+sub cmd_logout ($$) {
+ my ($self, $tag) = @_;
+ delete $self->{logged_in};
+ $self->write(\"* BYE logging out\r\n$tag OK logout completed\r\n");
+ $self->shutdn; # PublicInbox::DS::shutdn
+ undef;
+}
+
+sub cmd_authenticate ($$$) {
+ my ($self, $tag) = @_; # $method = $_[2], should be "ANONYMOUS"
+ $self->{-login_tag} = $tag;
+ "+\r\n"; # challenge
+}
+
+sub cmd_capability ($$) {
+ my ($self, $tag) = @_;
+ '* '.capa($self)."\r\n$tag OK\r\n";
+}
+
+sub cmd_noop ($$) { "$_[1] OK NOOP completed\r\n" }
+
+sub cmd_examine ($$$) {
+ my ($self, $tag, $mailbox) = @_;
+ my $ibx = $self->{imapd}->{groups}->{$mailbox} or
+ return "$tag NO Mailbox doesn't exist: $mailbox\r\n";
+ my $mm = $ibx->mm;
+ my $max = $mm->num_highwater // 0;
+ # RFC 3501 2.3.1.1 - "A good UIDVALIDITY value to use in
+ # this case is a 32-bit representation of the creation
+ # date/time of the mailbox"
+ my $uidvalidity = $mm->created_at or return "$tag BAD UIDVALIDITY\r\n";
+ my $uidnext = $max + 1;
+
+ # XXX: do we need this? RFC 5162/7162
+ my $ret = $self->{ibx} ? "* OK [CLOSED] previous closed\r\n" : '';
+ $self->{ibx} = $ibx;
+ $ret .= <<EOF;
+* $max EXISTS\r
+* $max RECENT\r
+* FLAGS (\\Seen)\r
+* OK [PERMANENTFLAGS ()] Read-only mailbox\r
+EOF
+ $ret .= "* OK [UNSEEN $max]\r\n" if $max;
+ $ret .= "* OK [UIDNEXT $uidnext]\r\n" if defined $uidnext;
+ $ret .= "* OK [UIDVALIDITY $uidvalidity]\r\n" if defined $uidvalidity;
+ $ret .= "$tag OK [READ-ONLY] EXAMINE/SELECT complete\r\n";
+}
+
+sub _esc ($) {
+ my ($v) = @_;
+ if (!defined($v)) {
+ 'NIL';
+ } elsif ($v =~ /[{"\r\n%*\\\[]/) { # literal string
+ '{' . length($v) . "}\r\n" . $v;
+ } else { # quoted string
+ qq{"$v"}
+ }
+}
+
+sub addr_envelope ($$;$) {
+ my ($eml, $x, $y) = @_;
+ my $v = $eml->header_raw($x) //
+ ($y ? $eml->header_raw($y) : undef) // return 'NIL';
+
+ my @x = $Address->parse($v) or return 'NIL';
+ '(' . join('',
+ map { '(' . join(' ',
+ _esc($_->name), 'NIL',
+ _esc($_->user), _esc($_->host)
+ ) . ')'
+ } @x) .
+ ')';
+}
+
+sub eml_envelope ($) {
+ my ($eml) = @_;
+ '(' . join(' ',
+ _esc($eml->header_raw('Date')),
+ _esc($eml->header_raw('Subject')),
+ addr_envelope($eml, 'From'),
+ addr_envelope($eml, 'Sender', 'From'),
+ addr_envelope($eml, 'Reply-To', 'From'),
+ addr_envelope($eml, 'To'),
+ addr_envelope($eml, 'Cc'),
+ addr_envelope($eml, 'Bcc'),
+ _esc($eml->header_raw('In-Reply-To')),
+ _esc($eml->header_raw('Message-ID')),
+ ) . ')';
+}
+
+sub uid_fetch_cb { # called by git->cat_async
+ my ($bref, $oid, $type, $size, $fetch_m_arg) = @_;
+ my ($self, undef, $ibx, undef, undef, $msgs, $want) = @$fetch_m_arg;
+ my $smsg = shift @$msgs or die 'BUG: no smsg';
+ $smsg->{blob} eq $oid or die "BUG: $smsg->{blob} != $oid";
+ $$bref =~ s/(?<!\r)\n/\r\n/sg; # make strict clients happy
+
+ # fixup old bug from import (pre-a0c07cba0e5d8b6a)
+ $$bref =~ s/\A[\r\n]*From [^\r\n]*\r\n//s;
+
+ $self->msg_more("* $smsg->{num} FETCH (UID $smsg->{num}");
+
+ $want->{'RFC822.SIZE'} and
+ $self->msg_more(' RFC822.SIZE '.length($$bref));
+ $want->{INTERNALDATE} and
+ $self->msg_more(' INTERNALDATE "'.$smsg->internaldate.'"');
+ $want->{FLAGS} and $self->msg_more(' FLAGS ()');
+ for ('RFC822', 'BODY[]', 'BODY.PEEK[]') {
+ next unless $want->{$_};
+ $self->msg_more(" $_ {".length($$bref)."}\r\n");
+ $self->msg_more($$bref);
+ }
+
+ my $eml = PublicInbox::Eml->new($bref);
+
+ $want->{ENVELOPE} and
+ $self->msg_more(' ENVELOPE '.eml_envelope($eml));
+
+ for my $f ('RFC822.HEADER', 'BODY[HEADER]', 'BODY.PEEK[HEADER]') {
+ next unless $want->{$f};
+ $self->msg_more(" $f {".length(${$eml->{hdr}})."}\r\n");
+ $self->msg_more(${$eml->{hdr}});
+ }
+ for my $f ('RFC822.TEXT', 'BODY[TEXT]') {
+ next unless $want->{$f};
+ $self->msg_more(" $f {".length($$bref)."}\r\n");
+ $self->msg_more($$bref);
+ }
+ # TODO BODY/BODYSTRUCTURE, specific headers
+ $self->msg_more(")\r\n");
+}
+
+sub uid_fetch_m { # long_response
+ my ($self, $tag, $ibx, $beg, $end, $msgs, $want) = @_;
+ if (!@$msgs) { # refill
+ @$msgs = @{$ibx->over->query_xover($$beg, $end)};
+ if (!@$msgs) {
+ $self->write(\"$tag OK Fetch done\r\n");
+ return;
+ }
+ $$beg = $msgs->[-1]->{num} + 1;
+ }
+ my $git = $ibx->git;
+ $git->cat_async_begin; # TODO: actually make async
+ $git->cat_async($msgs->[0]->{blob}, \&uid_fetch_cb, \@_);
+ $git->cat_async_wait;
+ 1;
+}
+
+sub cmd_uid_fetch ($$$;@) {
+ my ($self, $tag, $range, @want) = @_;
+ my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
+ if ($want[0] =~ s/\A\(//s) {
+ $want[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
+ }
+ my %want = map {;
+ my $x = $FETCH_ATT{uc($_)} or return "$tag BAD param: $_\r\n";
+ %$x;
+ } @want;
+ my ($beg, $end);
+ my $msgs = [];
+ if ($range =~ /\A([0-9]+):([0-9]+)\z/s) {
+ ($beg, $end) = ($1, $2);
+ } elsif ($range =~ /\A([0-9]+):\*\z/s) {
+ ($beg, $end) = ($1, $ibx->mm->num_highwater // 0);
+ } elsif ($range =~ /\A[0-9]+\z/) {
+ my $smsg = $ibx->over->get_art($range) or return "$tag OK\r\n";
+ push @$msgs, $smsg;
+ ($beg, $end) = ($range, 0);
+ } else {
+ return "$tag BAD\r\n";
+ }
+ long_response($self, \&uid_fetch_m, $tag, $ibx,
+ \$beg, $end, $msgs, \%want);
+}
+
+sub uid_search_all { # long_response
+ my ($self, $tag, $ibx, $num) = @_;
+ my $uids = $ibx->mm->ids_after($num);
+ if (scalar(@$uids)) {
+ $self->msg_more(join(' ', '', @$uids));
+ } else {
+ $self->write(\"\r\n$tag OK\r\n");
+ undef;
+ }
+}
+
+sub uid_search_uid_range { # long_response
+ my ($self, $tag, $ibx, $beg, $end) = @_;
+ my $uids = $ibx->mm->msg_range($beg, $end, 'num');
+ if (@$uids) {
+ $self->msg_more(join('', map { " $_->[0]" } @$uids));
+ } else {
+ $self->write(\"\r\n$tag OK\r\n");
+ undef;
+ }
+}
+
+sub cmd_uid_search ($$$;) {
+ my ($self, $tag, $arg, @rest) = @_;
+ my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
+ $arg = uc($arg);
+ if ($arg eq 'ALL' && !@rest) {
+ $self->msg_more('* SEARCH');
+ my $num = 0;
+ long_response($self, \&uid_search_all, $tag, $ibx, \$num);
+ } elsif ($arg eq 'UID' && scalar(@rest) == 1) {
+ if ($rest[0] =~ /\A([0-9]+):([0-9]+|\*)\z/s) {
+ my ($beg, $end) = ($1, $2);
+ $end = ($ibx->mm->minmax)[1] if $end eq '*';
+ $self->msg_more('* SEARCH');
+ long_response($self, \&uid_search_uid_range,
+ $tag, $ibx, \$beg, $end);
+ } elsif ($rest[0] =~ /\A[0-9]+\z/s) {
+ my $uid = $rest[0];
+ $uid = $ibx->over->get_art($uid) ? " $uid" : '';
+ "* SEARCH$uid\r\n$tag OK\r\n";
+ } else {
+ "$tag BAD\r\n";
+ }
+ } else {
+ "$tag BAD\r\n";
+ }
+}
+
+sub args_ok ($$) { # duplicated from PublicInbox::NNTP
+ my ($cb, $argc) = @_;
+ my $tot = prototype $cb;
+ my ($nreq, undef) = split(';', $tot);
+ $nreq = ($nreq =~ tr/$//) - 1;
+ $tot = ($tot =~ tr/$//) - 1;
+ ($argc <= $tot && $argc >= $nreq);
+}
+
+# returns 1 if we can continue, 0 if not due to buffered writes or disconnect
+sub process_line ($$) {
+ my ($self, $l) = @_;
+ my ($tag, $req, @args) = split(/[ \t]+/, $l);
+ if (@args && uc($req) eq 'UID') {
+ $req .= "_".(shift @args);
+ }
+ my $res = eval {
+ if (my $cmd = $self->can('cmd_'.lc($req // ''))) {
+ $cmd->($self, $tag, @args);
+ } else { # this is weird
+ auth_challenge_ok($self) //
+ "$tag BAD Error in IMAP command $req: ".
+ "Unknown command\r\n";
+ }
+ };
+ my $err = $@;
+ if ($err && $self->{sock}) {
+ $l =~ s/\r?\n//s;
+ err($self, 'error from: %s (%s)', $l, $err);
+ $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}:
+ $self->update_idle_time;
+
+ # 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;
+ } 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;
+}
+
+sub out ($$;@) {
+ my ($self, $fmt, @args) = @_;
+ 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) = @_;
+
+ return unless $self->flush_write && $self->{sock};
+
+ $self->update_idle_time;
+ # only read more requests if we've drained the write buffer,
+ # otherwise we can be buffering infinitely w/o backpressure
+
+ my $rbuf = $self->{rbuf} // (\(my $x = ''));
+ my $r = 1;
+
+ if (index($$rbuf, "\n") < 0) {
+ my $off = length($$rbuf);
+ $r = $self->do_read($rbuf, LINE_MAX, $off) or return;
+ }
+ while ($r > 0 && $$rbuf =~ s/\A[ \t]*([^\n]*?)\r?\n//) {
+ my $line = $1;
+ return $self->close if $line =~ /[[:cntrl:]]/s;
+ my $t0 = now();
+ my $fd = fileno($self->{sock});
+ $r = eval { process_line($self, $line) };
+ my $pending = $self->{wbuf} ? ' pending' : '';
+ out($self, "[$fd] %s - %0.6f$pending", $line, now() - $t0);
+ }
+
+ return $self->close if $r < 0;
+ my $len = length($$rbuf);
+ return $self->close if ($len >= LINE_MAX);
+ $self->rbuf_idle($rbuf);
+ $self->update_idle_time;
+
+ # maybe there's more pipelined data, or we'll have
+ # to register it for socket-readiness notifications
+ $self->requeue unless $self->{wbuf};
+}
+
+sub compressed { undef }
+
+sub zflush {} # overridden by IMAPdeflate
+
+# RFC 4978
+sub cmd_compress ($$$) {
+ my ($self, $tag, $alg) = @_;
+ return "$tag BAD DEFLATE only\r\n" if uc($alg) ne "DEFLATE";
+ return "$tag BAD COMPRESS active\r\n" if $self->compressed;
+
+ # CRIME made TLS compression obsolete
+ # return "$tag NO [COMPRESSIONACTIVE]\r\n" if $self->tls_compressed;
+
+ PublicInbox::IMAPdeflate->enable($self, $tag);
+ $self->requeue;
+ undef
+}
+
+sub cmd_starttls ($$) {
+ my ($self, $tag) = @_;
+ my $sock = $self->{sock} or return;
+ if ($sock->can('stop_SSL') || $self->compressed) {
+ return "$tag BAD TLS or compression already enabled\r\n";
+ }
+ my $opt = $self->{imapd}->{accept_tls} 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);
+ $self->requeue if PublicInbox::DS::accept_tls_step($self);
+ undef;
+}
+
+# for graceful shutdown in PublicInbox::Daemon:
+sub busy {
+ my ($self, $now) = @_;
+ ($self->{rbuf} || $self->{wbuf} || $self->not_idle_long($now));
+}
+
+# we're read-only, so SELECT and EXAMINE do the same thing
+no warnings 'once';
+*cmd_select = \&cmd_examine;
+
+1;
--- /dev/null
+# Copyright (C) 2020 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+
+# represents an IMAPD (currently a singleton),
+# see script/public-inbox-imapd for how it is used
+package PublicInbox::IMAPD;
+use strict;
+use parent qw(PublicInbox::NNTPD);
+
+sub new {
+ my ($class) = @_;
+ $class->SUPER::new; # PublicInbox::NNTPD->new
+}
+
+1;
--- /dev/null
+# Copyright (C) 2020 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+# TODO: reduce duplication from PublicInbox::NNTPdeflate
+
+# RFC 4978
+package PublicInbox::IMAPdeflate;
+use strict;
+use warnings;
+use 5.010_001;
+use base qw(PublicInbox::IMAP);
+use Compress::Raw::Zlib;
+use Hash::Util qw(unlock_hash); # dependency of fields for perl 5.10+, anyways
+
+my %IN_OPT = (
+ -Bufsize => 1024,
+ -WindowBits => -15, # RFC 1951
+ -AppendOutput => 1,
+);
+
+# global deflate context and buffer
+my $zbuf = \(my $buf = '');
+my $zout;
+{
+ my $err;
+ ($zout, $err) = Compress::Raw::Zlib::Deflate->new(
+ # nnrpd (INN) and Compress::Raw::Zlib favor MemLevel=9,
+ # the zlib C library and git use MemLevel=8 as the default
+ # -MemLevel => 9,
+ -Bufsize => 65536, # same as nnrpd
+ -WindowBits => -15, # RFC 1951
+ -AppendOutput => 1,
+ );
+ $err == Z_OK or die "Failed to initialize zlib deflate stream: $err";
+}
+
+sub enable {
+ my ($class, $self, $tag) = @_;
+ my ($in, $err) = Compress::Raw::Zlib::Inflate->new(%IN_OPT);
+ if ($err != Z_OK) {
+ $self->err("Inflate->new failed: $err");
+ $self->write(\"$tag BAD failed to activate compression\r\n");
+ return;
+ }
+ unlock_hash(%$self);
+ $self->write(\"$tag OK DEFLATE active\r\n");
+ bless $self, $class;
+ $self->{zin} = $in;
+}
+
+# overrides PublicInbox::NNTP::compressed
+sub compressed { 1 }
+
+# $_[1] may be a reference or not
+sub do_read ($$$$) {
+ my ($self, $rbuf, $len, $off) = @_;
+
+ my $zin = $self->{zin} or return; # closed
+ my $doff;
+ my $dbuf = delete($self->{dbuf}) // '';
+ $doff = length($dbuf);
+ my $r = PublicInbox::DS::do_read($self, \$dbuf, $len, $doff) or return;
+
+ # assert(length($$rbuf) == $off) as far as NNTP.pm is concerned
+ # -ConsumeInput is true, so $dbuf is automatically emptied
+ my $err = $zin->inflate($dbuf, $rbuf);
+ if ($err == Z_OK) {
+ $self->{dbuf} = $dbuf if $dbuf ne '';
+ $r = length($$rbuf) and return $r;
+ # nothing ready, yet, get more, later
+ $self->requeue;
+ } else {
+ delete $self->{zin};
+ $self->close;
+ }
+ 0;
+}
+
+# override PublicInbox::DS::msg_more
+sub msg_more ($$) {
+ my $self = $_[0];
+
+ # $_[1] may be a reference or not for ->deflate
+ my $err = $zout->deflate($_[1], $zbuf);
+ $err == Z_OK or die "->deflate failed $err";
+ 1;
+}
+
+sub zflush ($) {
+ my ($self) = @_;
+
+ my $deflated = $zbuf;
+ $zbuf = \(my $next = '');
+
+ my $err = $zout->flush($deflated, Z_FULL_FLUSH);
+ $err == Z_OK or die "->flush failed $err";
+
+ # We can still let the lower socket layer do buffering:
+ PublicInbox::DS::msg_more($self, $$deflated);
+}
+
+# compatible with PublicInbox::DS::write, so $_[1] may be a reference or not
+sub write ($$) {
+ my $self = $_[0];
+ return PublicInbox::DS::write($self, $_[1]) if ref($_[1]) eq 'CODE';
+
+ my $deflated = $zbuf;
+ $zbuf = \(my $next = '');
+
+ # $_[1] may be a reference or not for ->deflate
+ my $err = $zout->deflate($_[1], $deflated);
+ $err == Z_OK or die "->deflate failed $err";
+ $err = $zout->flush($deflated, Z_FULL_FLUSH);
+ $err == Z_OK or die "->flush failed $err";
+
+ # We can still let the socket layer do buffering:
+ PublicInbox::DS::write($self, $deflated);
+}
+
+1;
my @DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
my @MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
-sub date ($) {
+sub date ($) { # for NNTP
my ($self) = @_;
my $ds = $self->{ds};
return unless defined $ds;
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($ds);
"$DoW[$wday], " . sprintf("%02d $MoY[$mon] %04d %02d:%02d:%02d +0000",
$mday, $year+1900, $hour, $min, $sec);
+}
+sub internaldate { # for IMAP
+ my ($self) = @_;
+ my ($sec, $min, $hour, $mday, $mon, $year) = gmtime($self->{ts} // 0);
+ sprintf("%02d-$MoY[$mon]-%04d %02d:%02d:%02d +0000",
+ $mday, $year+1900, $hour, $min, $sec);
}
our $REPLY_RE = qr/^re:\s+/i;
--- /dev/null
+#!perl -w
+# Copyright (C) 2020 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+#
+# Standalone read-only IMAP server for public-inbox.
+use strict;
+use PublicInbox::Daemon;
+use PublicInbox::IMAPdeflate; # loads PublicInbox::IMAP
+use PublicInbox::IMAPD;
+my $imapd = PublicInbox::IMAPD->new;
+PublicInbox::Daemon::run('0.0.0.0:143',
+ sub { $imapd->refresh_groups }, # refresh
+ sub ($$$) { PublicInbox::IMAP->new($_[0], $imapd) }, # post_accept
+ $imapd);
--- /dev/null
+# Copyright (C) 2020 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+use strict;
+use warnings;
+use Test::More;
+use Socket qw(IPPROTO_TCP SOL_SOCKET);
+use PublicInbox::TestCommon;
+# IO::Poll is part of the standard library, but distros may split it off...
+require_mods(qw(DBD::SQLite IO::Socket::SSL Mail::IMAPClient IO::Poll));
+Mail::IMAPClient->can('starttls') or
+ plan skip_all => 'Mail::IMAPClient does not support TLS';
+my $cert = 'certs/server-cert.pem';
+my $key = 'certs/server-key.pem';
+unless (-r $key && -r $cert) {
+ plan skip_all =>
+ "certs/ missing for $0, run $^X ./create-certs.perl in certs/";
+}
+use_ok 'PublicInbox::TLS';
+use_ok 'IO::Socket::SSL';
+use PublicInbox::InboxWritable;
+require PublicInbox::SearchIdx;
+my $version = 1; # v2 needs newer git
+require_git('2.6') if $version >= 2;
+my ($tmpdir, $for_destroy) = tmpdir();
+my $err = "$tmpdir/stderr.log";
+my $out = "$tmpdir/stdout.log";
+my $inboxdir = "$tmpdir";
+my $pi_config = "$tmpdir/pi_config";
+my $group = 'test-imapd-tls';
+my $addr = $group . '@example.com';
+my $starttls = tcp_server();
+my $imaps = tcp_server();
+my $ibx = PublicInbox::Inbox->new({
+ inboxdir => $inboxdir,
+ name => 'imapd-tls',
+ version => $version,
+ -primary_address => $addr,
+ indexlevel => 'basic',
+});
+$ibx = PublicInbox::InboxWritable->new($ibx, {nproc=>1});
+$ibx->init_inbox(0);
+{
+ open my $fh, '>', $pi_config or BAIL_OUT "open: $!";
+ print $fh <<EOF
+[publicinbox "imapd-tls"]
+ inboxdir = $inboxdir
+ address = $addr
+ indexlevel = basic
+ newsgroup = $group
+EOF
+ ;
+ close $fh or BAIL_OUT "close: $!\n";
+}
+
+{
+ my $im = $ibx->importer(0);
+ ok($im->add(eml_load('t/data/0001.patch')), 'message added');
+ $im->done;
+ if ($version == 1) {
+ my $s = PublicInbox::SearchIdx->new($ibx, 1);
+ $s->index_sync;
+ }
+}
+
+my $imaps_addr = $imaps->sockhost . ':' . $imaps->sockport;
+my $starttls_addr = $starttls->sockhost . ':' . $starttls->sockport;
+my $env = { PI_CONFIG => $pi_config };
+my $td;
+
+# Mail::IMAPClient ->compress creates cyclic reference:
+# https://rt.cpan.org/Ticket/Display.html?id=132654
+my $compress_logout = sub {
+ my ($c) = @_;
+ ok($c->logout, 'logout ok after ->compress');
+ # all documented in Mail::IMAPClient manpage:
+ for (qw(Readmoremethod Readmethod Prewritemethod)) {
+ $c->$_(undef);
+ }
+};
+
+
+for my $args (
+ [ "--cert=$cert", "--key=$key",
+ "-limaps://$imaps_addr",
+ "-limap://$starttls_addr" ],
+) {
+ for ($out, $err) {
+ open my $fh, '>', $_ or BAIL_OUT "truncate: $!";
+ }
+ my $cmd = [ '-imapd', '-W0', @$args, "--stdout=$out", "--stderr=$err" ];
+ $td = start_script($cmd, $env, { 3 => $starttls, 4 => $imaps });
+ my %o = (
+ SSL_hostname => 'server.local',
+ SSL_verifycn_name => 'server.local',
+ SSL_verify_mode => SSL_VERIFY_PEER(),
+ SSL_ca_file => 'certs/test-ca.pem',
+ );
+ # start negotiating a slow TLS connection
+ my $slow = tcp_connect($imaps, Blocking => 0);
+ $slow = IO::Socket::SSL->start_SSL($slow, SSL_startHandshake => 0, %o);
+ my $slow_done = $slow->connect_SSL;
+ my @poll;
+ if ($slow_done) {
+ diag('W: connect_SSL early OK, slow client test invalid');
+ use PublicInbox::Syscall qw(EPOLLIN EPOLLOUT);
+ @poll = (fileno($slow), EPOLLIN | EPOLLOUT);
+ } else {
+ @poll = (fileno($slow), PublicInbox::TLS::epollbit());
+ }
+ # we should call connect_SSL much later...
+ my %imaps_opt = (User => 'a', Password => 'b',
+ Server => $imaps->sockhost,
+ Port => $imaps->sockport);
+ # IMAPS
+ my $c = Mail::IMAPClient->new(%imaps_opt, Ssl => [ %o ]);
+ ok($c && $c->IsAuthenticated, 'authenticated');
+ ok($c->select($group), 'SELECT works');
+ ok(!(scalar $c->has_capability('STARTTLS')),
+ 'starttls not advertised with IMAPS');
+ ok(!$c->starttls, "starttls fails");
+ ok($c->has_capability('COMPRESS'), 'compress advertised');
+ ok($c->compress, 'compression enabled with IMAPS');
+ ok(!$c->starttls, 'starttls still fails');
+ ok($c->noop, 'noop succeeds');
+ $compress_logout->($c);
+
+ # STARTTLS
+ my %imap_opt = (Server => $starttls->sockhost,
+ Port => $starttls->sockport);
+ $c = Mail::IMAPClient->new(%imap_opt);
+ ok(scalar $c->has_capability('STARTTLS'),
+ 'starttls advertised');
+ ok($c->Starttls([ %o ]), 'set starttls options');
+ ok($c->starttls, '->starttls works');
+ ok(!(scalar($c->has_capability('STARTTLS'))),
+ 'starttls not advertised');
+ ok(!$c->starttls, '->starttls again fails');
+ ok(!(scalar($c->has_capability('STARTTLS'))),
+ 'starttls still not advertised');
+ ok($c->examine($group), 'EXAMINE works');
+ ok($c->noop, 'NOOP works');
+ ok($c->compress, 'compression enabled with IMAPS');
+ ok($c->noop, 'NOOP works after compress');
+ $compress_logout->($c);
+
+ # STARTTLS with bad hostname
+ $o{SSL_hostname} = $o{SSL_verifycn_name} = 'server.invalid';
+ $c = Mail::IMAPClient->new(%imap_opt);
+ ok(scalar $c->has_capability('STARTTLS'), 'starttls advertised');
+ ok($c->Starttls([ %o ]), 'set starttls options');
+ ok(!$c->starttls, '->starttls fails with bad hostname');
+
+ $c = Mail::IMAPClient->new(%imap_opt);
+ ok($c->noop, 'NOOP still works from plain IMAP');
+
+ # IMAPS with bad hostname
+ $c = Mail::IMAPClient->new(%imaps_opt, Ssl => [ %o ]);
+ is($c, undef, 'IMAPS fails with bad hostname');
+
+ # make hostname valid
+ $o{SSL_hostname} = $o{SSL_verifycn_name} = 'server.local';
+ $c = Mail::IMAPClient->new(%imaps_opt, Ssl => [ %o ]);
+ ok($c, 'IMAPS succeeds again with valid hostname');
+
+ # slow TLS connection did not block the other fast clients while
+ # connecting, finish it off:
+ until ($slow_done) {
+ IO::Poll::_poll(-1, @poll);
+ $slow_done = $slow->connect_SSL and last;
+ @poll = (fileno($slow), PublicInbox::TLS::epollbit());
+ }
+ $slow->blocking(1);
+ ok(sysread($slow, my $greet, 4096) > 0, 'slow got a greeting');
+ like($greet, qr/\A\* OK \[CAPABILITY IMAP4rev1 /, 'got greeting');
+ is(syswrite($slow, "1 LOGOUT\r\n"), 10, 'slow wrote LOGOUT');
+ ok(sysread($slow, my $end, 4096) > 0, 'got end');
+ is(sysread($slow, my $eof, 4096), 0, 'got EOF');
+
+ SKIP: {
+ skip 'TCP_DEFER_ACCEPT is Linux-only', 2 if $^O ne 'linux';
+ my $var = eval { Socket::TCP_DEFER_ACCEPT() } // 9;
+ defined(my $x = getsockopt($imaps, IPPROTO_TCP, $var)) or die;
+ ok(unpack('i', $x) > 0, 'TCP_DEFER_ACCEPT set on IMAPS');
+ defined($x = getsockopt($starttls, IPPROTO_TCP, $var)) or die;
+ is(unpack('i', $x), 0, 'TCP_DEFER_ACCEPT is 0 on plain IMAP');
+ };
+ SKIP: {
+ skip 'SO_ACCEPTFILTER is FreeBSD-only', 2 if $^O ne 'freebsd';
+ if (system('kldstat -m accf_data >/dev/null')) {
+ skip 'accf_data not loaded? kldload accf_data', 2;
+ }
+ require PublicInbox::Daemon;
+ my $var = PublicInbox::Daemon::SO_ACCEPTFILTER();
+ my $x = getsockopt($imaps, SOL_SOCKET, $var);
+ like($x, qr/\Adataready\0+\z/, 'got dataready accf for IMAPS');
+ $x = getsockopt($starttls, IPPROTO_TCP, $var);
+ is($x, undef, 'no BSD accept filter for plain IMAP');
+ };
+
+ $c = undef;
+ $td->kill;
+ $td->join;
+ is($?, 0, 'no error in exited process');
+ open my $fh, '<', $err or BAIL_OUT "open $err failed: $!";
+ my $eout = do { local $/; <$fh> };
+ unlike($eout, qr/wide/i, 'no Wide character warnings');
+}
+
+done_testing;
--- /dev/null
+#!perl -w
+# Copyright (C) 2020 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+use strict;
+use Test::More;
+use PublicInbox::TestCommon;
+require_mods(qw(DBD::SQLite Mail::IMAPClient));
+my $level = '-Lbasic';
+SKIP: {
+ require_mods('Search::Xapian', 1);
+ $level = '-Lmedium';
+};
+
+my @V = (1);
+#push(@V, 2) if require_git('2.6', 1);
+
+my ($tmpdir, $for_destroy) = tmpdir();
+my $home = "$tmpdir/home";
+local $ENV{HOME} = $home;
+
+for my $V (@V) {
+ my $addr = "i$V\@example.com";
+ my $name = "i$V";
+ my $url = "http://example.com/i$V";
+ my $inboxdir = "$tmpdir/$name";
+ my $folder = "inbox.i$V";
+ my $cmd = ['-init', "-V$V", $level, $name, $inboxdir, $url, $addr];
+ run_script($cmd) or BAIL_OUT("init $name");
+ xsys(qw(git config), "--file=$ENV{HOME}/.public-inbox/config",
+ "publicinbox.$name.newsgroup", $folder) == 0 or
+ BAIL_OUT("setting newsgroup $V");
+ if ($V == 1) {
+ xsys(qw(git config), "--file=$ENV{HOME}/.public-inbox/config",
+ 'publicinboxmda.spamcheck', 'none') == 0 or
+ BAIL_OUT("config: $?");
+ }
+ open(my $fh, '<', 't/utf8.eml') or BAIL_OUT("open t/utf8.eml: $!");
+ my $env = { ORIGINAL_RECIPIENT => $addr };
+ run_script(['-mda', '--no-precheck'], $env, { 0 => $fh }) or
+ BAIL_OUT('-mda delivery');
+ if ($V == 1) {
+ run_script(['-index', $inboxdir]) or BAIL_OUT("index $?");
+ }
+}
+my $sock = tcp_server();
+my $err = "$tmpdir/stderr.log";
+my $out = "$tmpdir/stdout.log";
+my $cmd = [ '-imapd', '-W0', "--stdout=$out", "--stderr=$err" ];
+my $td = start_script($cmd, undef, { 3 => $sock }) or BAIL_OUT("-imapd: $?");
+my %mic_opt = (
+ Server => $sock->sockhost,
+ Port => $sock->sockport,
+ Uid => 1,
+);
+my $mic = Mail::IMAPClient->new(%mic_opt);
+my $pre_login_capa = $mic->capability;
+is(grep(/\AAUTH=ANONYMOUS\z/, @$pre_login_capa), 1,
+ 'AUTH=ANONYMOUS advertised pre-login');
+
+$mic->User('lorelei');
+$mic->Password('Hunter2');
+ok($mic->login && $mic->IsAuthenticated, 'LOGIN works');
+my $post_login_capa = $mic->capability;
+ok(join("\n", @$pre_login_capa) ne join("\n", @$post_login_capa),
+ 'got different capabilities post-login');
+
+$mic_opt{Authmechanism} = 'ANONYMOUS';
+$mic_opt{Authcallback} = sub { '' };
+$mic = Mail::IMAPClient->new(%mic_opt);
+ok($mic && $mic->login && $mic->IsAuthenticated, 'AUTHENTICATE ANONYMOUS');
+my $post_auth_anon_capa = $mic->capability;
+is_deeply($post_auth_anon_capa, $post_login_capa,
+ 'auth anon has same capabilities');
+my $e;
+ok(!$mic->examine('foo') && ($e = $@), 'EXAMINE non-existent');
+like($e, qr/\bNO\b/, 'got a NO on EXAMINE for non-existent');
+ok(!$mic->select('foo') && ($e = $@), 'EXAMINE non-existent');
+like($e, qr/\bNO\b/, 'got a NO on EXAMINE for non-existent');
+ok($mic->select('inbox.i1'), 'SELECT succeeds');
+ok($mic->examine('inbox.i1'), 'EXAMINE succeeds');
+
+my $ret = $mic->search('all') or BAIL_OUT "SEARCH FAIL $@";
+is_deeply($ret, [ 1 ], 'search all works');
+$ret = $mic->search('uid 1') or BAIL_OUT "SEARCH FAIL $@";
+is_deeply($ret, [ 1 ], 'search UID 1 works');
+$ret = $mic->search('uid 1:1') or BAIL_OUT "SEARCH FAIL $@";
+is_deeply($ret, [ 1 ], 'search UID 1:1 works');
+$ret = $mic->search('uid 1:*') or BAIL_OUT "SEARCH FAIL $@";
+is_deeply($ret, [ 1 ], 'search UID 1:* works');
+
+is_deeply(scalar $mic->flags('1'), [], '->flags works');
+
+for my $r ('1:*', '1') {
+ $ret = $mic->fetch_hash($r, 'RFC822') or BAIL_OUT "FETCH $@";
+ is_deeply([keys %$ret], [1]);
+ like($ret->{1}->{RFC822}, qr/\r\n\r\nThis is a test/, 'read full');
+
+ # ensure Mail::IMAPClient behaves
+ my $str = $mic->message_string($r) or BAIL_OUT "->message_string: $@";
+ is($str, $ret->{1}->{RFC822}, '->message_string works as expected');
+
+ my $sz = $mic->fetch_hash($r, 'RFC822.size') or BAIL_OUT "FETCH $@";
+ is($sz->{1}->{'RFC822.SIZE'}, length($ret->{1}->{RFC822}),
+ 'RFC822.SIZE');
+
+ $ret = $mic->fetch_hash($r, 'RFC822.HEADER') or BAIL_OUT "FETCH $@";
+ is_deeply([keys %$ret], [1]);
+ like($ret->{1}->{'RFC822.HEADER'},
+ qr/^Message-ID: <testmessage\@example\.com>/ms, 'read header');
+
+ $ret = $mic->fetch_hash($r, 'INTERNALDATE') or BAIL_OUT "FETCH $@";
+ is($ret->{1}->{'INTERNALDATE'}, '01-Jan-1970 00:00:00 +0000',
+ 'internaldate matches');
+ ok(!$mic->fetch_hash($r, 'INFERNALDATE'), 'bogus attribute fails');
+
+ my $envelope = $mic->get_envelope($r) or BAIL_OUT("get_envelope: $@");
+ is($envelope->{bcc}, 'NIL', 'empty bcc');
+ is($envelope->{messageid}, '<testmessage@example.com>', 'messageid');
+ is(scalar @{$envelope->{to}}, 1, 'one {to} header');
+ # *sigh* too much to verify...
+ #use Data::Dumper; diag Dumper($envelope);
+
+ $ret = $mic->fetch_hash($r, 'FLAGS') or BAIL_OUT "FETCH $@";
+ is_deeply($ret->{1}->{FLAGS}, '', 'no flags');
+}
+
+# Mail::IMAPClient ->compress creates cyclic reference:
+# https://rt.cpan.org/Ticket/Display.html?id=132654
+my $compress_logout = sub {
+ my ($c) = @_;
+ ok($c->logout, 'logout ok after ->compress');
+ # all documented in Mail::IMAPClient manpage:
+ for (qw(Readmoremethod Readmethod Prewritemethod)) {
+ $c->$_(undef);
+ }
+};
+
+is_deeply([$mic->has_capability('COMPRESS')], ['DEFLATE'], 'deflate cap');
+ok($mic->compress, 'compress enabled');
+$compress_logout->($mic);
+
+$td->kill;
+$td->join;
+is($?, 0, 'no error in exited process');
+open my $fh, '<', $err or BAIL_OUT("open $err failed: $!");
+my $eout = do { local $/; <$fh> };
+unlike($eout, qr/wide/i, 'no Wide character warnings');
+
+done_testing;