File Coverage

blib/lib/Net/PMP/Client.pm

Criterion	Covered	Total	%
statement	39	290	13.4
branch	0	110	0.0
condition	0	61	0.0
subroutine	13	43	30.2
pod	18	18	100.0
total	70	522	13.4

package Net::PMP::Client;
use Moose;
with 'MooseX::SimpleConfig';
use Carp;
use Data::Dump qw( dump );
use LWP::UserAgent 6;    # SSL verification bug fixed in 6.03
use HTTP::Request;
use MIME::Base64;
use JSON;
use Net::PMP::AuthToken;
use Net::PMP::CollectionDoc;
use Net::PMP::Schema;
use Net::PMP::Credentials;
use URI;
use Try::Tiny;

our $VERSION = '0.006';

has '+configfile' =>
    ( default => $ENV{PMP_CLIENT_CONFIG} || ( $ENV{HOME} . '/.pmp.yaml' ) );
has 'host' => (
    is       => 'rw',
    isa      => 'Str',
    required => 1,
    default => sub { $ENV{PMP_CLIENT_HOST} || 'https://api-sandbox.pmp.io/' },
);
has 'id'     => ( is => 'rw', isa => 'Str',  required => 1, );
has 'secret' => ( is => 'rw', isa => 'Str',  required => 1, );
has 'debug'  => ( is => 'rw', isa => 'Bool', default  => 0, );
has 'ua' => ( is => 'rw', isa => 'LWP::UserAgent', builder => '_init_ua', );
has 'pmp_content_type' => (
    is      => 'rw',
    isa     => 'Str',
    default => sub {'application/vnd.collection.doc+json'},
);
has 'last_response' => ( is => 'rw', isa => 'HTTP::Response', );

# TODO add strict mode where schema validation is enforced client-side on save()
#has 'strict' => ( is => 'rw', isa => 'Bool', default => sub {0} );

# some constructor-time setup
sub BUILD {
    my $self = shift;
    $self->{host} =~ s/\/$//;    # no trailing slash
    $self->{_last_token_ts} = 0;
    $self->get_token();               # initiate connection
    $self->_set_home_doc_config();    # basic introspection
    return $self;
}

sub _init_ua {
    my $self = shift;
    my $ua   = LWP::UserAgent->new(
        agent    => 'net-pmp-perl-' . $VERSION,
        ssl_opts => { verify_hostname => 1 },
    );

# if Compress::Zlib is installed, this should handle gzip transparently.
# thanks to
# http://stackoverflow.com/questions/1285305/how-can-i-accept-gzip-compressed-content-using-lwpuseragent
    my $can_accept = HTTP::Message::decodable();
    $ua->default_header( 'Accept-Encoding' => $can_accept );

    if ( $self->debug ) {
        $ua->add_handler( "request_send",  sub { shift->dump; return } );
        $ua->add_handler( "response_done", sub { shift->dump; return } );
    }

    return $ua;
}

__PACKAGE__->meta->make_immutable;

=head1 NAME

Net::PMP::Client - Perl client for the Public Media Platform

=head1 SYNOPSIS

 use Net::PMP::Client;

 my $host = 'https://api-sandbox.pmp.io';
 my $client_id = 'i-am-a-client';
 my $client_secret = 'i-am-a-secret';

 # instantiate a client
 my $client = Net::PMP::Client->new(
     host   => $host,
     id     => $client_id,
     secret => $client_secret,
 );

 # authenticate
 my $token = $client->get_token();
 if ($token->expires_in() < 10) {
     die "Access token expires too soon. Not enough time to make a request. Mayday, mayday!";
 }
 printf("PMP token is: %s\n, $token->as_string());

 # search
 my $search_results = $client->search({ tag => 'samplecontent', profile => 'story' });
 my $results = $search_results->get_items();
 printf( "total: %s\n", $results->total );
 while ( my $r = $results->next ) {
     printf( '%s: %s [%s]', $results->count, $r->get_uri, $r->get_title, ) );
 }

=cut

=head1 DESCRIPTION

Net::PMP::Client is a Perl client for the Public Media Platform API (http://docs.pmp.io/).

=head1 METHODS

=head2 new( I<args> )

Instantiate a Client object. I<args> may consist of:

=over

=item host

Default is C<https://api-sandbox.pmp.io>.

=item id (required)

The client id. See L<https://github.com/publicmediaplatform/pmpdocs/wiki/Authenticating-with-the-API#generating-credentials>.

=item secret (required)

The client secret. See L<https://github.com/publicmediaplatform/pmpdocs/wiki/Authenticating-with-the-API#generating-credentials>.

=item debug

Boolean. Default is off.

=item ua

A LWP::UserAgent object.

=item pmp_content_type

Defaults to C<application/vnd.collection.doc+json>. Change at your peril.

=back

=head2 BUILD

Internal method for object construction.

=head2 last_response

Returns the most recent HTTP::Response object. Useful for debugging client behaviour.

=head2 get_home_doc

Returns the CollectionDoc for the API root. This object is cached for performance reasons.

=cut

sub get_home_doc {
    my $self = shift;
    return $self->{_home_doc};
}

=head2 get_token([I<refresh>],[I<warning_ttl>])

Returns a Net::PMP::AuthToken object. The optional I<refresh> boolean indicates
that the Client should ignore any cached token and fetch a fresh one.

If get_home_doc() is undefined (i.e., no initial access has been attempted),
then this method will return undef.

If the token will expire in less than I<warning_ttl> seconds, the client will sleep()
that long and then refresh itself. The default is 10 seconds.

=cut

sub get_token {
    my $self        = shift;
    my $refresh     = shift || 0;
    my $warning_ttl = shift || 10;

    # use cache?
    if (   !$refresh
        and $self->{_token}
        and $self->{_token}->expires_in() > $warning_ttl )
    {
        my $tok = $self->{_token};
        if ( $self->{_last_token_ts} ) {
            $tok->expires_in(
                $tok->expires_in - ( time() - $self->{_last_token_ts} ) );
        }
        $self->{_last_token_ts} = time();
        return $tok;
    }

    if ( $self->{_token} and $self->{_token}->expires_in() <= $warning_ttl ) {
        if ( $self->debug ) {
            warn sprintf(
                "Token will expire in %d seconds. Sleeping for that long...\n",
                $self->{_token}->expires_in() );
        }
        sleep( $self->{_token}->expires_in() + 1 );   # let server side expire
    }

    # fetch new token
    my $home_doc = $self->get_home_doc();

    # we have a chicken-and-egg situation on the first home doc request,
    # but the home doc doesn't require a token,
    # so just skip it if not defined.
    if ( !$home_doc ) {
        return;
    }
    my $auth_links = $home_doc->get_links('auth');
    my $uri
        = $auth_links->rels('urn:collectiondoc:form:issuetoken')->[0]->href;
    my $request = HTTP::Request->new( POST => $uri );
    my $hash = encode_base64( join( ':', $self->id, $self->secret ), '' );
    $request->header( 'Accept'       => 'application/json' );
    $request->header( 'Content-Type' => 'application/x-www-form-urlencoded' );
    $request->header( 'Authorization' => 'Basic ' . $hash );
    $request->content('grant_type=client_credentials');
    my $response = $self->ua->request($request);

    if ( $response->code != 200 ) {
        croak "Invalid response from authn server: " . $response->status_line;
    }

    $self->last_response($response);

    # unpack response
    my $token = try {
        decode_json( $response->decoded_content );
    }
    catch {
        croak "Invalid authn response: " . $response->decoded_content;
    };
    $self->{_token}         = Net::PMP::AuthToken->new($token);
    $self->{_last_token_ts} = time();
    return $self->{_token};
}

=head2 revoke_token

Expires the currently active AuthToken.

=cut

sub revoke_token {
    my $self       = shift;
    my $auth_links = $self->get_home_doc()->get_links('auth');
    my $uri
        = $auth_links->rels('urn:collectiondoc:form:revoketoken')->[0]->href;
    my $hash = encode_base64( join( ':', $self->id, $self->secret ), '' );
    my $request = HTTP::Request->new( DELETE => $uri );
    $request->header( 'Authorization' => 'Basic ' . $hash );
    my $response = $self->ua->request($request);

    if ( $response->code != 204 ) {
        croak "Invalid response from authn server: " . $response->status_line;
    }
    $self->{_token} = undef;
    return $self;
}

=head2 get_credentials_uri

Returns the URI for the Credentials API.

=cut

sub get_credentials_uri {
    my $self       = shift;
    my $auth_links = $self->get_home_doc()->get_links('auth');
    my $uri
        = $auth_links->rels('urn:collectiondoc:form:createcredentials')->[0]
        ->href;
    return URI->new($uri);
}

=head2 create_credentials( I<params>  )

Instantiates credentials at server. I<params> should be a hash of key/value pairs.

=over

=item username (required)

=item password (required)

=item scope (default: read)

=item expires (default: 86400)

=item label (default: null)

=back

Returns a Net::PMP::Credentials object.

=cut

sub create_credentials {
    my $self   = shift;
    my %params = @_;
    my $user   = delete $params{username} or croak "username required";
    my $pass   = delete $params{password} or croak "password required";

    # validate input
    my @valid_params = qw( scope expires label token_expires_in );
    my %post_params;
    for my $p (@valid_params) {
        if (    exists $params{$p}
            and defined $params{$p}
            and length $params{$p} )
        {
            $post_params{$p} = delete $params{$p};
        }
    }

    # special case
    if ( $post_params{expires} ) {
        $post_params{token_expires_in} = delete $post_params{expires};
    }
    $post_params{label} ||= 'null'; # Net::PMP::Credentials requires it be set

    my $uri = $self->get_credentials_uri();
    my $hash = encode_base64( join( ':', $user, $pass ), '' );
    if ( $self->debug ) {
        warn "POST with $user:$pass => $hash\n";
    }
    my $request = HTTP::Request->new( POST => $uri );
    $request->header( 'Authorization' => 'Basic ' . $hash );
    $request->header( 'Accept'        => 'application/json' );
    $request->header( 'Content-Type' => 'application/x-www-form-urlencoded' );

    # mimic what HTTP::Request::Common does for POST
    my $url = URI->new('http:');
    $url->query_form(%post_params);
    $request->content( $url->query );

    # send request
    my $response = $self->ua->request($request);
    if ( $response->code != 200 ) {
        croak "Invalid response from authn server: " . $response->status_line;
    }
    $self->last_response($response);

    # unpack response
    my $creds = try {
        decode_json( $response->decoded_content );
    }
    catch {
        croak "Invalid authn response: " . $response->decoded_content;
    };
    return Net::PMP::Credentials->new($creds);
}

=head2 delete_credentials( I<params> )

Deletes credentials at the server.

I<params> should consist of:

=over

=item username

=item password

=item client_id

=back

=cut

sub delete_credentials {
    my $self      = shift;
    my %params    = @_;
    my $user      = $params{username} or croak "username required";
    my $pass      = $params{password} or croak "password required";
    my $client_id = $params{client_id} or croak "client_id required";

    my $uri     = $self->get_credentials_uri() . '/' . $client_id;
    my $hash    = encode_base64( join( ':', $user, $pass ), '' );
    my $request = HTTP::Request->new( DELETE => $uri );
    $request->header( 'Authorization' => 'Basic ' . $hash );
    $request->header( 'Accept'        => 'application/json' );
    $request->header( 'Content-Type'  => $self->pmp_content_type );

    # send request
    my $response = $self->ua->request($request);
    if ( $response->code != 204 ) {
        croak "Invalid response from authn server: " . $response->status_line;
    }
    $self->last_response($response);

    return $response;
}

=head2 uri_for_doc(I<guid>)

Returns full URI for I<guid>.

=cut

sub uri_for_doc {
    my $self = shift;
    my $guid = shift or croak "guid required";
    return $self->{_home_doc}->query('urn:collectiondoc:hreftpl:docs')
        ->as_uri( { guid => $guid } );
}

=head2 uri_for_profile(I<profile>)

Returns full URI for I<profile>.

=cut

sub uri_for_profile {
    my $self = shift;
    my $profile = shift or croak "profile required";
    return sprintf( "%s/profiles/%s", $self->host, $profile );
}

=head2 uri_for_schema(I<schema>)

Returns full URI for I<schema>.

=cut

sub uri_for_schema {
    my $self = shift;
    my $schema = shift or croak "schema required";
    return sprintf( "%s/schemas/%s", $self->host, $schema );
}

=head2 get(I<uri>)

Issues a GET request on I<uri> and decodes the JSON response into a Perl
scalar.

If the GET request returns a 404 (Not Found) will return 0 (zero).

If the GET request returns anything other than 200, will croak.

If the GET request returns 200, will return the JSON response, decoded.

=cut

sub get {
    my $self    = shift;
    my $uri     = shift or croak "uri required";
    my $request = HTTP::Request->new( GET => $uri );
    $request->header(
        'Accept' => 'application/json; ' . $self->pmp_content_type, );

    # the initial GET of home doc does not require a token.
    my $token = $self->get_token();
    if ($token) {
        $request->header( 'Authorization' =>
                sprintf( '%s %s', $token->token_type, $token->access_token )
        );
    }
    my $response = $self->ua->request($request);

    # retry if 401
    if ( $response->code == 401 ) {

        # occasional persistent 401 errors?
        sleep(1);
        $token = $self->get_token(1);
        $request->header( 'Authorization' =>
                sprintf( '%s %s', $token->token_type, $token->access_token )
        );

        #sleep(1);
        $response = $self->ua->request($request);
        $self->debug and warn "retry GET $uri\n" . dump($response);
    }

    $self->last_response($response);

    if ( $response->code == 404 ) {
        return 0;
    }

    if ( $response->code != 200 or !$response->decoded_content ) {
        croak "Unexpected response for GET $uri: " . $response->status_line;
    }

    my $json = try {
        decode_json( $response->decoded_content );
    }
    catch {
        croak "Invalid JSON in response: $@ : " . $response->decoded_content;
    };
    return $json;
}

sub _set_home_doc_config {
    my $self = shift;
    $self->{_home_doc} ||= $self->get_doc();
    if ( !$self->{_home_doc} ) {
        confess "Failed to GET home doc from " . $self->host;
    }
    my $edit_links = $self->{_home_doc}->get_links('edit');
    $self->{_doc_edit_link}
        = $edit_links->rels("urn:collectiondoc:form:documentsave")->[0];
}

=head2 get_doc_edit_link

Retrieves the base doc edit link object for the API.

=cut

sub get_doc_edit_link {
    my $self = shift;
    return $self->{_doc_edit_link} if $self->{_doc_edit_link};
    $self->_set_home_doc_config();
    return $self->{_doc_edit_link};
}

=head2 put(I<doc_object>)

Write I<doc_object> to the server. I<doc_object> should be an instance
of L<Net::PMP::CollectionDoc>.

Returns the JSON response from the server on success, croaks on failure.

Normally you should use save() instead of put() directly, since save()
optionally validates the I<doc_object> before calling put() and makes
sure there is a B<guid> and B<href> defined.

=cut

sub put {
    my $self = shift;
    my $doc = shift or croak "doc required";
    if ( !blessed $doc or !$doc->isa('Net::PMP::CollectionDoc') ) {
        croak "doc must be a Net::PMP::CollectionDoc object";
    }
    my $uri     = $doc->get_publish_uri( $self->get_doc_edit_link );
    my $request = HTTP::Request->new( PUT => $uri );
    my $token   = $self->get_token();
    my $body    = $doc->as_json();
    if ( $self->debug ) {
        warn "PUT $uri\n" . dump( $doc->as_hash() ) . "\n";
        warn "JSON: $body\n";
    }
    $request->header( 'Accept'       => 'application/json' );
    $request->header( 'Content-Type' => $self->pmp_content_type );
    $request->header( 'Authorization' =>
            sprintf( '%s %s', $token->token_type, $token->access_token ) );
    $request->content($body);
    my $response = $self->ua->request($request);

    # retry if 401
    if ( $response->code == 401 ) {

        # occasional persistent 401 errors?
        sleep(1);
        $token = $self->get_token(1);
        $request->header( 'Authorization' =>
                sprintf( '%s %s', $token->token_type, $token->access_token )
        );

        #sleep(1);
        $response = $self->ua->request($request);
        $self->debug and warn "retry PUT $uri\n" . dump($response);
    }

    $self->last_response($response);

    if ( $response->code !~ m/^20[02]$/ or !$response->decoded_content ) {
        croak sprintf( "Unexpected response for PUT %s: %s\n%s\n",
            $uri, $response->status_line, $response->content );
    }

    my $json = try {
        decode_json( $response->decoded_content );
    }
    catch {
        croak "Invalid JSON in response: $_ : " . $response->decoded_content;
    };
    return $json;
}

=head2 delete(I<doc_object>)

Remove I<doc_object> from the server. Returns true on success, croaks on failure.

=cut

sub delete {
    my $self = shift;
    my $doc = shift or croak "doc required";
    if ( !blessed $doc or !$doc->isa('Net::PMP::CollectionDoc') ) {
        croak "doc must be a Net::PMP::CollectionDoc object";
    }
    my $uri     = $doc->get_publish_uri( $self->get_doc_edit_link );
    my $request = HTTP::Request->new( DELETE => $uri );
    my $token   = $self->get_token();
    $request->header( 'Accept'       => 'application/json' );
    $request->header( 'Content-Type' => $self->pmp_content_type );
    $request->header( 'Authorization' =>
            sprintf( '%s %s', $token->token_type, $token->access_token ) );
    my $response = $self->ua->request($request);

    # retry if 401
    if ( $response->code == 401 ) {

        # occasional persistent 401 errors?
        sleep(1);
        $token = $self->get_token(1);
        $request->header( 'Authorization' =>
                sprintf( '%s %s', $token->token_type, $token->access_token )
        );

        $response = $self->ua->request($request);
        $self->debug and warn "retry DELETE $uri\n" . dump($response);
    }

    $self->last_response($response);

    if ( $response->code != 204 ) {
        croak sprintf( "Unexpected response for DELETE %s: %s\n%s\n",
            $uri, $response->status_line, $response->content );
    }
    return 1;
}

=head2 get_doc( [I<uri>] [,I<tries>] )

Returns a Net::PMP::CollectionDoc representing I<uri>. Defaults
to the API base endpoint if I<uri> is omitted or false.

If I<uri> is not found, returns 0 (zero) just like get().

The second, optional parameter I<tries> indicates how many re-tries should
be attempted when the response is a 404. This feature helps compenstate
for occasional latency on the server between an initial save and subsequent
read, since PUT and DELETE requests always return a 202 (accepted but not
necessarily acted upon). The default is 1 try.

=cut

sub get_doc {
    my $self  = shift;
    my $uri   = shift || $self->host;
    my $tries = shift || 1;

    # optimize a little for the root doc
    if ( $uri eq $self->host and $self->{_home_doc} ) {
        return $self->{_home_doc};
    }

    my $response;
    my $attempts = 0;
    while ( !$response and $attempts++ < $tries ) {
        $response = $self->get($uri);
        $self->debug and warn dump $response;
        if ( !$response and $attempts < $tries ) {
            $self->debug
                and warn "search returned 404 - sleeping and trying again\n";
            sleep(1);
        }
    }

    return $response unless $response;    # 404

    # convert JSON response into a CollectionDoc
    # check content type to determine object
    if ( $self->last_response->content_type eq 'application/schema+json' ) {
        return Net::PMP::Schema->new($response);
    }

    my $doc = Net::PMP::CollectionDoc->new($response);

    return $doc;
}

=head2 get_doc_by_guid(I<guid>)

Like get_doc() but takes a I<guid> as argument.

=cut

sub get_doc_by_guid {
    my $self = shift;
    my $guid = shift or croak "guid required";
    return $self->get_doc( $self->uri_for_doc($guid) );
}

=head2 search( I<opts> [,I<tries>] )

Search in the 'urn:collectiondoc:query:docs' namespace.

Returns a Net::PMP::CollectionDoc object for I<opts>.
I<opts> are passed directly to the query link URI template.
See L<https://github.com/publicmediaplatform/pmpdocs/wiki/Query-Link-Relation>.

The second, optional parameter I<tries> is passed internally to get_doc().
See the description of get_doc().

=cut

sub search {
    my $self  = shift;
    my $opts  = shift or croak "options required";
    my $tries = shift || 1;
    my $uri   = $self->{_home_doc}->query('urn:collectiondoc:query:docs')
        ->as_uri($opts);

    # debugging option
    if ( $ENV{PMP_CLIENT_DEBUG} and $ENV{PMP_APPEND_RANDOM_STRING} ) {
        my $rand_guid = Net::PMP::CollectionDoc->create_guid();
        $uri .= '&random=' . $rand_guid;
    }

    return $self->get_doc( $uri, $tries );
}

=head2 save(I<doc_object>)

Write I<doc_object> to the server. I<doc_object> may be a L<Net::PMP::Profile> object,
in which case the as_doc() method is called on it, or it may be a L<Net::PMP::CollectionDoc> object.

Returns a L<Net::PMP::CollectionDoc> object with its URI updated to reflect the server response.

=cut

sub save {
    my $self = shift;
    my $doc = shift or croak "doc object required";
    if ( blessed $doc and $doc->isa('Net::PMP::Profile') ) {
        $doc = $doc->as_doc();
    }
    if ( !blessed $doc or !$doc->isa('Net::PMP::CollectionDoc') ) {
        croak "doc must be a Net::PMP::CollectionDoc object";
    }

    # if $doc has no guid (necessary for PUT) create one
    if ( !$doc->get_guid ) {
        $doc->set_guid();
    }

    # similar for href
    if ( !$doc->href ) {
        $doc->href( $self->uri_for_doc( $doc->get_guid ) );
    }

    my $saved = $self->put($doc);
    $self->debug and warn dump $saved;

    $doc->set_uri( $saved->{url} );

    return $doc;
}

1;

__END__

=head1 AUTHOR

Peter Karman, C<< <karman at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-net-pmp at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-PMP>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Net::PMP::Client


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-PMP>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Net-PMP>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Net-PMP>

=item * Search CPAN

L<http://search.cpan.org/dist/Net-PMP/>

=back


=head1 ACKNOWLEDGEMENTS

American Public Media and the Public Media Platform sponsored the development of this module.

=head1 LICENSE AND COPYRIGHT

Copyright 2013 American Public Media Group

See the LICENSE file that accompanies this module.

=cut