File Coverage

blib/lib/GraphQL/Client/http.pm

Criterion	Covered	Total	%
statement	82	85	96.4
branch	22	26	84.6
condition	18	30	60.0
subroutine	18	18	100.0
pod	7	7	100.0
total	147	166	88.5

package GraphQL::Client::http;
# ABSTRACT: GraphQL over HTTP

use 5.010;
use warnings;
use strict;

use HTTP::AnyUA::Util qw(www_form_urlencode);
use HTTP::AnyUA;
use namespace::clean;

our $VERSION = '0.604'; # VERSION

sub _croak { require Carp; goto &Carp::croak }

sub new {
    my $class = shift;
    my $self  = @_ % 2 == 0 ? {@_} : $_[0];
    bless $self, $class;
}

sub execute {
    my $self = shift;
    my ($request, $options) = @_;

    my $url     = delete $options->{url}    || $self->url;
    my $method  = delete $options->{method} || $self->method;

    $request && ref($request) eq 'HASH' or _croak q{Usage: $http->execute(\%request)};
    $request->{query} or _croak q{Request must have a query};
    $url or _croak q{URL must be provided};

    my $data = {%$request};

    if ($method eq 'GET' || $method eq 'HEAD') {
        $data->{variables} = $self->json->encode($data->{variables}) if $data->{variables};
        my $params  = www_form_urlencode($data);
        my $sep     = $url =~ /^[^#]+\?/ ? '&' : '?';
        $url =~ s/#/${sep}${params}#/ or $url .= "${sep}${params}";
    }
    else {
        my $encoded_data = $self->json->encode($data);
        $options->{content} = $encoded_data;
        $options->{headers}{'content-length'} = length $encoded_data;
        $options->{headers}{'content-type'}   = 'application/json;charset=UTF-8';
    }

    return $self->_handle_response($self->any_ua->request($method, $url, $options));
}

sub _handle_response {
    my $self = shift;
    my ($resp) = @_;

    if (eval { $resp->isa('Future') }) {
        return $resp->followed_by(sub {
            my $f = shift;

            if (my ($exception, $category, @other) = $f->failure) {
                if (ref $exception eq 'HASH') {
                    my $resp = $exception;
                    return Future->done($self->_handle_error($resp));
                }

                return Future->done({
                    error       => $exception,
                    response    => undef,
                    details     => {
                        exception_details => [$category, @other],
                    },
                });
            }

            my $resp = $f->get;
            return Future->done($self->_handle_success($resp));
        });
    }
    else {
        return $self->_handle_error($resp) if !$resp->{success};
        return $self->_handle_success($resp);
    }
}

sub _handle_error {
    my $self = shift;
    my ($resp) = @_;

    my $data    = eval { $self->json->decode($resp->{content}) };
    my $content = $resp->{content} // 'No content';
    my $reason  = $resp->{reason}  // '';
    my $message = "HTTP transport returned $resp->{status} ($reason): $content";

    chomp $message;

    return {
        error       => $message,
        response    => $data,
        details     => {
            http_response   => $resp,
        },
    };
}

sub _handle_success {
    my $self = shift;
    my ($resp) = @_;

    my $data = eval { $self->json->decode($resp->{content}) };
    if (my $exception = $@) {
        return {
            error       => "HTTP transport failed to decode response: $exception",
            response    => undef,
            details     => {
                http_response   => $resp,
            },
        };
    }

    return {
        response    => $data,
        details     => {
            http_response   => $resp,
        },
    };
}

sub ua {
    my $self = shift;
    $self->{ua} //= do {
        require HTTP::Tiny;
        HTTP::Tiny->new(
            agent => $ENV{GRAPHQL_CLIENT_HTTP_USER_AGENT} // "perl-graphql-client/$VERSION",
        );
    };
}

sub any_ua {
    my $self = shift;
    $self->{any_ua} //= HTTP::AnyUA->new(ua => $self->ua);
}

sub url {
    my $self = shift;
    $self->{url};
}

sub method {
    my $self = shift;
    $self->{method} // 'POST';
}

sub json {
    my $self = shift;
    $self->{json} //= do {
        require JSON::MaybeXS;
        JSON::MaybeXS->new(utf8 => 1);
    };
}

1;

__END__