Skip to content

Commit 3f74b38

Browse files
author
Steffen Ullrich
committed
2.093 - another attempt do deal with one-sided SSL shutdown
1 parent 2d5d2bd commit 3f74b38

File tree

6 files changed

+264
-57
lines changed

6 files changed

+264
-57
lines changed

‎Changes‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,7 @@
1+
2.093 2025/06/17
2+
- Another rework for one-sided SSL shutdown, to a) implement a useful and secure
3+
behavior and b) without affecting existing applications. 2.092 had still
4+
unwanted side effects
15
2.092 2025/06/16
26
- rework implementation and behavior for one-sided SSL shutdown. Implementation
37
in 2.091 lead to some problems with Net::FTP and others.

‎MANIFEST‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,7 @@ t/sni_verify.t
7575
t/startssl-failed.t
7676
t/startssl.t
7777
t/start-stopssl.t
78+
t/start-stopssl-with-cb.t
7879
t/sysread_write.t
7980
t/testlib.pl
8081
t/verify_fingerprint.t

‎lib/IO/Socket/SSL.pm‎

Lines changed: 34 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -13,13 +13,13 @@
1313

1414
package IO::Socket::SSL;
1515

16-
our $VERSION = '2.092';
16+
our $VERSION = '2.093';
1717

1818
use IO::Socket;
1919
use Net::SSLeay 1.46;
2020
use IO::Socket::SSL::PublicSuffix;
2121
use Exporter ();
22-
use Errno qw( EWOULDBLOCK EAGAIN ETIMEDOUT EINTR EPIPE );
22+
use Errno qw( EWOULDBLOCK EAGAIN ETIMEDOUT EINTR EPIPE EPERM );
2323
use Carp;
2424
use strict;
2525

@@ -1209,16 +1209,23 @@ sub _generic_read {
12091209
if ($status & SSL_SENT_SHUTDOWN) {
12101210
# fully done, close SSL object - no need to call shutdown again
12111211
$self->stop_SSL(SSL_no_shutdown => 1);
1212+
} elsif (my $cb = ${*$self}{_SSL_arguments}{SSL_on_peer_shutdown}) {
1213+
# Mark as half done but leave further handling to callback
1214+
${*$self}{_SSL_read_closed} = 1;
1215+
return $cb->($self);
12121216
} else {
1213-
# mark read side as automatically closed
1214-
# _SSL_read_closed is
1215-
# -1: SSL shutdown done, but not acknowledged by user
1216-
# 1: SSL shutdown acknowledged by the user
1217-
${*$self}{_SSL_read_closed} = -1;
1217+
# Half done, send also close notify
1218+
# Don't destruct _SSL_object since code might still rely on
1219+
# having access to it. Leave this to explicit stop_SSL or close.
1220+
local $SIG{PIPE} = 'IGNORE';
1221+
$SSL_ERROR = $! = undef;
1222+
Net::SSLeay::shutdown($ssl);
1223+
# Use "-1" to mark as automatic closed and thus require action
1224+
# before reading/sending plain data
1225+
${*$self}{_SSL_read_closed} = ${*$self}{_SSL_write_closed} = -1;
12181226
}
12191227
}
1220-
$! = EAGAIN;
1221-
return;
1228+
return 0;
12221229
}
12231230

12241231
$$buffer = '' if !defined $$buffer;
@@ -1244,8 +1251,7 @@ sub _handle_read_closed_unack {
12441251
# reading eof is fine, reading plain data is not
12451252
return if ! defined recv($self,my $buf,1,MSG_PEEK);
12461253
return 0 if $buf eq '';
1247-
carp "got SSL shutdown by peer, call stop_SSL(SSL_ack_read_closed => 1) before reading plain data";
1248-
$! = EAGAIN;
1254+
$! = EPERM;
12491255
return;
12501256
}
12511257

@@ -1285,10 +1291,7 @@ sub peek {
12851291
return _generic_read( $self, $ssl, 1, \&Net::SSLeay::peek, @_ );
12861292
}
12871293

1288-
if ($rc<0) {
1289-
carp "got SSL shutdown by peer, call stop_SSL(SSL_ack_read_closed => 1) before reading plain data";
1290-
return;
1291-
}
1294+
return _handle_read_closed_unack($self) if $rc<0;
12921295

12931296
# fall back to plain peek if we are not required to use SSL yet
12941297
# emulate peek with recv(...,MSG_PEEK) - peek(buf,len,offset)
@@ -1337,11 +1340,17 @@ sub _generic_write {
13371340
# if all data are written
13381341
sub write {
13391342
my $self = shift;
1340-
my $wc = ${*$self}{_SSL_write_closed};
1343+
my $wc = ${*$self}{_SSL_write_closed} || 0;
13411344
if (my $ssl = !$wc && ${*$self}{_SSL_object}) {
13421345
return _generic_write( $self, $ssl, scalar($self->blocking),@_ );
13431346
}
13441347

1348+
# don't write plain after automtic SSL shutdown
1349+
if ($wc<0) {
1350+
$! = EPERM;
1351+
return;
1352+
}
1353+
13451354
# fall back to plain write if we are not required to use SSL yet
13461355
return ($wc ? _rawfd($self) : $self)->SUPER::write(@_);
13471356
}
@@ -1350,11 +1359,17 @@ sub write {
13501359
# a part of the data is written
13511360
sub syswrite {
13521361
my $self = shift;
1353-
my $wc = ${*$self}{_SSL_write_closed};
1362+
my $wc = ${*$self}{_SSL_write_closed} || 0;
13541363
if (my $ssl = !$wc && ${*$self}{_SSL_object}) {
13551364
return _generic_write($self,$ssl,0,@_);
13561365
}
13571366

1367+
# don't write plain after automtic SSL shutdown
1368+
if ($wc<0) {
1369+
$! = EPERM;
1370+
return;
1371+
}
1372+
13581373
# fall back to plain syswrite if we are not required to use SSL yet
13591374
return ($wc ? _rawfd($self) : $self)->SUPER::syswrite(@_);
13601375
}
@@ -1519,10 +1534,6 @@ sub stop_SSL {
15191534
if (my $ssl = ${*$self}{'_SSL_object'}) {
15201535
if (delete ${*$self}{'_SSL_opening'}) {
15211536
# just destroy the object further below
1522-
} elsif ($stop_args->{SSL_ack_read_closed} ) {
1523-
return 0 if !${*$self}{_SSL_read_closed}; # not (automatically) closed
1524-
${*$self}{_SSL_read_closed} = 1; # accept as closed
1525-
return 1;
15261537
} elsif ( ! $stop_args->{SSL_no_shutdown} ) {
15271538
my $status = Net::SSLeay::get_shutdown($ssl);
15281539

@@ -1602,8 +1613,8 @@ sub stop_SSL {
16021613
if (my $cert = delete ${*$self}{'_SSL_certificate'}) {
16031614
Net::SSLeay::X509_free($cert);
16041615
}
1605-
delete ${*$self}{_SSL_object};
1606-
delete ${*$self}{_SSL_rawfd};
1616+
delete @{*$self}{
1617+
qw(_SSL_object _SSL_write_closed _SSL_read_closed _SSL_rawfd)};
16071618
${*$self}{'_SSL_opened'} = 0;
16081619
delete $SSL_OBJECT{$ssl};
16091620
delete $CREATED_IN_THIS_THREAD{$ssl};

‎lib/IO/Socket/SSL.pod‎

Lines changed: 29 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
1+
CK
22
=head1 NAME
33

44
IO::Socket::SSL - SSL sockets with IO::Socket interface
@@ -1559,6 +1559,12 @@ Example:
15591559

15601560
my $srv = IO::Socket::SSL->new(..., SSL_ticket_keycb => $keycb);
15611561

1562+
=item SSL_on_peer_shutdown CODE
1563+
1564+
This defines a callback which gets called on receiving SSL shutdown (close
1565+
notify) from the peer. This can be used to override the default behavior, see
1566+
C<stop_SSL> for more.
1567+
15621568
=item SSL_mode_release_buffers 1|0
15631569

15641570
This enables or disables the SSL_MODE_RELEASE_BUFFERS option on the SSL object.
@@ -1905,6 +1911,14 @@ This returns false if the socket could not be opened, 1 if the socket could be
19051911
opened and the SSL handshake was successful done and -1 if the underlying
19061912
IO::Handle is open, but the SSL handshake failed.
19071913

1914+
=item B<is_SSL()>
1915+
1916+
This returns undefined if there is no SSL object associated with the socket.
1917+
It will return C<rw> if the state of the SSL object has SSL active for both
1918+
directions, C<r> if there was a locally initiated SSL shutdown (close notify),
1919+
C<w> if a remote SSL shutdown was received and C<> (empty string but defined) if
1920+
a bidirectional SSL shutdown was done.
1921+
19081922
=item B<< IO::Socket::SSL->start_SSL($socket, ... ) >>
19091923

19101924
This will convert a glob reference or a socket that you provide to an
@@ -1953,15 +1967,20 @@ Even if the SSL shutdown is only done for writing (C<SSL_fast_shutdown>) plain
19531967
data can be immediately written.
19541968

19551969
If the SSL shutdown was initiated by the peer it will lead to an implicit SSL
1956-
shutdown for reading and sysread will return undef with errno EAGAIN once in
1957-
this case. After this the socket is ready to receive plain data from the peer.
1958-
But to keep the program in control when encrypted and when plain data are
1959-
received the plain read will only be done if either a full SSL shutdown was
1960-
explicitly issued by calling C<stop_SSL> or if the one sided SSL shutdown from
1961-
the peer is explicitly acknowledged by calling C<stop_SSL> with
1962-
C<SSL_ack_read_closed> set to true. Without this reading will just check
1963-
if the socket is closed and without this issue a warning and return undef with
1964-
EAGAIN.
1970+
shutdown for reading and sysread will return with 0 in this case. It will also
1971+
SSL shutdown the local side. After this the socket is ready to receive plain
1972+
data from the peer and locally send data will also be transmitted in plain. To
1973+
prevent accidental sending/receiving plain data after such implicit SSL
1974+
shutdown, the read and write functions will return undef with $ERRNO set to
1975+
EPERM until an explicit stop_SSL was done. If the peer directly closes the TCP
1976+
connection ater the SSL shutdown without sending plain data this will still be
1977+
detected though.
1978+
1979+
If this default behavior is not wanted a callback can be setup using
1980+
C<SSL_on_peer_shutdown> which gets C<$self> as first argument. The result from
1981+
the callback will then be returned instead of 0 and no local SSL shutdown will
1982+
be automatically initiated. Similar no explicit stop_SSL is needed before
1983+
receiving plain data since the callback is considered explicit action enough.
19651984

19661985
=item B<connect_SSL>, B<accept_SSL>
19671986

‎t/start-stopssl-with-cb.t‎

Lines changed: 157 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,157 @@
1+
#!perl
2+
3+
use strict;
4+
use warnings;
5+
use IO::Socket::INET;
6+
use IO::Socket::SSL;
7+
do './testlib.pl' || do './t/testlib.pl' || die "no testlib";
8+
9+
$|=1;
10+
my @tests = qw( start stop start stop:write close );
11+
print "1..20\n";
12+
13+
my $server = IO::Socket::INET->new(
14+
LocalAddr => '127.0.0.1',
15+
LocalPort => 0,
16+
Listen => 2,
17+
) || die "not ok # tcp listen failed: $!\n";
18+
print "ok # listen\n";
19+
my $saddr = $server->sockhost.':'.$server->sockport;
20+
21+
defined( my $pid = fork() ) || die $!;
22+
$pid ? server():client();
23+
wait;
24+
exit(0);
25+
26+
27+
sub client {
28+
close($server);
29+
my $client = IO::Socket::INET->new($saddr) or
30+
die "not ok # client connect: $!\n";
31+
$client->autoflush;
32+
print "ok # client connect\n";
33+
34+
for my $test (@tests) {
35+
alarm(15);
36+
#print STDERR "begin test $test\n";
37+
if ( $test eq 'start' ) {
38+
syswrite($client,"start\n");
39+
sleep(1); # avoid race condition, if client calls start but server is not yet available
40+
41+
#print STDERR ">>$$(client) start\n";
42+
IO::Socket::SSL->start_SSL($client, SSL_verify_mode => 0 )
43+
|| die "not ok # client::start_SSL: $SSL_ERROR\n";
44+
#print STDERR "<<$$(client) start\n";
45+
print "ok # client::start_SSL\n";
46+
47+
ref($client) eq "IO::Socket::SSL" or print "not ";
48+
print "ok # client::class=".ref($client)."\n";
49+
50+
} elsif ( $test eq 'stop' ) {
51+
syswrite($client,"stop\n");
52+
$client->stop_SSL || die "not ok # client::stop_SSL\n";
53+
print "ok # client::stop_SSL\n";
54+
55+
ref($client) eq "IO::Socket::INET" or print "not ";
56+
print "ok # client::class=".ref($client)."\n";
57+
58+
} elsif ( $test eq 'stop:write' ) {
59+
syswrite($client,"stop:write\n");
60+
$client->stop_SSL(SSL_fast_shutdown => 1)
61+
|| die "not ok # client::stop_SSL\n";
62+
print "ok # client::stop_SSL(SSL_fast_shutdown => 1)\n";
63+
64+
ref($client) eq "IO::Socket::SSL" or print "not ";
65+
print "ok # client::class=".ref($client)."\n";
66+
67+
${*$client}{_SSL_write_closed} or print "not ";
68+
print "ok # client _SSL_write_closed\n";
69+
70+
# this should be send in plain
71+
syswrite($client, "after stop:write\n");
72+
73+
} elsif ( $test eq 'close' ) {
74+
syswrite($client,"close\n");
75+
my $class = ref($client);
76+
$client->close || die "not ok # client::close\n";
77+
print "ok # client::close\n";
78+
79+
ref($client) eq $class or print "not ";
80+
print "ok # client::class=".ref($client)."\n";
81+
last;
82+
}
83+
#print STDERR "cont test $test\n";
84+
85+
sysread($client, my $line, 1024) or return;
86+
die "'$line'" if $line ne "OK\n";
87+
}
88+
}
89+
90+
91+
sub server {
92+
my $client = $server->accept || die $!;
93+
$client->autoflush;
94+
my $peer_shutdown;
95+
while (1) {
96+
alarm(15);
97+
sysread($client, my $line, 1024) or last;
98+
chomp($line);
99+
if ( $line eq 'start' ) {
100+
#print STDERR ">>$$ start\n";
101+
IO::Socket::SSL->start_SSL( $client,
102+
SSL_server => 1,
103+
SSL_cert_file => "t/certs/client-cert.pem",
104+
SSL_key_file => "t/certs/client-key.pem",
105+
SSL_on_peer_shutdown => sub {
106+
$peer_shutdown = 1;
107+
return;
108+
}
109+
) || die "not ok # server::start_SSL: $SSL_ERROR\n";
110+
#print STDERR "<<$$ start\n";
111+
112+
ref($client) eq "IO::Socket::SSL" or print "not ";
113+
print "ok # server::class=".ref($client)."\n";
114+
syswrite($client,"OK\n");
115+
116+
} elsif ( $line eq 'stop' ) {
117+
$client->stop_SSL || die "not ok # server::stop_SSL\n";
118+
print "ok # server::stop_SSL\n";
119+
120+
ref($client) eq "IO::Socket::INET" or print "not ";
121+
print "ok # server class=".ref($client)."\n";
122+
syswrite($client,"OK\n");
123+
124+
} elsif ( $line eq 'stop:write' ) {
125+
# expect undef + $peer_shutdown true - see SSL_on_peer_shutdown
126+
my $n = sysread($client, $line, 1);
127+
print "not " if defined $n or !$peer_shutdown;
128+
print "ok # server read ssl n=undef + peer_shutdown true\n";
129+
130+
ref($client) eq "IO::Socket::SSL" or print "not ";
131+
print "ok # server class=".ref($client)."\n";
132+
133+
${*$client}{_SSL_read_closed} == 1 or print "not ";
134+
print "ok # server _SSL_read_closed == 1\n";
135+
136+
# finish shutdown
137+
$client->stop_SSL() || die "not ok # server::stop_SSL\n";
138+
# _SSL_read_closed should be no longer there
139+
exists(${*$client}{_SSL_read_closed}) and print "not ";
140+
print "ok # server _SSL_read_closed gone\n";
141+
142+
$n = sysread($client, $line, 100);
143+
print "not " if ! $line || $line ne "after stop:write\n";
144+
print "ok # server plain read: $line\n";
145+
syswrite($client,"OK\n");
146+
147+
} elsif ( $line eq 'close' ) {
148+
my $class = ref($client);
149+
$client->close || die "not ok # server::close\n";
150+
print "ok # server::close\n";
151+
152+
ref($client) eq $class or print "not ";
153+
print "ok # server class=".ref($client)."\n";
154+
last;
155+
}
156+
}
157+
}

0 commit comments

Comments
 (0)