view release on metacpan or  search on metacpan

lib/Clustericious/Client.pm  view on Meta::CPAN

package Clustericious::Client;

use strict;
use warnings;
use 5.010;
use Mojo::Base qw/-base/;
use Mojo::UserAgent;
use Mojo::ByteStream qw/b/;
use Mojo::Parameters;
use Clustericious;
use Clustericious::Config;
use Clustericious::Client::Object;
use Clustericious::Client::Meta;
use Clustericious::Client::Meta::Route;
use MojoX::Log::Log4perl;
use Log::Log4perl qw/:easy/;
use File::Temp;
use JSON::MaybeXS qw( encode_json decode_json );
use Carp qw( carp );
use Mojo::Util qw( monkey_patch );

# ABSTRACT: Construct command line and perl clients for RESTful services.
our $VERSION = '1.29'; # VERSION


has server_url => '';
has [qw(tx res userinfo ua )];
has _remote => ''; # Access via remote()
has _cache => sub { + {} }; # cache of credentials

sub client
{
  carp "Clustericious::Client->client is deprecated (use ua instead)";
  shift->ua(@_);
}

sub import
{
  my($class) = @_;
  my $caller = caller;

  monkey_patch $caller, route => \&route;
  monkey_patch $caller, route_meta => \&route_meta;
  monkey_patch $caller, route_args => \&route_args;
  monkey_patch $caller, route_doc => sub {
    Clustericious::Client::Meta->add_route( $caller, @_ );
  };
  monkey_patch $caller, object => \&object;
  monkey_patch $caller, import => sub {};

  do {
    no strict 'refs';
    push @{"${caller}::ISA"}, $class unless $caller->isa($class);
  };
}


sub _mojo_user_agent_factory
{
  my($class, $new) = @_;
  state $factory = sub { Mojo::UserAgent->new };
  $factory = $new if $new;
  defined wantarray ? $factory->() : ();
}

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

  my $config = delete $args{config};
  
  my $self = $class->SUPER::new(%args);

  $self->{_base_config} = $config if $config;

  if($self->{app})
  {
    my $app = $self->{app};
    $app = $app->new() unless ref($app);
    my $ua = $self->_mojo_user_agent_factory();
    return undef unless $ua;
    eval { $ua->server->app($app) } // $ua->app($app);
    $self->ua($ua);
  }
  else
  {
    $self->ua($self->_mojo_user_agent_factory());
    unless(length $self->server_url)
    {

lib/Clustericious/Client.pm  view on Meta::CPAN

            }
        }
    }

    while (defined(my $arg = shift @args)) {
        if (ref $arg eq 'HASH') {
            $method = 'POST';
            $parameters->append(skip_existing => 1) if $meta && $meta->get("skip_existing");
            $body = encode_json $arg;
            $headers = { 'Content-Type' => 'application/json' };
        } elsif (ref $arg eq 'CODE') {
            $cb = $self->_mycallback($arg);
        } elsif (my $code = $url_modifier{$arg}) {
            $url = $code->($url, shift @args);
        } elsif (my $code2 = $payload_modifer{$arg}) {
            $body = $code2->($body, shift @args);
        } elsif ($method eq "GET" && $arg =~ s/^--//) {
            my $value = shift @args;
            $parameters->append($arg => $value);
        } elsif ($method eq "GET" && $arg =~ s/^-//) {
            # example: $client->esdt(-range => [1 => 100]);
            my $value = shift @args;
            if (ref $value eq 'ARRAY') {
                $value = "items=$value->[0]-$value->[1]";
            }
            $headers->{$arg} = $value;
        } elsif ($method eq "POST" && !ref $arg) {
            $body = $arg;
            $headers = shift @args if $args[0] && ref $args[0] eq 'HASH';
        } else {
            push @{ $url->path->parts }, $arg;
        }
    }
    $url = $url->to_abs unless $url->is_abs || $self->{app};
    WARN "url $url is not absolute" unless $url =~ /^http/i;

    $url->userinfo($self->userinfo) if $self->userinfo;

    DEBUG ( (ref $self)." : $method " ._sanitize_url($url));
    $headers->{Connection} ||= 'Close';
    $headers->{Accept}     ||= 'application/json';

    if($body && ref $body eq 'HASH' || ref $body eq 'ARRAY')
    {
        $headers->{'Content-Type'} = 'application/json';
        $body = encode_json $body;
    }

    return $self->ua->build_tx($method, $url, $headers, $body, $cb) if $cb;

    my $tx = $self->ua->build_tx($method, $url, $headers, $body);

    $tx = $self->ua->start($tx);
    my $res = $tx->res;
    $self->res($res);
    $self->tx($tx);

    my $auth_header;
    if (($tx->res->code||0) == 401 && ($auth_header = $tx->res->headers->www_authenticate)
        && !$url->userinfo && ($self->_has_auth || $self->_can_auth)) {
        DEBUG "received code 401, trying again with credentials";
        my ($realm) = $auth_header =~ /realm=(.*)$/i;
        my $host = $url->host;
        $self->login( $self->_has_auth ? () : $self->_get_user_pw($host,$realm) );
        return $self->_doit($meta ? $meta : (), @_);
    }

    if ($res->is_success) {
        TRACE "Got response : ".$res->to_string;
        my $content_type = $res->headers->content_type || do {
            WARN "No content-type from "._sanitize_url($url);
            "text/plain";
        };
        return $method =~ /HEAD|DELETE/       ? 1
            : $content_type =~ qr[application/json] ? decode_json($res->body)
            : $res->body;
    }

    # Failed.
    my $err = $tx->error;
    my ($msg, $code) = ($err->{message}, $err->{code});
    $msg ||= 'unknown error';
    my $s_url = _sanitize_url($url);

    if ($code) {
        if ($code == 404) {
            TRACE "$method $url : $code $msg"
                 unless $ENV{ACPS_SUPPRESS_404}
                     && $url =~ /$ENV{ACPS_SUPPRESS_404}/;
        } else {
            ERROR "Error trying to $method $s_url : $code $msg";
            TRACE "Full error body : ".$res->body if $res->body;
            my $brief = $res->body || '';
            $brief =~ s/\n/ /g;
            ERROR substr($brief,0,200) if $brief;
        }
        # No failover for legitimate status codes.
        return undef;
    }

    unless ($auto_failover) {
        ERROR "Error trying to $method $s_url : $msg";
        ERROR $res->body if $res->body;
        return undef;
    }
    my $failover_urls = $self->config->failover_urls(default => []);
    unless (@$failover_urls) {
        ERROR $msg;
        return undef;
    }
    INFO "$msg but will try up to ".@$failover_urls." failover urls";
    TRACE "Failover urls : @$failover_urls";
    for my $url (@$failover_urls) {
        DEBUG "Trying $url";
        $self->server_url($url);
        my $got = $self->_doit(@_);
        return $got if $got;
    }

    return undef;
}