File Coverage

blib/lib/PAGI/Server/ConnectionState.pm

Criterion	Covered	Total	%
statement	88	89	98.8
branch	32	36	88.8
condition	4	8	50.0
subroutine	13	13	100.0
pod	7	7	100.0
total	144	153	94.1

package PAGI::Server::ConnectionState;

use strict;
use warnings;

our $VERSION = '0.002001';

use Scalar::Util qw(weaken);

=encoding utf8

=head1 NAME

PAGI::Server::ConnectionState - Connection state tracking for HTTP requests

=head1 SYNOPSIS

    my $conn = $scope->{'pagi.connection'};

    # Synchronous, non-destructive check
    if ($conn->is_connected) {
        # Client still connected
    }

    # Get disconnect reason (undef while connected)
    my $reason = $conn->disconnect_reason;

    # Register a callback for an abnormal end (client gone, timeout, error)
    $conn->on_disconnect(sub {
        my ($reason) = @_;
        rollback();
    });

    # ...and its counterpart for a clean finish. Exactly one of the two fires.
    $conn->on_complete(sub {
        commit();
    });

    # Await abnormal disconnect (if Future provided)
    if (my $future = $conn->disconnect_future) {
        my $reason = await $future;
    }

=head1 DESCRIPTION

PAGI::Server::ConnectionState provides a mechanism for applications to detect
client disconnection without consuming messages from the receive queue.

This addresses a fundamental limitation in the PAGI (and ASGI) model where
checking for disconnect via C may inadvertently consume request
body data.

The C method lazily creates a Future only when called,
avoiding allocation overhead for simple request/response handlers that don't
need async disconnect detection.

See the "Connection State" section in L for the full
specification.

=head1 METHODS

=head2 new

    my $conn = PAGI::Server::ConnectionState->new(connection => $connection);

Creates a new connection state object. The C argument provides
a reference to the parent Connection object for lazy Future creation.

=cut

sub new {
    my ($class, %args) = @_;

    my $connected = 1;
    my $reason = undef;

    my $self = bless {
        # Connection reference for lazy Future creation (will be weakened)
        _connection => $args{connection},

        # State (scalar refs - for internal consistency)
        _connected => \$connected,
        _reason    => \$reason,

        # Distinguishes the two terminal states once _connected is false:
        # an abnormal disconnect (false) vs. a clean completion (true).
        _completed => 0,

        # Response progress (HTTP): set when http.response.start is emitted.
        _response_started => 0,

        # Lazy Future (only created if disconnect_future() called)
        _future => undef,

        # Callbacks registered via on_disconnect()
        _callbacks => [],

        # Callbacks registered via on_complete()
        _complete_callbacks => [],
    }, $class;

    # Weaken to avoid circular reference: Connection -> ConnectionState -> Connection
    weaken($self->{_connection}) if $self->{_connection};

    return $self;
}

=head2 is_connected

    my $connected = $conn->is_connected;  # Boolean

Returns true if the connection is still open, false if disconnected.

This is a synchronous, non-destructive check that does not consume
messages from the receive queue.

=cut

sub is_connected {
    my $self = shift;
    return ${$self->{_connected}} ? 1 : 0;
}

=head2 response_started

    my $started = $conn->response_started;  # 0 or 1

True once the server has started this request's response (C
emitted -- by the application, a framework, a middleware, or a server-synthesized
error/backstop response). Server-owned; read-only to applications.

=cut

sub response_started { return $_[0]->{_response_started} ? 1 : 0 }

# Server-internal: called from the send path when http.response.start is emitted.
sub _mark_response_started { $_[0]->{_response_started} = 1; return }

=head2 disconnect_reason

    my $reason = $conn->disconnect_reason;  # String or undef

Returns the disconnect reason string, or C if still connected B
request completed normally> -- every reason below describes an abnormal end.

Standard reason strings:

=over 4

=item * C - Client initiated clean close (TCP FIN) mid-request

=item * C - Client stopped responding (read timeout)

=item * C - Connection idle too long before the request arrived

=item * C - Keep-alive connection idled out between requests

=item * C - Response write timed out

=item * C - Socket write failed (EPIPE, ECONNRESET)

=item * C - Socket read failed

=item * C - HTTP parse error, invalid request

=item * C - Server shutting down gracefully

=item * C - Unhandled server-side error aborted the request

=item * C - Request body exceeded limit

=item * C - A bounded server queue overflowed; connection dropped

=back

See L for the authoritative list.

=cut

sub disconnect_reason {
    my $self = shift;
    return ${$self->{_reason}};
}

=head2 disconnect_future

    my $future = $conn->disconnect_future;  # Future or undef
    my $reason = await $future;

Returns a Future that resolves when the connection closes B
(client disconnect, transport error). On a clean completion the connection
closes but this Future is deliberately left pending — use C to
observe normal completion.

The Future is created lazily on first call, avoiding allocation overhead
for handlers that don't need async disconnect detection.

The Future resolves with the disconnect reason string.

This is useful for racing against other async operations:

    await Future->wait_any($disconnect_future, $event_future);

=cut

sub disconnect_future {
    my $self = shift;

    # Return cached Future if exists
    return $self->{_future} if $self->{_future};

    # Create new Future (lazy)
    my $conn = $self->{_connection};
    my $loop = $conn && $conn->{server} ? $conn->{server}->loop : undef;

    if ($loop) {
        $self->{_future} = $loop->new_future;
    } else {
        # Fallback if no loop available (shouldn't happen in practice)
        require Future;
        $self->{_future} = Future->new;
    }

    # If already disconnected, resolve immediately
    unless (${$self->{_connected}}) {
        $self->{_future}->done(${$self->{_reason}});
    }

    return $self->{_future};
}

=head2 on_disconnect

    $conn->on_disconnect(sub {
        my ($reason) = @_;
        # cleanup code
    });

Registers a callback to be invoked when disconnect occurs.

=over 4

=item * May be called multiple times to register multiple callbacks

=item * Callbacks are invoked in registration order

=item * Callbacks receive the disconnect reason as the first argument

=item * If registered after disconnect already occurred, callback is
invoked immediately with the reason

=item * One callback's failure does not prevent other callbacks from
being invoked

=back

=cut

sub on_disconnect {
    my ($self, $cb) = @_;

    # Still in flight: register for later.
    if (${$self->{_connected}}) {
        push @{$self->{_callbacks}}, $cb;
        return;
    }

    # Terminal: only fire if the request ended abnormally, not on clean
    # completion (on_disconnect means "something went wrong").
    return if $self->{_completed};

    eval { $cb->(${$self->{_reason}}) };
    warn "on_disconnect callback error: $@" if $@;
}

=head2 on_complete

    $conn->on_complete(sub {
        # request finished cleanly
    });

Registers a callback invoked B
(the response was fully delivered without the client disconnecting). It is the
counterpart to L: exactly one of the two fires for a given
request.

=over 4

=item * May be called multiple times to register multiple callbacks

=item * Callbacks are invoked in registration order, with no arguments

=item * If registered after the request already completed, the callback is
invoked immediately

=item * If the request ended in an abnormal disconnect, the callback never fires

=item * One callback's failure does not prevent other callbacks from being
invoked

=back

=cut

sub on_complete {
    my ($self, $cb) = @_;

    # Still in flight: register for later.
    if (${$self->{_connected}}) {
        push @{$self->{_complete_callbacks}}, $cb;
        return;
    }

    # Terminal: only fire on clean completion, not on abnormal disconnect.
    return unless $self->{_completed};

    eval { $cb->() };
    warn "on_complete callback error: $@" if $@;
}

=head2 _mark_disconnected

    $conn->_mark_disconnected($reason);

B - Called by the server when disconnect is detected.

Updates the connection state and invokes all registered callbacks.
Applications should not call this method directly.

State transitions occur in this order:

=over 4

=item 1. C returns false

=item 2. C returns the reason string

=item 3. C resolves with the reason (if it was created)

=item 4. C callbacks are invoked in registration order

=back

=cut

sub _mark_disconnected {
    my ($self, $reason) = @_;

    # Already disconnected - no-op (idempotent)
    return unless ${$self->{_connected}};

    # 1. Update state
    ${$self->{_connected}} = 0;
    ${$self->{_reason}} = $reason // 'unknown';

    # 2. Resolve future if it exists (lazy - may not have been created)
    if ($self->{_future} && !$self->{_future}->is_ready) {
        $self->{_future}->done(${$self->{_reason}});
    }

    # 3. Invoke callbacks
    for my $cb (@{$self->{_callbacks}}) {
        eval { $cb->(${$self->{_reason}}) };
        warn "on_disconnect callback error: $@" if $@;
    }

    # 4. Clear callbacks to release references. The request ended abnormally,
    #    so on_complete callbacks never run.
    $self->{_callbacks}          = [];
    $self->{_complete_callbacks} = [];
}

=head2 _mark_complete

    $conn->_mark_complete;

B - Called by the server when the request completes
successfully (the response was fully delivered). Applications should not call
this method directly.

Transitions to the C terminal state and invokes C
callbacks in registration order. Unlike L, it leaves
C as C and does B resolve C
or fire C callbacks -- a clean completion is not a disconnect.

Idempotent, and a no-op once the connection has already reached a terminal
state (so a stray completion after an abnormal disconnect is ignored).

=cut

sub _mark_complete {
    my ($self) = @_;

    # Already terminal (disconnected or completed) - no-op (idempotent).
    return unless ${$self->{_connected}};

    # Mark the completed terminal state. Reason stays undef; the disconnect
    # Future is deliberately left pending (completion is not a disconnect).
    ${$self->{_connected}} = 0;
    $self->{_completed}    = 1;

    # Invoke completion callbacks (no reason argument).
    for my $cb (@{$self->{_complete_callbacks}}) {
        eval { $cb->() };
        warn "on_complete callback error: $@" if $@;
    }

    # Clear both lists to release references.
    $self->{_complete_callbacks} = [];
    $self->{_callbacks}          = [];
}

1;

__END__