my $worker_processes = 1;
my @listeners;
my (%pids, %logs);
-my %tls_opt; # scheme://sockname => args for IO::Socket::SSL->start_SSL
+my %tls_opt; # scheme://sockname => args for IO::Socket::SSL::SSL_Context->new
my $reexec_pid;
my ($uid, $gid);
my ($default_cert, $default_key);
$o;
}
+sub check_absolute ($$) {
+ my ($var, $val) = @_;
+ die <<EOM if index($val // '/', '/') != 0;
+$var must be an absolute path when using --daemonize: $val
+EOM
+}
+
sub accept_tls_opt ($) {
my ($opt) = @_;
my $o = ref($opt) eq 'HASH' ? $opt : listener_opt($opt);
return if !defined($o->{cert});
require PublicInbox::TLS;
- my %ctx_opt = (SSL_server => 1);
+ my @ctx_opt;
# parse out hostname:/path/to/ mappings:
for my $k (qw(cert key)) {
$o->{$k} // next;
- my $x = $ctx_opt{'SSL_'.$k.'_file'} = {};
+ push(@ctx_opt, "SSL_${k}_file", {});
foreach my $path (@{$o->{$k}}) {
my $host = '';
$path =~ s/\A([^:]+):// and $host = $1;
- $x->{$host} = $path;
+ $ctx_opt[-1]->{$host} = $path;
check_absolute($k, $path) if $daemonize;
}
}
- my $ctx = IO::Socket::SSL::SSL_Context->new(%ctx_opt) or
- die 'SSL_Context->new: '.PublicInbox::TLS::err();
-
- # save ~34K per idle connection (cf. SSL_CTX_set_mode(3ssl))
- # RSS goes from 346MB to 171MB with 10K idle NNTPS clients on amd64
- # cf. https://rt.cpan.org/Ticket/Display.html?id=129463
- my $mode = eval { Net::SSLeay::MODE_RELEASE_BUFFERS() };
- if ($mode && $ctx->{context}) {
- eval { Net::SSLeay::CTX_set_mode($ctx->{context}, $mode) };
- warn "W: $@ (setting SSL_MODE_RELEASE_BUFFERS)\n" if $@;
- }
-
- { SSL_server => 1, SSL_startHandshake => 0, SSL_reuse_ctx => $ctx };
-}
-
-sub check_absolute ($$) {
- my ($var, $val) = @_;
- die <<EOM if index($val // '/', '/') != 0;
-$var must be an absolute path when using --daemonize: $val
-EOM
+ \@ctx_opt;
}
sub do_chown ($) {
exit # never gets here, just for documentation
}
-sub tls_start_cb ($$) {
- my ($opt, $orig_post_accept) = @_;
+sub tls_cb {
+ my ($post_accept, $tlsd) = @_;
sub {
my ($io, $addr, $srv) = @_;
- my $ssl = IO::Socket::SSL->start_SSL($io, %$opt);
- $orig_post_accept->($ssl, $addr, $srv);
+ $post_accept->(PublicInbox::TLS::start($io, $tlsd), $addr, $srv)
}
}
my $refresh = sub {
my ($sig) = @_;
for my $xn (values %$xnetd) {
+ delete $xn->{tlsd}->{ssl_ctx}; # PublicInbox::TLS::start
eval { $xn->{refresh}->($sig) };
warn "refresh $@\n" if $@;
}
};
my %post_accept;
- while (my ($k, $v) = each %tls_opt) {
+ while (my ($k, $ctx_opt) = each %tls_opt) {
my $l = $k;
$l =~ s!\A([^:]+)://!!;
my $scheme = $1 // '';
my $xn = $xnetd->{$l} // $xnetd->{''};
- if ($scheme =~ m!\A(?:https|imaps|nntps|pop3s)!) {
- $post_accept{$l} = tls_start_cb($v, $xn->{post_accept});
- } elsif ($xn->{tlsd}) { # STARTTLS, $k eq '' is OK
- $xn->{tlsd}->{accept_tls} = $v;
- }
+ $xn->{tlsd}->{ssl_ctx_opt} //= $ctx_opt;
+ $scheme =~ m!\A(?:https|imaps|nntps|pop3s)! and
+ $post_accept{$l} = tls_cb(@$xn{qw(post_accept tlsd)});
}
my $sig = {
HUP => $refresh,
$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';
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;
}
mailboxes => {},
err => \*STDERR,
out => \*STDOUT,
- # accept_tls => { SSL_server => 1, ..., SSL_reuse_ctx => ... }
+ # ssl_ctx_opt => { SSL_cert_file => ..., SSL_key_file => ... }
# pi_cfg => PublicInbox::Config
# idler => PublicInbox::InboxIdle
}, $class;
my ($self, undef) = @_;
my $res = $CAPABILITIES;
if (!$self->{sock}->can('accept_SSL') &&
- $self->{nntpd}->{accept_tls}) {
+ $self->{nntpd}->{ssl_ctx_opt}) {
$res .= "STARTTLS\r\n";
}
$res .= ".\r\n";
sub cmd_starttls ($) {
my ($self) = @_;
- my $sock = $self->{sock} or return;
# RFC 4642 2.2.1
- return r502 if ($sock->can('accept_SSL') || $self->compressed);
- my $opt = $self->{nntpd}->{accept_tls} or
+ (($self->{sock} // return)->can('stop_SSL') || $self->compressed) and
+ return r502;
+ $self->{nntpd}->{ssl_ctx_opt} or
return \"580 can not initiate TLS negotiation\r\n";
$self->write(\"382 Continue with TLS negotiation\r\n");
- $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
+ PublicInbox::TLS::start($self->{sock}, $self->{nntpd});
$self->requeue if PublicInbox::DS::accept_tls_step($self);
undef;
}
err => \*STDERR,
out => \*STDOUT,
# pi_cfg => $pi_cfg,
- # accept_tls => { SSL_server => 1, ..., SSL_reuse_ctx => ... }
+ # ssl_ctx_opt => { SSL_cert_file => ..., SSL_key_file => ... }
# idler => PublicInbox::InboxIdle
}, $class;
}
sub cmd_stls {
my ($self) = @_;
- my $sock = $self->{sock} or return;
- return \"-ERR TLS already enabled\r\n" if $sock->can('stop_SSL');
- my $opt = $self->{pop3d}->{accept_tls} or
+ ($self->{sock} // return)->can('stop_SSL') and
+ return \"-ERR TLS already enabled\r\n";
+ $self->{pop3d}->{ssl_ctx_opt} or
return \"-ERR can't start TLS negotiation\r\n";
$self->write(\"+OK begin TLS negotiation now\r\n");
- $self->{sock} = IO::Socket::SSL->start_SSL($sock, %$opt);
+ PublicInbox::TLS::start($self->{sock}, $self->{pop3d});
$self->requeue if PublicInbox::DS::accept_tls_step($self);
undef;
}
sub cmd_capa {
my ($self) = @_;
my $STLS = !$self->{ibx} && !$self->{sock}->can('stop_SSL') &&
- $self->{pop3d}->{accept_tls} ? "\nSTLS\r" : '';
+ $self->{pop3d}->{ssl_ctx_opt} ? "\nSTLS\r" : '';
$self->{expire} = ''; # "EXPIRE 0" allows clients to avoid DELE commands
<<EOM;
+OK Capability list follows\r
# lock_path => ...
# interprocess lock is the $pop3state/txn.locks file
# txn_locks => {}, # intraworker locks
- # accept_tls => { SSL_server => 1, ..., SSL_reuse_ctx => ... }
+ # ssl_ctx_opt => { SSL_cert_file => ..., SSL_key_file => ... }
}, $cls;
}
-# Copyright (C) 2019-2021 all contributors <meta@public-inbox.org>
+# Copyright (C) all contributors <meta@public-inbox.org>
# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
# IO::Socket::SSL support code
use strict;
use IO::Socket::SSL;
use PublicInbox::Syscall qw(EPOLLIN EPOLLOUT);
-use Carp qw(carp);
+use Carp qw(carp croak);
sub err () { $SSL_ERROR }
undef;
}
+sub _ctx_new ($) {
+ my ($tlsd) = @_;
+ my $ctx = IO::Socket::SSL::SSL_Context->new(
+ @{$tlsd->{ssl_ctx_opt}}, SSL_server => 1) or
+ croak "SSL_Context->new: $SSL_ERROR";
+
+ # save ~34K per idle connection (cf. SSL_CTX_set_mode(3ssl))
+ # RSS goes from 346MB to 171MB with 10K idle NNTPS clients on amd64
+ # cf. https://rt.cpan.org/Ticket/Display.html?id=129463
+ my $mode = eval { Net::SSLeay::MODE_RELEASE_BUFFERS() };
+ if ($mode && $ctx->{context}) {
+ eval { Net::SSLeay::CTX_set_mode($ctx->{context}, $mode) };
+ warn "W: $@ (setting SSL_MODE_RELEASE_BUFFERS)\n" if $@;
+ }
+ $ctx;
+}
+
+sub start {
+ my ($io, $tlsd) = @_;
+ IO::Socket::SSL->start_SSL($io, SSL_server => 1,
+ SSL_reuse_ctx => ($tlsd->{ssl_ctx} //= _ctx_new($tlsd)),
+ SSL_startHandshake => 0);
+}
+
1;
-# Copyright (C) 2019-2021 all contributors <meta@public-inbox.org>
+#!perl -w
+# Copyright (C) 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 v5.12;
use Socket qw(SOCK_STREAM IPPROTO_TCP SOL_SOCKET);
use PublicInbox::TestCommon;
+use File::Copy qw(cp);
# IO::Poll is part of the standard library, but distros may split them off...
require_mods(qw(IO::Socket::SSL IO::Poll Plack::Util));
-my $cert = 'certs/server-cert.pem';
-my $key = 'certs/server-key.pem';
-unless (-r $key && -r $cert) {
+my @certs = qw(certs/server-cert.pem certs/server-key.pem
+ certs/server2-cert.pem certs/server2-key.pem);
+if (scalar(grep { -r $_ } @certs) != scalar(@certs)) {
plan skip_all =>
"certs/ missing for $0, run $^X ./create-certs.perl in certs/";
}
my $https = tcp_server();
my $td;
my $https_addr = tcp_host_port($https);
+my $cert = "$tmpdir/cert.pem";
+my $key = "$tmpdir/key.pem";
+cp('certs/server-cert.pem', $cert) or xbail $!;
+cp('certs/server-key.pem', $key) or xbail $!;
+
+my $check_url_scheme = sub {
+ my ($s, $line) = @_;
+ $s->print("GET /url_scheme HTTP/1.1\r\n\r\nHost: example.com\r\n\r\n")
+ or xbail "failed to write HTTP request: $! (line $line)";
+ my $buf = '';
+ sysread($s, $buf, 2007, length($buf)) until $buf =~ /\r\n\r\nhttps?/;
+ like($buf, qr!\AHTTP/1\.1 200!, "read HTTPS response (line $line)");
+ like($buf, qr!\r\nhttps\z!, "psgi.url_scheme is 'https' (line $line)");
+};
for my $args (
[ "-lhttps://$https_addr/?key=$key,cert=$cert" ],
# normal HTTPS
my $c = tcp_connect($https);
IO::Socket::SSL->start_SSL($c, %o);
- $c->print("GET /url_scheme HTTP/1.1\r\n\r\nHost: example.com\r\n\r\n")
- or xbail "failed to write HTTP request: $!";
- my $buf = '';
- sysread($c, $buf, 2007, length($buf)) until $buf =~ /\r\n\r\nhttps?/;
- like($buf, qr!\AHTTP/1\.1 200!, 'read HTTP response');
- like($buf, qr!\r\nhttps\z!, "psgi.url_scheme is 'https'");
+ $check_url_scheme->($c, __LINE__);
# HTTPS with bad hostname
$c = tcp_connect($https);
$slow->blocking(1);
ok($slow->print("GET /empty HTTP/1.1\r\n\r\nHost: example.com\r\n\r\n"),
'wrote HTTP request from slow');
- $buf = '';
+ my $buf = '';
sysread($slow, $buf, 666, length($buf)) until $buf =~ /\r\n\r\n/;
like($buf, qr!\AHTTP/1\.1 200!, 'read HTTP response from slow');
$slow = undef;
like($x, qr/\Adataready\0+\z/, 'got dataready accf for https');
};
- $c = undef;
+ # switch cert and key:
+ cp('certs/server2-cert.pem', $cert) or xbail $!;
+ cp('certs/server2-key.pem', $key) or xbail $!;
+ $td->kill('HUP') or xbail "kill: $!";
+ tick(); # wait for SIGHUP to take effect (hopefully :x)
+
+ my $d = tcp_connect($https);
+ $d = IO::Socket::SSL->start_SSL($d, %o);
+ is($d, undef, 'HTTPS fails with bad hostname after new cert on HUP');
+
+ $d = tcp_connect($https);
+ $o{SSL_hostname} = $o{SSL_verifycn_name} = 'server2.local';
+ is(IO::Socket::SSL->start_SSL($d, %o), $d,
+ 'new hostname to match cert works after HUP');
+ $check_url_scheme->($d, __LINE__);
+
+ # existing connection w/ old cert still works:
+ $check_url_scheme->($c, __LINE__);
+
+ undef $c;
+ undef $d;
$td->kill;
$td->join;
is($?, 0, 'no error in exited process');