view release on metacpan or  search on metacpan

lib/Developer/Dashboard/Web/DancerApp.pm  view on Meta::CPAN

# Returns the configured backend service object and default headers.
# Input: none.
# Output: hash reference with app object and default headers.
sub _current_backend {
    return $BACKEND_APP || die 'Missing backend web app';
}

# _request_headers()
# Normalizes the subset of inbound headers the backend service expects.
# Input: none.
# Output: hash reference with host and cookie values.
sub _request_headers {
    return {
        host   => scalar( request->header('Host') // '' ),
        cookie => scalar( request->header('Cookie') // '' ),
    };
}

# _request_args()
# Normalizes the active Dancer2 request into the backend service request shape.
# Input: none.
# Output: hash reference with path, query, method, body, headers, and remote address.
sub _request_args {
    my $host = scalar( request->header('Host') // '' );
    if ( $host eq '' ) {
        my $server_name = scalar( request->env->{SERVER_NAME} // '' );
        my $server_port = scalar( request->env->{SERVER_PORT} // '' );
        $host = $server_name;
        $host .= ':' . $server_port if $host ne '' && $server_port ne '';
    }
    my $remote_addr = scalar( request->env->{REMOTE_ADDR} // request->env->{SERVER_ADDR} // '' );
    $remote_addr = scalar( request->env->{SERVER_NAME} // '' ) if $remote_addr eq '';
    return {
        path        => scalar( request->env->{PATH_INFO} // '/' ),
        query       => scalar( request->env->{QUERY_STRING} // '' ),
        method      => scalar( request->env->{REQUEST_METHOD} // 'GET' ),
        body        => scalar( request->body // '' ),
        remote_addr => $remote_addr,
        headers     => {
            %{ _request_headers() },
            host => $host,
        },
    };
}

# _capture($index)
# Returns one regex-route capture from the current Dancer2 request.
# Input: zero-based capture index.
# Output: captured path string or undef.
sub _capture {
    my ($index) = @_;
    my @parts = splat;
    @parts = @{ $parts[0] } if @parts == 1 && ref( $parts[0] ) eq 'ARRAY';
    return undef if !@parts;
    return $parts[$index];
}

# _response_from_result($result)
# Applies one backend response onto the active Dancer2 response object.
# Input: backend response array reference.
# Output: plain body or delayed streaming response suitable for Dancer2.
sub _response_from_result {
    my ($result) = @_;
    my ( $code, $type, $body, $headers ) = @{$result};
    my $backend = _current_backend();
    my %merged_headers = (
        %{ $backend->{default_headers} || {} },
        %{ $headers || {} },
    );

    if ( ref($body) eq 'HASH' && ref( $body->{stream} ) eq 'CODE' ) {
        my $stream = $body->{stream};
        return delayed {
            my @headers = ( 'Content-Type' => $type );
            push @headers, map { $_ => $merged_headers{$_} } sort keys %merged_headers;
            my $responder = $Dancer2::Core::Route::RESPONDER
              or die "Missing delayed response writer\n";
            my $psgi_writer = $responder->([ $code, \@headers ]);
            my $writer = sub {
                my ($chunk) = @_;
                return 1 if !defined $chunk || $chunk eq '';
                my $ok = eval {
                    $psgi_writer->write($chunk);
                    1;
                };
                return 0 if !$ok && _looks_like_disconnect_error($@);
                die $@ if !$ok;
                return 1;
            };

            eval {
                $stream->($writer);
                1;
            } or do {
                my $error = $@ || "Streaming response failed\n";
                $writer->($error);
            };

            eval { $psgi_writer->close };
        };
    }

    status $code;
    content_type $type;
    for my $name ( sort keys %merged_headers ) {
        response_header $name => $merged_headers{$name};
    }

    return $body;
}

# _looks_like_disconnect_error($error)
# Detects writer/content failures that mean the HTTP client has already closed the stream.
# Input: raw exception text from Dancer content writes.
# Output: boolean true when the error matches a broken client connection.
sub _looks_like_disconnect_error {
    my ($error) = @_;
    return 0 if !defined $error || $error eq '';
    return $error =~ /(broken pipe|client disconnected|connection reset|stream closed|connection aborted|write failed)/i ? 1 : 0;
}