1#!perl -w 2# Before `make install' is performed this script should be runnable with 3# `make test'. After `make install' it should work as `perl t/nonblock.t' 4 5 6use Net::SSLeay; 7use Socket; 8use IO::Socket::SSL; 9use IO::Select; 10use Errno qw( EAGAIN EINPROGRESS EPIPE ECONNRESET ); 11use strict; 12 13use vars qw( $SSL_SERVER_ADDR ); 14do "t/ssl_settings.req" || do "ssl_settings.req"; 15 16if ( ! eval "use 5.006; use IO::Select; return 1" ) { 17 print "1..0 # Skipped: no support for nonblocking sockets\n"; 18 exit; 19} 20if ( grep { $^O =~m{$_} } qw( MacOS VOS vmesa riscos amigaos ) ) { 21 print "1..0 # Skipped: fork not implemented on this platform\n"; 22 exit 23} 24 25if ( $^O =~m{mswin32}i ) { 26 print "1..0 # Skipped: nonblocking does not work on Win32\n"; 27 exit 28} 29 30$SIG{PIPE} = 'IGNORE'; # use EPIPE not signal handler 31 32$|=1; 33print "1..27\n"; 34 35################################################################# 36# create Server socket before forking client, so that it is 37# guaranteed to be listening 38################################################################# 39my %tls_options = ( 40 SSL_version => 'TLSv1', 41 SSL_cipher_list => 'HIGH', 42); 43 44 45# first create simple non-blocking tcp-server 46my $ID = 'server'; 47my $server = IO::Socket::INET->new( 48 Blocking => 0, 49 LocalAddr => $SSL_SERVER_ADDR, 50 Listen => 2, 51 ReuseAddr => 1, 52); 53 54print "not ok: $!\n", exit if !$server; # Address in use? 55ok("Server Initialization"); 56 57my ($SSL_SERVER_PORT) = unpack_sockaddr_in( $server->sockname ); 58 59defined( my $pid = fork() ) || die $!; 60if ( $pid == 0 ) { 61 62 ############################################################ 63 # CLIENT == child process 64 ############################################################ 65 66 close($server); 67 $ID = 'client'; 68 my %extra_options = $Net::SSLeay::VERSION>=1.16 ? 69 ( 70 SSL_key_file => "certs/server-key.enc", 71 SSL_passwd_cb => sub { return "bluebell" }, 72 ) : ( 73 SSL_key_file => "certs/server-key.pem" 74 ); 75 76 # fast: try connect_SSL immediatly after sending plain text 77 # connect_SSL should fail on the first attempt because server 78 # is not ready yet 79 # slow: wait before calling connect_SSL 80 # connect_SSL should succeed, because server was already waiting 81 82 for my $test ( 'fast','slow' ) { 83 84 # initial socket is unconnected, tcp, nonblocking 85 my $to_server = IO::Socket::INET->new( Proto => 'tcp', Blocking => 0 ); 86 87 my $server_addr = pack_sockaddr_in( 88 $SSL_SERVER_PORT, 89 inet_aton( $SSL_SERVER_ADDR ) 90 ); 91 92 # nonblocking connect of tcp socket 93 while (1) { 94 connect($to_server,$server_addr ) && last; 95 if ( $!{EINPROGRESS} ) { 96 diag( 'connect in progress' ); 97 IO::Select->new( $to_server )->can_write(30) && next; 98 print "not "; 99 last; 100 } elsif ( $!{EALREADY} ) { 101 diag( 'connect not yet completed'); 102 # just wait 103 select(undef,undef,undef,0.1); 104 next; 105 } elsif ( $!{EISCONN} ) { 106 diag('claims that socket is already connected'); 107 # found on Mac OS X, dunno why it does not tell me that 108 # the connect succeeded before 109 last; 110 } 111 diag( 'connect failed: '.$! ); 112 print "not "; 113 last; 114 } 115 ok( "client tcp connect" ); 116 117 # work around (older?) systems where IO::Socket::INET 118 # cannot do non-blocking connect by forcing non-blocking 119 # again (we want to test non-blocking behavior of IO::Socket::SSL, 120 # not IO::Socket::INET) 121 $to_server->blocking(0); 122 123 # send some plain text on non-ssl socket 124 my $pmsg = 'plaintext'; 125 while ( $pmsg ne '' ) { 126 my $w = syswrite( $to_server,$pmsg ); 127 if ( ! defined $w ) { 128 if ( ! $!{EAGAIN} ) { 129 diag("syswrite failed with $!"); 130 print "not "; 131 last; 132 } 133 IO::Select->new($to_server)->can_write(30) or do { 134 diag("failed to get write ready"); 135 print "not "; 136 last; 137 }; 138 } elsif ( $w>0 ) { 139 diag("wrote $w bytes"); 140 substr($pmsg,0,$w,''); 141 } else { 142 die "syswrite returned 0"; 143 } 144 } 145 ok( "write plain text" ); 146 147 # let server catch up, so that it awaits my connection 148 # so that connect_SSL does not have to wait 149 sleep(5) if ( $test eq 'slow' ); 150 151 # upgrade to SSL socket w/o connection yet 152 if ( ! IO::Socket::SSL->start_SSL( $to_server, 153 SSL_startHandshake => 0, 154 %extra_options, 155 %tls_options, 156 )) { 157 diag( 'start_SSL return undef' ); 158 print "not "; 159 } elsif ( !UNIVERSAL::isa( $to_server,'IO::Socket::SSL' ) ) { 160 diag( 'failed to upgrade socket' ); 161 print "not "; 162 } 163 ok( "upgrade client to IO::Socket::SSL" ); 164 165 # SSL handshake thru connect_SSL 166 # if $test eq 'fast' we expect one failed attempt because server 167 # did not call accept_SSL yet 168 my $attempts = 0; 169 while ( 1 ) { 170 $to_server->connect_SSL && last; 171 diag( $SSL_ERROR ); 172 if ( $SSL_ERROR == SSL_WANT_READ ) { 173 $attempts++; 174 IO::Select->new($to_server)->can_read(30) && next; # retry if can read 175 } elsif ( $SSL_ERROR == SSL_WANT_WRITE ) { 176 IO::Select->new($to_server)->can_write(30) && next; # retry if can write 177 } 178 diag( "failed to connect: $@" ); 179 print "not "; 180 last; 181 } 182 ok( "connected" ); 183 184 if ( $test ne 'slow' ) { 185 print "not " if !$attempts; 186 ok( "nonblocking connect with $attempts attempts" ); 187 } 188 189 # send some data 190 # we send up to 500000 bytes, server reads first 10 bytes and then sleeps 191 # before reading more. In total server only reads 30000 bytes 192 # the sleep will cause the internal buffers to fill up so that the syswrite 193 # should return with EAGAIN+SSL_WANT_WRITE. 194 # the socket close should cause EPIPE or ECONNRESET 195 196 my $msg = "1234567890"; 197 $attempts = 0; 198 my $bytes_send = 0; 199 200 # set send buffer to 8192 so it will definitly fail writing all 500000 bytes in it 201 # beware that linux allocates twice as much (see tcp(7)) 202 # AIX seems to get very slow if you set the sndbuf on localhost, so don't to it 203 # https://rt.cpan.org/Public/Bug/Display.html?id=72305 204 if ( $^O !~m/aix/i ) { 205 eval q{ 206 setsockopt( $to_server, SOL_SOCKET, SO_SNDBUF, pack( "I",8192 )); 207 diag( "sndbuf=".unpack( "I",getsockopt( $to_server, SOL_SOCKET, SO_SNDBUF ))); 208 }; 209 } 210 211 my $test_might_fail; 212 if ( $@ ) { 213 # the next test might fail because setsockopt(... SO_SNDBUF...) failed 214 $test_might_fail = 1; 215 } 216 217 my $can; 218 WRITE: 219 for( my $i=0;$i<50000;$i++ ) { 220 my $offset = 0; 221 while (1) { 222 if ( $can && ! IO::Select->new($to_server)->$can(30)) { 223 diag("fail $can"); 224 print "not "; 225 last WRITE; 226 }; 227 my $n = syswrite( $to_server,$msg,length($msg)-$offset,$offset ); 228 if ( !defined($n) ) { 229 diag( "\$!=$! \$SSL_ERROR=$SSL_ERROR send=$bytes_send" ); 230 if ( $! == EAGAIN ) { 231 if ( $SSL_ERROR == SSL_WANT_WRITE ) { 232 diag( 'wait for write' ); 233 $can = 'can_write'; 234 $attempts++; 235 } elsif ( $SSL_ERROR == SSL_WANT_READ ) { 236 diag( 'wait for read' ); 237 $can = 'can_read'; 238 } else { 239 $can = 'can_write'; 240 } 241 } elsif ( ( $! == EPIPE || $! == ECONNRESET ) && $bytes_send > 30000 ) { 242 diag( "connection closed hard" ); 243 last WRITE; 244 } else { 245 print "not "; 246 last WRITE; 247 } 248 next; 249 } elsif ( $n == 0 ) { 250 diag( "connection closed" ); 251 last WRITE; 252 } elsif ( $n<0 ) { 253 diag( "syswrite returned $n!" ); 254 print "not "; 255 last WRITE; 256 } 257 258 $bytes_send += $n; 259 if ( $n + $offset == 10 ) { 260 last 261 } else { 262 $offset += $n; 263 diag( "partial write of $n new offset=$offset" ); 264 } 265 } 266 } 267 ok( "syswrite" ); 268 269 if ( ! $attempts && $test_might_fail ) { 270 ok( " write attempts failed, but OK nevertheless because setsockopt failed" ); 271 } else { 272 print "not " if !$attempts; 273 ok( "multiple write attempts" ); 274 } 275 276 print "not " if $bytes_send < 30000; 277 ok( "30000 bytes send" ); 278 } 279 280} else { 281 282 ############################################################ 283 # SERVER == parent process 284 ############################################################ 285 my %extra_options = $Net::SSLeay::VERSION>=1.16 ? 286 ( 287 SSL_key_file => "certs/client-key.enc", 288 SSL_passwd_cb => sub { return "opossum" } 289 ) : ( 290 SSL_key_file => "certs/client-key.pem" 291 ); 292 293 # pendant to tests in client. Where client is slow (sleep 294 # between plain text sending and connect_SSL) I need to 295 # be fast and where client is fast I need to be slow (sleep 296 # between receiving plain text and accept_SSL) 297 298 foreach my $test ( 'slow','fast' ) { 299 300 # accept a connection 301 IO::Select->new( $server )->can_read(30); 302 my $from_client = $server->accept or print "not "; 303 ok( "tcp accept" ); 304 $from_client || do { 305 diag( "failed to tcp accept: $!" ); 306 next; 307 }; 308 309 # make client non-blocking! 310 $from_client->blocking(0); 311 312 # read plain text data 313 my $buf = ''; 314 while ( length($buf) <9 ) { 315 sysread( $from_client, $buf,9-length($buf),length($buf) ) && next; 316 die "sysread failed: $!" if $! != EAGAIN; 317 IO::Select->new( $from_client )->can_read(30); 318 } 319 $buf eq 'plaintext' || print "not "; 320 ok( "received plain text" ); 321 322 # upgrade socket to IO::Socket::SSL 323 # no handshake yet 324 if ( ! IO::Socket::SSL->start_SSL( $from_client, 325 SSL_startHandshake => 0, 326 SSL_server => 1, 327 SSL_verify_mode => 0x00, 328 SSL_ca_file => "certs/test-ca.pem", 329 SSL_use_cert => 1, 330 SSL_cert_file => "certs/client-cert.pem", 331 %extra_options, 332 %tls_options, 333 )) { 334 diag( 'start_SSL return undef' ); 335 print "not "; 336 } elsif ( !UNIVERSAL::isa( $from_client,'IO::Socket::SSL' ) ) { 337 diag( 'failed to upgrade socket' ); 338 print "not "; 339 } 340 ok( "upgrade to_client to IO::Socket::SSL" ); 341 342 sleep(5) if $test eq 'slow'; # wait until client calls connect_SSL 343 344 # SSL handshake thru accept_SSL 345 # if test is 'fast' (e.g. client is 'slow') we excpect the first 346 # accept_SSL attempt to fail because client did not call connect_SSL yet 347 my $attempts = 0; 348 while ( 1 ) { 349 $from_client->accept_SSL && last; 350 if ( $SSL_ERROR == SSL_WANT_READ ) { 351 $attempts++; 352 IO::Select->new($from_client)->can_read(30) && next; # retry if can read 353 } elsif ( $SSL_ERROR == SSL_WANT_WRITE ) { 354 $attempts++; 355 IO::Select->new($from_client)->can_write(30) && next; # retry if can write 356 } else { 357 diag( "failed to ssl accept ($test): $@" ); 358 print "not "; 359 last; 360 } 361 } 362 ok( "ssl accept handshake done" ); 363 364 if ( $test eq 'fast' ) { 365 print "not " if !$attempts; 366 ok( "nonblocking accept_SSL with $attempts attempts" ); 367 } 368 369 # reading 10 bytes 370 # then sleeping so that buffers from client to server gets 371 # filled up and clients receives EAGAIN+SSL_WANT_WRITE 372 373 IO::Select->new( $from_client )->can_read(30); 374 ( sysread( $from_client, $buf,10 ) == 10 ) || print "not "; 375 #diag($buf); 376 ok( "received client message" ); 377 378 sleep(5); 379 my $bytes_received = 10; 380 381 # read up to 30000 bytes from client, then close the socket 382 my $can; 383 READ: 384 while ( ( my $diff = 30000 - $bytes_received ) > 0 ) { 385 if ( $can && ! IO::Select->new($from_client)->$can(30)) { 386 diag("failed $can"); 387 print "not "; 388 last READ; 389 } 390 my $n = sysread( $from_client,my $buf,$diff ); 391 if ( !defined($n) ) { 392 diag( "\$!=$! \$SSL_ERROR=$SSL_ERROR" ); 393 if ( $! == EAGAIN ) { 394 if ( $SSL_ERROR == SSL_WANT_READ ) { 395 $attempts++; 396 $can = 'can_read'; 397 } elsif ( $SSL_ERROR == SSL_WANT_WRITE ) { 398 $attempts++; 399 $can = 'can_write'; 400 } else { 401 $can = 'can_read'; 402 } 403 } else { 404 print "not "; 405 last READ; 406 } 407 next; 408 } elsif ( $n == 0 ) { 409 diag( "connection closed" ); 410 last READ; 411 } elsif ( $n<0 ) { 412 diag( "sysread returned $n!" ); 413 print "not "; 414 last READ; 415 } 416 417 $bytes_received += $n; 418 #diag( "read of $n bytes total $bytes_received" ); 419 } 420 421 diag( "read $bytes_received ($attempts r/w attempts)" ); 422 close($from_client); 423 } 424 425 # wait until client exits 426 wait; 427} 428 429exit; 430 431 432 433sub ok { print "ok # [$ID] @_\n"; } 434sub diag { print "# @_\n" } 435