Test stunnel behavior when file descriptor limit exceeded

fd_limit_test

#!/usr/bin/perl

use strict;
use warnings;
use TestUtils;
use TestHTTPD;
use File::Temp;
use BSD::Resource qw( setrlimit RLIMIT_NOFILE );

sub proxy {
    my $config = shift;

    setrlimit(RLIMIT_NOFILE, 16, 16)
        or die("Failed to set rlimit: $!");
    exec(@_, 'src/stunnel', $config);
}

sub worker($$$$) {
    my ($hostname, $path, $port, $requests) = @_;

    for (my $i = 0; $i < $requests; $i++) {
        system('curl',
                '-s', '-S', '-k',
                '-H', "Host: $hostname",
                '-o', '/dev/null',
                "https://localhost:$port/$path");

        if ($? == -1) {
            die "failed to execute: $!\n";
        } elsif ($? & 127) {
            printf STDERR "child died with signal %d, %s coredump\n", ($? & 127), ($? & 128) ? 'with' : 'without';
            exit 255;
        } elsif ($? >> 8) {
            exit $? >> 8;
        }
    }
    # Success
    exit 0;
}

sub make_stunnel_config($$) {
    my $proxy_port = shift;
    my $httpd_port = shift;

    my ($fh, $filename) = File::Temp::tempfile();
    my ($unused, $pidfile) = File::Temp::tempfile();
    close($unused);
    my ($unused, $certfile) = File::Temp::tempfile();
    close($unused);
    unlink $certfile;

    # Generate test cert key pair
    system('openssl', 'req', '-x509', '-nodes',
            '-days', '365',
            '-subj', '/C=US/ST=WA/O=Stunnel Test/CN=localhost',
            '-newkey', 'rsa:2048',
            '-out', $certfile,
            '-keyout', $certfile);
    chmod 0600, $certfile;

    # Write out a test config file
    print $fh <<END;
sslVersion = all
options = NO_SSLv2
options = CIPHER_SERVER_PREFERENCE
syslog = no
foreground = yes
reset = no
pid = $pidfile

socket = l:TCP_NODELAY=1
socket = r:TCP_NODELAY=1

[test]
    cert = $certfile
    accept = 127.0.0.1:$proxy_port
    connect = 127.0.0.1:$httpd_port
    TIMEOUTclose = 0
    TIMEOUTidle = 50
END

    close ($fh);

    return $filename;
}

sub main {
    my $proxy_port = $ENV{STUNNEL_PORT} || 8080;
    my $httpd_port = $ENV{TEST_HTTPD_PORT} || 8081;
    my $workers = $ENV{WORKERS} || 10;
    my $iterations = $ENV{ITERATIONS} || 3;
    my $local_httpd = $ENV{LOCAL_HTTPD_PORT};

    my $config = make_stunnel_config($proxy_port, $local_httpd || $httpd_port);
    my $proxy_pid = start_child('server', \&proxy, $config, @ARGV);
    my $httpd_pid = start_child('server', \&TestHTTPD::httpd, $httpd_port) unless $local_httpd;

    # Wait for proxy to load and parse config
    wait_for_port($httpd_port);
    wait_for_port($proxy_port);

    for (my $i = 0; $i < $workers; $i++) {
        start_child('worker', \&worker, 'localhost', '', $proxy_port, $iterations);
    }

    # Wait for all our children to finish
    wait_for_type('worker');

    # Give the proxy a second to flush buffers and close server connections
    sleep 1;

    # For troubleshooting connections stuck in CLOSE_WAIT state
    #kill 10, $proxy_pid;
    #system("netstat -ptn | grep $proxy_pid\/sniproxy");

    # For troubleshooting 100% CPU usage
    #system("top -n 1 -p $proxy_pid -b");

    # Orderly shutdown of the server
    kill 15, $proxy_pid;
    kill 15, $httpd_pid unless $local_httpd;
    sleep 1;

    # Delete our test configuration
    unlink($config);

    # Kill off any remaining children
    reap_children();
}

main();

TestHTTPD.pm

package TestHTTPD;

use warnings;
use strict;
require IO::Socket::INET;
require Socket;
require Exporter;
require Time::HiRes;
our @ISA = qw(Exporter);
our @EXPORT = qw(new);
our $VERSION = '0.01';

# This represents the sizes of chunks of our responses
my $responses = [
    [ 20 ],
    [ 20, 18000],
    [ 22 ],
    [ 200 ],
    [ 20, 1, 1, 1, 1, 1, 1, 200 ],
];

sub httpd {
    my $port = shift;
    my $count = 0;

    my $server = IO::Socket::INET->new(Listen    => Socket::SOMAXCONN(),
                                       Proto     => 'tcp',
                                       LocalAddr => 'localhost',
                                       LocalPort => $port,
                                       ReuseAddr => 1)
        or die $!;

    $SIG{CHLD} = 'IGNORE';

    while(my $client = $server->accept()) {
        $count ++;

        my $pid = fork();
        next if $pid; # Parent
        die "fork: $!" unless defined $pid;

        # Child
        my @chunks = @{$responses->[$count % scalar @{$responses}]};
        my $content_length = 0;
        map { $content_length += $_ } @chunks;

        while (my $line = $client->getline()) {
            # Wait for blank line indicating the end of the request
            last if $line eq "\r\n";
        }

        # Assume a GET request

        print $client "HTTP/1.1 200 OK\r\n";
        print $client "Server: TestHTTPD/$VERSION\r\n";
        print $client "Content-Type: text/plain\r\n";
        print $client "Content-Length: $content_length\r\n";
        print $client "Connection: close\r\n";
        print $client "\r\n";

        # Return data in chunks specified in responses
        while (my $length = shift @chunks) {
            print $client 'X' x $length;
            $client->flush();
            Time::HiRes::usleep(100) if @chunks;
        }

        $client->close();
        exit 0;
    } continue {
        # close child sockets
        $client->close();
    }
    die "accept(): $!";
}

1;

TestUtils.pm

package TestUtils;

use warnings;
use strict;
use POSIX ":sys_wait_h";
use IO::Socket::INET;
require File::Temp;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(start_child reap_children wait_for_type wait_for_port make_config);
our $VERSION = '0.01';

$SIG{CHLD} = \&REAPER;

my %children;

sub REAPER {
    my $stiff;
    while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
        # do something with $stiff if you want
        $children{$stiff}->{'running'} = undef;
        $children{$stiff}->{'exit_code'} = $? >> 8;
        $children{$stiff}->{'signal'} = $? & 127;
        $children{$stiff}->{'core_dumped'} = $? & 128;
    }
    $SIG{CHLD} = \&REAPER; # install *after* calling waitpid
}

# Make several requests through the proxy specifying the host header
sub start_child {
    my $type = shift;
    my $child = shift;
    my @args = @_;

    my $pid = fork();
    if (not defined $pid) {
        die("fork: $!");
    } elsif ($pid == 0) {
        undef $SIG{CHLD};
        $child->(@args);
        # Should not be reached
        exit(99);
    }

    $children{$pid} = {
        type => $type,
        pid => $pid,
        running => 1,
        core_dumped => undef,
        signal => undef,
        exit_core => undef,
    };

    return $pid;
}

sub reap_children {
    while (my @hit_list = grep($children{$_}->{'running'}, keys %children)) {
        kill 15, @hit_list;
        sleep 1;
    }

    # Check that all our children exited cleanly
    my @failures = grep($_->{'exit_code'} != 0 || $_->{'core_dumped'}, values %children);
    if (@failures) {
        print "Test failed.\n";
        foreach (@failures) {
            if ($_->{'core_dumped'}) {
                printf "%s died with signal %d, %s coredump\n", $_->{'type'}, $_->{'signal'}, $_->{'core_dumped'} ? 'with' : 'without';
            } else {
                print "$_->{'type'} failed with exit code $_->{'exit_code'}\n";
            }
        }
        exit 1;
    } else {
        # print "Test passed.\n";
        exit 0;
    }
}

sub wait_for_type($) {
    my $type = shift;

    while (grep($children{$_}->{'running'} && $children{$_}->{'type'} eq $type, keys %children) > 0) {
        sleep 1;
    }
}

sub wait_for_port($) {
    my $port = shift;

    my $delay = 1;
    while ($delay < 60) {
        my $port_open = undef;
        eval {
            my $socket = IO::Socket::INET->new(PeerAddr => '127.0.0.1',
                                            PeerPort => $port,
                                            Proto => "tcp",
                                            Type => SOCK_STREAM);
            if ($socket && $socket->connected()) {
                $socket->shutdown(2);
                $port_open = 1;
            }
        };

        return 1 if ($port_open);

        sleep($delay);
        $delay *= 2;
    }

    return undef;
}

sub make_config($$) {
    my $proxy_port = shift;
    my $httpd_port = shift;

    my ($fh, $filename) = File::Temp::tempfile();
    my ($unused, $logfile) = File::Temp::tempfile();

    # Write out a test config file
    print $fh <<END;
# Minimal test configuration

listen 127.0.0.1 $proxy_port {
    proto http

    access_log $logfile
}

table {
    localhost 127.0.0.1 $httpd_port
}
END

    close ($fh);

    return $filename;
}

1;