File Coverage

blib/lib/WebService/ILS/RecordedBooks.pm

Criterion	Covered	Total	%
statement	27	296	9.1
branch	0	148	0.0
condition	0	25	0.0
subroutine	9	48	18.7
pod	19	30	63.3
total	55	547	10.0

package WebService::ILS::RecordedBooks;

use Modern::Perl;

=encoding utf-8

=head1 NAME

WebService::ILS::RecordedBooks - WebService::ILS module for RecordedBooks services

=head1 SYNOPSIS

    use WebService::ILS::RecordedBooks::Partner;
    or
    use WebService::ILS::RecordedBooks::Patron;

=head1 DESCRIPTION

L - services
that use partner credentials, for any patron

L - same as above,
except it operates on a single patron account

L - services
that use individual patron credentials, in addition to partner credentials

L is preferred over
L because the later requires patron
credentials - username and password. However, if you do not know patron's
email or RecordedBooks id (barcode) you are stuck with Patron interface.

See L

=cut

use Carp;
use HTTP::Request::Common;
use URI::Escape;
use JSON qw(to_json);

use parent qw(WebService::ILS::JSON);

use constant API_VERSION => "v1";
use constant BASE_DOMAIN => "rbdigital.com";

=head1 CONSTRUCTOR

=head2 new (%params_hash or $params_hashref)

=head3 Additional constructor params:

=over 12

=item C            => if set to true use https

=item C         => RecordedBooks domain for title url

=back

C is either RecordedBooks id (barcode) or email

C if set is either "whatever.rbdigital.com" or "whatever",
in which case rbdigital.com is appended.

=cut

use Class::Tiny qw(
    ssl
    domain
    _api_base_url
);

__PACKAGE__->_set_param_spec({
    client_id  => { required => 0 },
    library_id => { required => 1 },
    domain     => { required => 0 },
    ssl        => { required => 0, default => 1 },
});

sub BUILD {
    my $self = shift;
    my $params = shift;

    if (my $domain = $self->domain) {
        $self->domain("$domain.".BASE_DOMAIN) unless $domain =~ m/\./;
    }

    my $ssl = $self->ssl;
    my $ua = $self->user_agent;
    $ua->ssl_opts( verify_hostname => 0 ) if $ssl;

    my $api_url = sprintf "%s://api.%s", $ssl ? "https" : "http", BASE_DOMAIN;
    $self->_api_base_url($api_url);
}

sub api_url {
    my $self = shift;
    my $action = shift or croak "No action";

    return sprintf "%s/%s%s", $self->_api_base_url, API_VERSION, $action;
}

sub library_action_base_url {
    my $self = shift;

    return $self->api_url("/libraries/".$self->library_id);
}

sub products_url {
    my $self = shift;
    return $self->library_action_base_url."/search";
}

sub circulation_action_url {
    my $self = shift;
    my $action = shift or croak "No action";

    return $self->circulation_action_base_url(@_).$action;
}

sub _access_auth_string {
    my $self = shift;
    return $self->client_secret;
}

sub native_countries {
    my $self = shift;

    my $url = $self->api_url("/countries");
    return $self->get_without_auth($url);
}

sub native_facets {
    my $self = shift;

    my $url = $self->api_url("/facets");
    return $self->get_response($url);
}


sub native_facet_values {
    my $self = shift;
    my $facet = shift or croak "No facet";

    my $url = $self->api_url("/facets/$facet");
    return $self->get_without_auth($url);
}

sub native_libraries_search {
    my $self = shift;
    my $query = shift or croak "No query";
    my $region = shift;

    my %search_params = ( term => $query );
    $search_params{ar} = $region if $region;
    my $url = $self->api_url("/suggestive/libraries");
    return $self->get_without_auth($url, \%search_params);
}

sub get_without_auth {
    my $self = shift;
    my $url = shift or croak "No url";
    my $get_params = shift; # hash ref

    my $uri = URI->new($url);
    $uri->query_form($get_params) if $get_params;
    my $request = HTTP::Request::Common::GET( $uri );
    my $response = $self->user_agent->request( $request );
    $self->check_response($response);

    return $self->process_json_response($response, sub {
        my ($data) = @_;
        die "No data\n" unless $data;
        return $data;
    });
}

=head1 DISCOVERY METHODS

=head2 facets ()

=head3 Returns a hashref of facet => [values]

=cut

sub facets {
    my $self = shift;

    my $facets = $self->native_facets;
    my %facet_values;
    foreach (@$facets) {
        my $f = $_->{facetToken};
        $facet_values{$f} = [map $_->{valueToken}, @{ $self->native_facet_values($f) }];
    }
    return \%facet_values;
}

=head2 search ($params_hashref)

=head3 Additional input params:

=over 12

=item C => a hashref of facet values

=back

=cut

my %SORT_XLATE = (
    rating => undef,
    publication_date => undef, # not available
);
sub search {
    my $self = shift;
    my $params = shift || {};

    my $url = $self->products_url;

    if (my $query = delete $params->{query}) {
        $query = join " ", @$query if ref $query;
        $params->{all} = $query;
    }
    if (my $page_size = delete $params->{page_size}) {
        $params->{'page-size'} = $page_size;
    }
    if (my $page_number = delete $params->{page}) {
        die "page_size must be specified for paging" unless $params->{'page-size'};
        $params->{'page-index'} = $page_number - 1;
    }
    if (my $sort = delete $params->{sort}) {
        my $sa = $self->_parse_sort_string($sort, \%SORT_XLATE);
        if (@$sa) {
            my @params = %$params;
            foreach (@$sa) {
                my ($s, $d) = split ':';
                push @params, "sort-by", $s;
                push @params, "sort-order", $d if $d;
            }
            return $self->_search_result_xlate( $self->get_response($url, \@params) );
        }
    }

    return $self->_search_result_xlate( $self->get_response($url, $params) );
}

sub _search_result_xlate {
    my $self = shift;
    my $res = shift or return;

    my $domain = $self->domain;
    return {
        items => [ map {
            my $i = $self->_item_xlate($_->{item});
            $i->{url} ||= "https://$domain/#titles/$i->{isbn}" if $domain;
            $i->{available} = $_->{interest}{isAvailable};
            $i;
        } @{$res->{items} || []} ],
        page_size => $res->{pageSize},
        page => $res->{pageIndex} + 1,
        pages => $res->{pageCount},
    };
}

my %SEARCH_RESULT_ITEM_XLATE = (
    id => "id",
    title => "title",
    subtitle => "subtitle",
    shortDescription => "description",
    mediaType => "media",
    downloadUrl => "url",
    encryptionKey => "encryption_key",
    isbn => "isbn",
    hasDrm => "drm",
    releasedDate => "publication_date",
    size => "size",
    language => "language",
    expiration => "expires",
);
my %ITEM_FILES_XLATE = (
    id => "id",
    filename => "filename",
    display => "title",
    downloadUrl => "url",
    size => "size",
);
sub _item_xlate {
    my $self = shift;
    my $item = shift;

    my $std_item = $self->_result_xlate($item, \%SEARCH_RESULT_ITEM_XLATE);

    if (my $images = delete $item->{images}) { # XXX let's say that caller wouldn't mind
        $std_item->{images} = {map { $_->{name} => $_->{url} } @$images};
    }

    if (my $files = delete $item->{files}) {
        $std_item->{files} = [ map $self->_result_xlate($_, \%ITEM_FILES_XLATE), @$files ];
    }

    my %facets;
    if (my $publisher = delete $item->{publisher}) {
        if (ref $publisher) {
            if (my $f = $publisher->{facet}) {
                $facets{$f} = [$publisher->{token}];
            }
            $publisher = $publisher->{text};
        }
        $std_item->{publisher} = $publisher;
    }
    if (my $authors = delete $item->{authors}) {
        my @a;
        if (ref $authors) {
            foreach (@$authors) {
                push @a, $_->{text} if $_->{text};
                if (my $f = $_->{facet}) {
                    my $f_a = $facets{$f} ||= [];
                    push @$f_a, $_->{token};
                }
            }
        }
        else {
            push @a, $authors;
        }
        $std_item->{author} = join ", ", @a;
    }
    foreach my $v (values %$item) {
        my $ref = ref $v or next;
        $v = [$v] if $ref eq "HASH";
        next unless ref($v) eq "ARRAY";
        foreach (@$v) {
            if (my $f = $_->{facet}) {
                my $f_a = $facets{$f} ||= [];
                push @$f_a, $_->{token};
            }
        }
    }
    $std_item->{facets} = \%facets if keys %facets;

    return $std_item;
}

=head2 named_query_search ($query, $media)

  See C below for $query, $media

=cut

sub named_query_search {
    my $self = shift;
    return $self->_search_result_xlate( $self->native_named_query_search(@_) );
}

=head2 facet_search ($facets)

  See C below for $facets

=cut

sub facet_search {
    my $self = shift;
    return $self->_search_result_xlate( $self->native_facet_search(@_) );
}

sub item_metadata {
    my $self = shift;
    my $ni = $self->native_item(@_) or return;
    return $self->_item_xlate( $ni->{item} );
}

=head1 CIRCULATION METHOD SPECIFICS

Differences to general L interface

=cut

=head2 holds ()

=head2 place_hold ($isbn)

=head2 remove_hold ($isbn)

=cut

sub holds {
    my $self = shift;

    my $items = $self->native_holds(@_);
    return {
        total => scalar @$items,
        items => [ map {
            my $i = $self->_item_xlate($_);
            $i->{hold_id} = $_->{transactionId};
            $i;
        } @$items ],
    };
}

sub place_hold {
    my $self = shift;
    my $isbn = shift or croak "No isbn";

    my $url = $self->circulation_action_url("/holds/$isbn", @_);
    my $request = HTTP::Request::Common::POST( $url );
    my $response = $self->_request_with_auth($request);
    unless ($response->is_success) {
        $self->process_json_error_response($response, sub {
            my ($data) = @_;
            if (my $message = $data->{message}) {
                return 1 if $message =~ m/already exists/i;
                die $message;
            }
            die $self->_error_from_json($data) || "Cannot place hold: ".to_json($data);
        });
    }

    if (my $holds = $self->holds(@_)) {
        foreach my $i (@{ $holds->{items} }) {
            if ($i->{isbn} eq $isbn) {
                $i->{total} = $holds->{total};
                return $i;
            }
        }
    }

    my $content = $response->decoded_content;
    my $content_type = $response->header('Content-Type');
    my $error;
    if ($content_type && $content_type =~ m!application/json!) {
        if (my $data = eval { from_json( $content ) }) {
            $error = $self->_error_from_json($data);
        }
    }

    die $error || "Cannot place hold:\n$content";
}

sub remove_hold {
    my $self = shift;
    my $isbn = shift or croak "No isbn";

    my $url = $self->circulation_action_url("/holds/$isbn", @_);
    my $request = HTTP::Request::Common::DELETE( $url );
    my $response = $self->_request_with_auth($request);
    unless ($response->is_success) {
        return $self->process_json_error_response($response, sub {
            my ($data) = @_;
            if (my $message = $data->{message}) {
                return 1 if $message =~ m/not exists|expired/i;
                die $message;
            }
            die $self->_error_from_json($data) || "Cannot remove hold: ".to_json($data);
        });
    }
    return 1;
}

=head2 checkouts ()

=head2 checkout ($isbn, $days)

=head2 renew ($isbn)

=head2 return ($isbn)

=cut

sub checkouts {
    my $self = shift;

    my $items = $self->native_checkouts(@_);
    return {
        total => scalar @$items,
        items => [ map {
            my $i = $self->_item_xlate($_);
            $i->{checkout_id} = $_->{transactionId};
            $i;
        } @$items ],
    };
}

sub checkout {
    my $self = shift;
    my $isbn = shift or croak "No isbn";
    my $days = shift;

    if (my $checkouts = $self->checkouts(@_)) {
        foreach my $i (@{ $checkouts->{items} }) {
            if ( $i->{isbn} eq $isbn ) {
                $i->{total} = scalar @{ $checkouts->{items} };
                return $i;
            }
        }
    }

    my $url = $self->circulation_action_url("/checkouts/$isbn", @_);
    $url .= "?days=$days" if $days;
    my $res = $self->with_post_request(
        \&_basic_callback,
        $url
    );

    my $checkouts = $self->checkouts(@_) or die "Cannot checkout, unknown error";
    foreach my $i (@{ $checkouts->{items} }) {
        if ($i->{isbn} eq $isbn) {
            $i->{total} = scalar @{ $checkouts->{items} };
            return $i;
        }
    }
    die $res->{message} || "Cannot checkout, unknown error";
}

sub renew {
    my $self = shift;
    my $isbn = shift or croak "No isbn";

    my $url = $self->circulation_action_url("/checkouts/$isbn", @_);
    my $res = $self->with_put_request(
        \&_basic_callback,
        $url
    );

    my $checkouts = $self->checkouts(@_) or die "Cannot renew, unkmown error";
    foreach my $i (@{ $checkouts->{items} }) {
        if ($i->{isbn} eq $isbn) {
            $i->{total} = scalar @{ $checkouts->{items} };
            return $i;
        }
    }
    die $res->{output} || "Cannot renew, unknown error";
}

sub return {
    my $self = shift;
    my $isbn = shift or croak "No isbn";

    my $url = $self->circulation_action_url("/checkouts/$isbn", @_);
    my $request = HTTP::Request::Common::DELETE( $url );
    my $response = $self->_request_with_auth($request);
    unless ($response->is_success) {
        return $self->process_json_error_response($response, sub {
            my ($data) = @_;
            if (my $message = $data->{message}) {
                return 1 if $message =~ m/not exists|expired/i;
                die $message;
            }
            die "Cannot return: ".to_json($data);
        });
    }
    return 1;
}

=head1 NATIVE METHODS

=head2 native_search ($params_hashref)

See L

=cut

sub native_search {
    my $self = shift;
    my $search_params = shift;

    return $self->get_response($self->products_url, $search_params);
}

=head2 native_named_query_search ($query, $media)

  $query can be one of 'bestsellers', 'most-popular', 'newly-added'
  $media can be 'eaudio' or 'ebook'

=cut

my @MEDIA = qw( eaudio ebook );
my @NAMED_QUERY = ( 'bestsellers', 'most-popular', 'newly-added' );
sub native_named_query_search {
    my $self = shift;
    my $query = shift or croak "No query";
    my $media = shift or croak "No media";

    croak "Invalid media $media - should be one of ".join(", ", @MEDIA)
      unless grep { $_ eq $media } @MEDIA;
    croak "Invalid named query $query - should be one of ".join(", ", @NAMED_QUERY)
      unless grep { $_ eq $query } @NAMED_QUERY;

    my $url = $self->products_url."/$media/$query";
    return $self->get_response($url);
}

=head2 native_facet_search ($facets)

  $facets can be either:
  * a hashref of facet => [values],
  * an arrayref of values
  * a single value

=cut

sub native_facet_search {
    my $self = shift;
    my $facets = shift or croak "No facets";
    $facets = [$facets] unless ref $facets;

    my $url = $self->products_url;
    if (ref ($facets) eq "ARRAY") {
        $url = join "/", $url, @$facets;
        undef $facets;
    }
    return $self->get_response($url, $facets);
}

# Item API

=head2 native_item ($isbn)

=head2 native_item_summary ($isbn)

=head3 Returns subset of item fields, with addition of summary field

=cut

sub native_item {
    my $self = shift;
    my $isbn = shift or croak "No isbn";

    my $url = $self->title_url($isbn);
    return $self->get_response($url);
}

sub native_item_summary {
    my $self = shift;
    my $isbn = shift or croak "No isbn";

    my $url = $self->title_url("$isbn/summary");
    return $self->get_response($url);
}

=head2 native_holds ()

See L

=cut

sub native_holds {
    my $self = shift;

    my $url = $self->circulation_action_url("/holds/all", @_);
    return $self->get_response($url);
}

=head2 native_checkouts ()

=cut

sub native_checkouts {
    my $self = shift;

    my $url = $self->circulation_action_url("/checkouts/all", @_);
    return $self->get_response($url);
}

# Utility methods

sub _basic_callback { return $_[0]; }

sub get_response {
    my $self = shift;
    my $url = shift or croak "No url";
    my $get_params = shift; # hash ref

    return $self->with_get_request(\&_basic_callback, $url, $get_params);
}

sub _error_from_json {
    my $self = shift;
    my $data = shift or croak "No json data";
    return join " ", grep defined, $data->{errorCode}, $data->{message};
}

1;

__END__