view release on metacpan or  search on metacpan

t/59-ws-disconnect-exactly-once.t  view on Meta::CPAN

# masked per RFC 6455). Mirrors t/14-websocket-invalid-utf8.t's helper.
sub make_websocket_frame {
    my ($opcode, $payload) = @_;

    my $frame = chr(0x80 | $opcode);

    my $len = length($payload);
    if ($len < 126) {
        $frame .= chr(0x80 | $len);
    }
    else {
        $frame .= chr(0x80 | 126) . pack('n', $len);
    }

    my $mask = pack('N', int(rand(0xFFFFFFFF)));
    $frame .= $mask;

    my $masked_payload = '';
    for my $i (0 .. length($payload) - 1) {
        $masked_payload .= chr(ord(substr($payload, $i, 1)) ^ ord(substr($mask, $i % 4, 1)));
    }
    $frame .= $masked_payload;

    return $frame;
}

subtest 'clean peer close delivers exactly one websocket.disconnect' => sub {
    my @seen;

    my $test_app = async sub {
        my ($scope, $receive, $send) = @_;

        if ($scope->{type} eq 'lifespan') {
            while (1) {
                my $event = await $receive->();
                if ($event->{type} eq 'lifespan.startup') {
                    await $send->({ type => 'lifespan.startup.complete' });
                }
                elsif ($event->{type} eq 'lifespan.shutdown') {
                    await $send->({ type => 'lifespan.shutdown.complete' });
                    last;
                }
            }
            return;
        }

        return unless $scope->{type} eq 'websocket';

        my $event = await $receive->();  # websocket.connect
        await $send->({ type => 'websocket.accept' });

        # Normal, well-behaved app: stop calling receive() the moment the
        # first websocket.disconnect arrives -- exactly one call, ever.
        my $ev = await $receive->();
        push @seen, $ev;

        # Stay alive well past the TCP close that follows the peer's Close
        # frame (~50ms later, per the reproduction) without calling receive()
        # again. This isolates the on_closed path as the only thing that can
        # still act after the Close frame was handled -- the app's own
        # session-complete teardown (which fires the moment this coroutine
        # returns) must not be what triggers a second delivery.
        await $loop->delay_future(after => 0.5);
    };

    my $server = PAGI::Server->new(
        app   => $test_app,
        host  => '127.0.0.1',
        port  => 0,
        quiet => 1,
    );

    $loop->add($server);
    $server->listen->get;
    my $port = $server->port;

    my $sock = IO::Socket::INET->new(
        PeerAddr => '127.0.0.1',
        PeerPort => $port,
        Proto    => 'tcp',
        Timeout  => 5,
    );

    SKIP: {
        skip "Cannot connect to server", 5 unless $sock;

        my $key = 'dGhlIHNhbXBsZSBub25jZQ==';
        print $sock "GET / HTTP/1.1\r\n";
        print $sock "Host: 127.0.0.1:$port\r\n";
        print $sock "Upgrade: websocket\r\n";
        print $sock "Connection: Upgrade\r\n";
        print $sock "Sec-WebSocket-Key: $key\r\n";
        print $sock "Sec-WebSocket-Version: 13\r\n";
        print $sock "\r\n";

        $sock->blocking(0);
        my $response = '';
        my $deadline = time + 3;
        while (time < $deadline) {
            my $buf;
            my $n = sysread($sock, $buf, 4096);
            if (defined $n && $n > 0) {
                $response .= $buf;
                last if $response =~ /\r\n\r\n/;
            }
            $loop->loop_once(0.1);
        }
        like($response, qr/HTTP\/1\.1 101/, 'WebSocket upgrade successful');

        # White-box handle on the live Connection object -- captured now,
        # before any close activity, so it survives the connection's later
        # removal from $server->{connections}.
        my ($conn) = values %{$server->{connections}};
        ok($conn, 'captured Connection object for white-box inspection');

        # Step 1: peer sends a clean Close frame (code 1000, reason 'bye').
        my $close_frame = make_websocket_frame(8, pack('n', 1000) . 'bye');
        $sock->blocking(1);
        print $sock $close_frame;
        $sock->flush;