view release on metacpan or  search on metacpan

t/18-destructive-lifecycle.t  view on Meta::CPAN

sub pump_pair {
    my ($client, $server, $client_local, $server_local) = @_;
    my $progress = 0;

    while (my $datagram = $server->next_datagram) {
        ++$progress;
        $client->receive_datagram(
            $datagram->data,
            $client_local,
            $server_local,
        );
    }

    while (my $datagram = $client->next_datagram) {
        ++$progress;
        $server->receive_datagram(
            $datagram->data,
            $server_local,
            $client_local,
        );
    }

    my $server_after = $server->timeout_after;
    if (defined($server_after) && $server_after <= 0) {
        ++$progress;
        $server->handle_timeout;
    }

    my $client_after = $client->timeout_after;
    if (defined($client_after) && $client_after <= 0) {
        ++$progress;
        $client->handle_timeout;
    }

    if (!$progress) {
        my @wait = sort { $a <=> $b }
            grep { defined($_) && $_ > 0 }
            ($server_after, $client_after);

        if (@wait) {
            my $nap = $wait[0] > 0.01 ? 0.01 : $wait[0] + 0.001;
            sleep($nap);
            ++$progress;
        }
    }

    return $progress;
}

sub make_ready_pair {
    my ($port, $name) = @_;

    my $server_local = pack_sockaddr_in($port, inet_aton('127.0.0.1'));
    my $client_local = pack_sockaddr_in($port + 10000, inet_aton('127.0.0.1'));
    my $alpn = "net-quic-lifecycle-$name";

    my $server = Net::QUIC::Endpoint->server(
        alpn             => $alpn,
        certificate_file => $cert_file,
        private_key_file => $key_file,
    );

    my $client = Net::QUIC::Endpoint->client(
        local       => $client_local,
        peer        => $server_local,
        alpn        => $alpn,
        server_name => 'localhost',
        ca_file     => $cert_file,
    );

    my $accepted;

    for (1 .. 1000) {
        pump_pair($client, $server, $client_local, $server_local);
        $accepted ||= $server->next_connection;

        last if $accepted
            && $client->connection->ready
            && $accepted->ready;
    }

    die "lifecycle test handshake did not complete"
        if !$accepted
        || !$client->connection->ready
        || !$accepted->ready;

    return (
        $client,
        $server,
        $accepted,
        $client_local,
        $server_local,
    );
}

subtest 'object destruction order' => sub {
    my ($client, $server, $accepted, $client_local, $server_local) =
        make_ready_pair(4460, 'drop-order-one');

    my @discarded;
    my @timeouts;

    my $driver = Net::QUIC::Driver->new(
        endpoint => $client,

        send => sub {
            my ($datagram) = @_;
            push @discarded, $datagram;
            return 1;
        },

        set_timeout => sub {
            push @timeouts, $_[0];
            return;
        },
    );

    my $connection = $driver->connection;
    my $stream = $connection->open_uni_stream;

t/18-destructive-lifecycle.t  view on Meta::CPAN

            $server->receive_datagram(
                $datagram->data,
                $server_local,
                $locals->[$i],
            );
        }
    }

    while (my $datagram = $server->next_datagram) {
        my $client = $client_for{$datagram->peer};
        die "server produced datagram for unknown lifecycle client"
            if !defined $client;

        ++$progress;
        $client->receive_datagram(
            $datagram->data,
            $datagram->peer,
            $server_local,
        );
    }

    my $server_after = $server->timeout_after;
    if (defined($server_after) && $server_after <= 0) {
        ++$progress;
        $server->handle_timeout;
    }

    my @client_after;
    for my $client (@$clients) {
        my $after = $client->timeout_after;
        push @client_after, $after;

        if (defined($after) && $after <= 0) {
            ++$progress;
            $client->handle_timeout;
        }
    }

    if (!$progress) {
        my @wait = sort { $a <=> $b }
            grep { defined($_) && $_ > 0 }
            ($server_after, @client_after);

        if (@wait) {
            my $nap = $wait[0] > 0.01 ? 0.01 : $wait[0] + 0.001;
            sleep($nap);
            ++$progress;
        }
    }

    return $progress;
}

subtest 'staggered multi-connection retirement' => sub {
    my $server_local = pack_sockaddr_in(4463, inet_aton('127.0.0.1'));
    my $alpn = 'net-quic-lifecycle-many';

    my $server = Net::QUIC::Endpoint->server(
        alpn             => $alpn,
        certificate_file => $cert_file,
        private_key_file => $key_file,
    );

    my @locals = map {
        pack_sockaddr_in(41000 + $_, inet_aton('127.0.0.1'))
    } 0 .. 2;

    my @clients = map {
        Net::QUIC::Endpoint->client(
            local       => $locals[$_],
            peer        => $server_local,
            alpn        => $alpn,
            server_name => 'localhost',
            ca_file     => $cert_file,
        )
    } 0 .. 2;

    my @accepted;

    for (1 .. 2000) {
        pump_many($server, \@clients, \@locals, $server_local);

        while (my $connection = $server->next_connection) {
            push @accepted, $connection;
        }

        last if @accepted == 3
            && !(grep { !$_->connection->ready } @clients)
            && !(grep { !$_->ready } @accepted);
    }

    is(scalar(@accepted), 3, 'server accepts all three lifecycle clients');
    ok(!(grep { !$_->connection->ready } @clients), 'all clients are ready');
    ok(!(grep { !$_->ready } @accepted), 'all server Connections are ready');
    is($server->_managed_connection_count, 3, 'server manages three live Connections');
    ok($server->_route_count >= 3, 'live Connections have CID routes');

    my @client_streams;
    for my $i (0 .. 2) {
        my $stream = $clients[$i]->connection->open_bidi_stream;
        $stream->send("lifecycle-client-$i\n");
        $stream->finish;
        push @client_streams, $stream;
    }

    my @server_for;
    my %server_stream_for;
    my %server_finished;
    my %received_for;

    for (1 .. 2000) {
        pump_many($server, \@clients, \@locals, $server_local);

        for my $connection (@accepted) {
            my $key = refaddr($connection);
            my $stream = $server_stream_for{$key};

            if (!$stream) {
                $stream = $connection->next_stream;
                $server_stream_for{$key} = $stream if $stream;
            }