git.maemo.org Git - pkg-perl/blob - deb-src/libio-socket-ssl-perl/libio-socket-ssl-perl-1.16/t/nonblock.t

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