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