view release on metacpan or  search on metacpan

lib/Metabase/Client/Simple.pm  view on Meta::CPAN

use 5.006;
use strict;
use warnings;

package Metabase::Client::Simple;
# ABSTRACT: a client that submits to Metabase servers

our $VERSION = '0.012';

use JSON::MaybeXS;
use HTTP::Tiny 0.056; # can_ssl
use URI;

my @valid_args;

BEGIN {
    @valid_args = qw(profile secret uri);

    for my $arg (@valid_args) {
        no strict 'refs';
        *$arg = sub { $_[0]->{$arg}; }
    }
}

#pod =method new
#pod
#pod   my $client = Metabase::Client::Simple->new(\%arg)
#pod
#pod This is the object constructor.
#pod
#pod Valid arguments are:
#pod
#pod   profile - a Metabase::User::Profile object
#pod   secret  - a Metabase::User::Secret object
#pod   uri     - the root URI for the metabase server
#pod
#pod If you use a C<uri> argument with the 'https' scheme, you must have
#pod L<IO::Socket::SSL> and L<Net::SSLeay> installed.  You may also
#pod require L<Mozilla::CA>.
#pod
#pod =cut

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

    my $args = $class->__validate_args( \@args, { map { $_ => 1 } @valid_args } );

    # uri must have a trailing slash
    $args->{uri} .= "/" unless substr( $args->{uri}, -1 ) eq '/';

    my $self = bless $args => $class;

    unless ( $self->profile->isa('Metabase::User::Profile') ) {
        Carp::confess("'profile' argument for $class must be a Metabase::User::Profile");
    }
    unless ( $self->secret->isa('Metabase::User::Secret') ) {
        Carp::confess("'profile' argument for $class must be a Metabase::User::secret");
    }

    my $scheme = URI->new( $self->uri )->scheme;
    my ( $can_ssl, $reason ) = HTTP::Tiny::can_ssl();
    unless ( $scheme eq 'http' || ( $scheme eq 'https' && $can_ssl ) ) {
        my $msg = "Scheme '$scheme' is not supported.\n";
        if ( $scheme eq 'https' ) {
            $msg .= $reason;
        }
        die $msg;
    }

    return $self;
}

sub _ua {
    my ($self) = @_;
    if ( !$self->{_ua} ) {
        $self->{_ua} =
          HTTP::Tiny->new( agent => __PACKAGE__ . "/" . __PACKAGE__->VERSION . " ", );
    }
    return $self->{_ua};
}

#pod =method submit_fact
#pod
#pod   $client->submit_fact($fact);
#pod
#pod This method will submit a L<Metabase::Fact|Metabase::Fact> object to the
#pod client's server.  On success, it will return a true value.  On failure, it will
#pod raise an exception.
#pod
#pod =cut

sub submit_fact {
    my ( $self, $fact ) = @_;

    my $path = sprintf 'submit/%s', $fact->type;

    $fact->set_creator( $self->profile->resource )
      unless $fact->creator;

    my $req_uri = $self->_abs_uri($path);

    my $auth = $self->_ua->_uri_escape(
        join( ":", $self->profile->resource->guid, $self->secret->content ) );

    $req_uri->userinfo($auth);

    my @req = (
        $req_uri,
        {
            headers => {
                Content_Type => 'application/json',