From cc72106198d6529f835dd42ad2d78486517e84cb Mon Sep 17 00:00:00 2001 From: Jonathan Druart Date: Fri, 23 Jan 2026 09:29:51 +0100 Subject: [PATCH] Bug 41521: Add WebService::ILS to lib/ Signed-off-by: Victor Grousset/tuxayo --- lib/WebService/ILS.pm | 810 ++++++++++++++++++ lib/WebService/ILS/JSON.pm | 141 +++ lib/WebService/ILS/OverDrive.pm | 383 +++++++++ lib/WebService/ILS/OverDrive/Library.pm | 93 ++ lib/WebService/ILS/OverDrive/Patron.pm | 777 +++++++++++++++++ lib/WebService/ILS/RecordedBooks.pm | 698 +++++++++++++++ lib/WebService/ILS/RecordedBooks/Partner.pm | 126 +++ .../ILS/RecordedBooks/PartnerBase.pm | 90 ++ .../ILS/RecordedBooks/PartnerPatron.pm | 103 +++ lib/WebService/ILS/RecordedBooks/Patron.pm | 109 +++ lib/WebService/ILS/XML.pm | 184 ++++ 11 files changed, 3514 insertions(+) create mode 100644 lib/WebService/ILS.pm create mode 100644 lib/WebService/ILS/JSON.pm create mode 100644 lib/WebService/ILS/OverDrive.pm create mode 100644 lib/WebService/ILS/OverDrive/Library.pm create mode 100644 lib/WebService/ILS/OverDrive/Patron.pm create mode 100644 lib/WebService/ILS/RecordedBooks.pm create mode 100644 lib/WebService/ILS/RecordedBooks/Partner.pm create mode 100644 lib/WebService/ILS/RecordedBooks/PartnerBase.pm create mode 100644 lib/WebService/ILS/RecordedBooks/PartnerPatron.pm create mode 100644 lib/WebService/ILS/RecordedBooks/Patron.pm create mode 100644 lib/WebService/ILS/XML.pm diff --git a/lib/WebService/ILS.pm b/lib/WebService/ILS.pm new file mode 100644 index 0000000000..2b66d5c554 --- /dev/null +++ b/lib/WebService/ILS.pm @@ -0,0 +1,810 @@ +package WebService::ILS; + +use Modern::Perl; + +our $VERSION = "0.18"; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS - Standardised library discovery/circulation services + +=head1 SYNOPSIS + + use WebService::ILS::; + my $ils = WebService::ILS::->new({ + client_id => $client_id, + client_secret => $client_secret + }); + my %search_params = ( + query => "Some keyword", + sort => "rating", + ); + my $result = $ils->search(\%search_params); + foreach (@{ $result->{items} }) { + ... + } + foreach (2..$result->{pages}) { + $search_params{page} = $_; + my $next_results = $ils->search(\%search_params); + ... + } + + or + + my $native_result = $ils->native_search(\%native_search_params); + +=head1 DESCRIPTION + +WebService::ILS is an attempt to create a standardised interface for +online library services providers. + +In addition, native API interface is provided. + +Here we will describe constructor parameters and methods common to all +service providers. Diversions and native interfaces are documented +in corresponding modules. + +=head2 Supported service providers + +=over 4 + +=item B + +OverDrive Library API L + +=item B + +OverDrive Circulation API L + +=back + +=head1 INTERFACE + +=head2 Error handling + +Method calls will die on error. $@ will contain a multi-line string. +See C below. + +=head2 Item record + +Item record is returned by many methods, so we specify it here. + +=over 12 + +=item C + +=item C + +=item C + +=item C<subtitle> + +=item C<description> + +=item C<author> + +=item C<publisher> + +=item C<publication_date> + +=item C<language> + +=item C<rating> => user ratings metrics + +=item C<popularity> => checkout metrics + +=item C<subjects> => subject categories (tags) + +=item C<facets> => a hashref of facet => [values] + +=item C<media> => book, e-book, video, audio etc + +=item C<formats> => an arrayref of available formats + +=item C<images> => a hashref of size => url + +=item C<encryption_key> => for decryption purposes + +=item C<drm> => subject to drm + +=back + +Not all fields are available for all service providers. +Field values are not standardised. + +=cut + +use Carp; +use Hash::Merge; +use Params::Check; +use LWP::UserAgent; +use HTTP::Status qw(:constants); +use MIME::Base64 qw(); +use JSON qw(from_json); + +our $DEBUG; + +my %CONSTRUCTOR_PARAMS_SPEC; +sub _set_param_spec { + my $class = shift; + my $param_spec = shift; + + $CONSTRUCTOR_PARAMS_SPEC{$class} = $param_spec; +} +sub _get_param_spec { + my $class = shift; + if (my $ref = ref($class)) { + $class = $ref; + } + + my $p_s = $CONSTRUCTOR_PARAMS_SPEC{$class}; + return $p_s if $class eq __PACKAGE__; + + (my $superclass = $class) =~ s/::\w+$//o; + return Hash::Merge::merge($p_s || {}, $superclass->_get_param_spec); +} + +=head1 CONSTRUCTOR + +=head2 new (%params_hash or $params_hashref) + +=head3 Client (vendor) related constructor params, given by service provider: + +=over 12 + +=item C<client_id> => client (vendor) identifier + +=item C<client_secret> => secret key (password) + +=item C<library_id> => sometimes service providers provide access + to differnt "libraries" + +=back + +=head3 General constructor params: + +=over 12 + +=item C<user_agent> => LWP::UserAgent or a derivative; + usually not needed, one is created for you. + +=item C<user_agent_params> => LWP::UserAgent constructor params + so you don't need to create user agent yourself + +=item C<access_token> => as returned from the provider authentication system + +=item C<access_token_type> => as returned from the provider authentication system + +=back + +These are also read-only attributes + +Not all of client/library params are required for all service providers. + +=cut + +use Class::Tiny qw( + user_agent + client_id client_secret library_id + access_token access_token_type +); + +__PACKAGE__->_set_param_spec({ + client_id => { required => 1, defined => 1 }, + client_secret => { required => 1, defined => 1 }, + library_id => { required => 0, defined => 1 }, + access_token => { required => 0 }, + access_token_type => { required => 0 }, + user_agent => { required => 0 }, + user_agent_params => { required => 0 }, +}); + +sub BUILDARGS { + my $self = shift; + my $params = shift || {}; + if (!ref( $params )) { + $params = {$params, @_}; + } + + local $Params::Check::WARNINGS_FATAL = 1; + $params = Params::Check::check($self->_get_param_spec, $params) + or croak "Invalid parameters: ".Params::Check::last_error(); + return $params; +} + +sub BUILD { + my $self = shift; + my $params = shift; + + my $ua_params = delete $params->{user_agent_params} || {}; + $self->user_agent( LWP::UserAgent->new(%$ua_params) ) unless $self->user_agent; + delete $self->{user_agent_params}; +} + +=head1 ATTRIBUTES + +=head2 user_agent + +As provided to constructor, or auto created. Useful if one wants to +change user agent attributes on the fly, eg + + $ils->user_agent->timeout(120); + +=head1 DISCOVERY METHODS + +=head2 search ($params_hashref) + +=head3 Input params: + +=over 12 + +=item C<query> => query (search) string + +=item C<page_size> => number of items per results page + +=item C<page> => wanted page number + +=item C<sort> => resultset sort option (see below) + +=back + +Sort options are either an array or a comma separated string of options: + +=over 12 + +=item C<publication_date> => date title was published + +=item C<available_date> => date title became available for users + +=item C<rating> => number of items per results page + +=back + +Sort order can be added after option with ":", eg +"publication_date:desc,rating:desc" + +=head3 Returns search results record: + +=over 12 + +=item C<items> => an array of item records + +=item C<page_size> => number of items per results page + +=item C<page> => results page number + +=item C<pages> => total number of pages + +=item C<total> => total number of items found by the search + +=back + +=head2 item_metadata ($item_id) + +=head3 Returns item record + +=head2 item_availability ($item_id) + +=head3 Returns item availability record: + +=over 12 + +=item C<id> + +=item C<available> => boolean + +=item C<copies_available> => number of copies available + +=item C<copies_owned> => number of copies owned + +=item C<type> => availability type, provider dependant + +=back + +Not all fields are available for all service providers. +For example, some will provide "copies_available", making "available" +redundant, whereas others will just provide "available". + +=head2 is_item_available ($item_id) + +=head3 Returns boolean + +Simplified version of L<item_availability()> + +=cut + +sub search { + die "search() not implemented"; +} + +# relevancy availability available_date title author popularity rating price publisher publication_date +sub _parse_sort_string { + my $self = shift; + my $sort = shift or croak "No sort options"; + my $xlate_table = shift || {}; + my $camelise = shift; + + $sort = [split /\s*,\s*/, $sort] unless ref $sort; + + foreach (@$sort) { + my ($s,$d) = split ':'; + if (exists $xlate_table->{$s}) { + next unless $xlate_table->{$s}; + $_ = $xlate_table->{$s}; + } + else { + $_ = $s; + } + # join('', map{ ucfirst $_ } split(/(?<=[A-Za-z])_(?=[A-Za-z])|\b/, $s)); + $_ = join '', map ucfirst, split /(?<=[A-Za-z])_(?=[A-Za-z])|\b/ if $camelise; + $_ = "$_:$d" if $d; + } + + return $sort; +} + +sub item_metadata { + die "item_metadata() not implemented"; +} + +sub item_availability { + die "item_availability() not implemented"; +} + +=head1 INDIVIDUAL USER AUTHENTICATION AND METHODS + +=head2 user_id / password + +Provider authentication API is used to get an authorized session. + +=head3 auth_by_user_id($user_id, $password) + +An example: + + my $ils = WebService::ILS::Provider({ + client_id => $client_id, + client_secret => $client_secret, + }); + eval { $ils->auth_by_user_id( $user_id, $password ) }; + if ($@) { some_error_handling(); return; } + $session{ils_access_token} = $ils->access_token; + $session{ils_access_token_type} = $ils->access_token_type; + ... + Somewhere else in your app: + my $ils = WebService::ILS::Provider({ + client_id => $client_id, + client_secret => $client_secret, + access_token => $session{ils_access_token}, + access_token_type => $session{ils_access_token_type}, + }); + + my $checkouts = $ils->checkouts; + +=head2 Authentication at the provider + +User is redirected to the provider authentication url, and after +authenticating at the provider redirected back with some kind of auth token. +Requires url to handle return redirect from the provider. + +It can be used as an alternative to FB and Google auth. + +This is just to give an idea, specifics heavily depend on the provider + +=head3 auth_url ($redirect_back_uri) + +Returns provider authentication url to redirect to + +=head3 auth_token_param_name () + +Returns auth code url param name + +=head3 auth_by_token ($provider_token) + +An example: + + my $ils = WebService::ILS::Provider({ + client_id => $client_id, + client_secret => $client_secret, + }); + my $redirect_url = $ils->auth_url("http://myapp.com/ils-auth"); + $response->redirect($redirect_url); + ... + After successful authentication at the provider, provider redirects + back to specified app url (http://myapp.com/ils-auth) + + /ils-auth handler: + my $auth_token = $req->param( $ils->auth_token_param_name ) + or some_error_handling(), return; + local $@; + eval { $ils->auth_by_token( $auth_token ) }; + if ($@) { some_error_handling(); return; } + $session{ils_access_token} = $ils->access_token; + $session{ils_access_token_type} = $ils->access_token_type; + ... + Somewhere else in your app: + passing access token to the constructor as above + +=cut + +=head1 CIRCULATION METHODS + +=head2 patron () + +=head3 Returns patron record: + +=over 12 + +=item C<id> + +=item C<active> => boolean + +=item C<copies_available> => number of copies available + +=item C<checkout_limit> => number of checkouts allowed + +=item C<hold_limit> => number of holds allowed + +=back + +=head2 holds () + +=head3 Returns holds record: + +=over 12 + +=item C<total> => number of items on hold + +=item C<items> => list of individual items + +=back + +In addition to Item record fields described above, +item records will have: + +=over 12 + +=item C<placed_datetime> => hold timestamp, with or without timezone + +=item C<queue_position> => user's position in the waiting queue, + if available + +=back + +=head2 place_hold ($item_id) + +=head3 Returns holds item record (as described above) + +In addition, C<total> field will be incorported as well. + +=head2 remove_hold ($item_id) + +=head3 Returns true to indicate success + +Returns true in case user does not have a hold on the item. +Throws exception in case of any other failure. + +=head2 checkouts () + +=head3 Returns checkout record: + +=over 12 + +=item C<total> => number of items on hold + +=item C<items> => list of individual items + +=back + +In addition to Item record fields described above, +item records will have: + +=over 12 + +=item C<checkout_datetime> => checkout timestamp, with or without timezone + +=item C<expires> => date (time) checkout expires + +=item C<url> => download/stream url + +=item C<files> => an arrayref of downloadable file details + title, url, size + +=back + +=head2 checkout ($item_id) + +=head3 Returns checkout item record (as described above) + +In addition, C<total> field will be incorported as well. + +=head2 return ($item_id) + +=head3 Returns true to indicate success + +Returns true in case user does not have the item checked out. +Throws exception in case of any other failure. + +=cut + +=head1 NATIVE METHODS + +All Discovery and Circulation methods (with exception of remove_hold() +and return(), where it does not make sense) have native_*() counterparts, +eg native_search(), native_item_availability(), native_checkout() etc. + +In case of single item methods, native_item_availability(), +native_checkout() etc, they take item_id as parameter. Otherwise, it's a +hashref of HTTP request params (GET or POST). + +Return value is a record as returned by API. + +Individual provider subclasses provide additional provider specific +native methods. + +=head1 UTILITY METHODS + +=head2 Error constants + +=over 4 + +=item C<ERROR_ACCESS_TOKEN> + +=item C<ERROR_NOT_AUTHENTICATED> + +=back + +=cut + +use constant ERROR_ACCESS_TOKEN => "Error: Authorization Failed"; +use constant ERROR_NOT_AUTHENTICATED => "Error: User Not Authenticated"; + +sub invalid_response_exception_string { + my $self = shift; + my $response = shift; + + return join "\n", + $response->message, + "Request:" => $response->request->as_string, + "Response:" => $response->as_string + ; +} + +sub check_response { + my $self = shift; + my $response = shift; + + die $self->invalid_response_exception_string($response) unless $response->is_success; +} + +=head2 error_message ($exception_string) + +=head3 Returns error message probably suitable for displaying to the user + +Example: + + my $res = eval { $ils->checkout($id) }; + if ($@) { + my $msg = $ils->error_message($@); + display($msg); + log_error($@); + } + +=head2 is_access_token_error ($exception_string) + +=head3 Returns true if the error is access token related + +=head2 is_not_authenticated_error ($exception_string) + +=head3 Returns true if the error is "Not authenticated" + +=cut + +sub error_message { + my $self = shift; + my $die_string = shift or return; + $die_string =~ m/(.*?)\n/o; + (my $msg = $1 || $die_string) =~ s! at /.* line \d+\.$!!; + return $msg; +} + +sub is_access_token_error { + my $self = shift; + my $die_string = shift or croak "No error message"; + return $self->error_message($die_string) eq ERROR_ACCESS_TOKEN; +} + +sub is_not_authenticated_error { + my $self = shift; + my $die_string = shift or croak "No error message"; + return $self->error_message($die_string) eq ERROR_NOT_AUTHENTICATED; +} + +# Client access authorization +# +sub _request_with_auth { + my $self = shift; + my $request = shift or croak "No request"; + + my $has_token = $self->access_token; + my $response = $self->_request_with_token($request); + # token expired? + $response = $self->_request_with_token($request, "FRESH TOKEN") + if $response->code == HTTP_UNAUTHORIZED && $has_token; + return $response; +} + +sub make_access_token_request { + die "make_access_token_request() not implemented"; +} + +sub _request_access_token { + my $self = shift; + my $request = shift or croak "No request"; + + $request->header( + Authorization => "Basic " . $self->_access_auth_string + ); + + my $response = $self->user_agent->request( $request ); + # XXX check content type + return $self->process_json_response( + $response, + sub { + my ($data) = @_; + + my ($token, $token_type) = $self->_extract_token_from_response($data); + $token or die "No access token\n"; + $self->access_token($token); + $self->access_token_type($token_type || 'Bearer'); + return $data; + }, + sub { + my ($data) = @_; + + die join "\n", ERROR_ACCESS_TOKEN, $self->_error_from_json($data) || $response->decoded_content; + } + ); +} + +sub _access_auth_string { + my $self = shift; + return MIME::Base64::encode( join(":", $self->client_id, $self->client_secret) ); +} + +sub _extract_token_from_response { + my $self = shift; + my $data = shift; + + return ($data->{access_token}, $data->{token_type}); +} + +sub _request_with_token { + my $self = shift; + my $request = shift or croak "No request"; + my $force_fresh = shift; + + my $token = $force_fresh ? undef : $self->access_token; + unless ($token) { + my $request = $self->make_access_token_request; + $self->_request_access_token($request); + $token = $self->access_token; + } + die "No access token" unless $token; + my $token_type = $self->access_token_type; + + $request->header( Authorization => "$token_type $token" ); + return $self->user_agent->request( $request ); +} + +# Strictly speaking process_json_response() and process_json_error_response() +# should go to ::JSON. However, JSON is used for authentication services even for +# APIs that are XML, so need to be available +sub process_json_response { + my $self = shift; + my $response = shift or croak "No response"; + my $success_callback = shift; + my $error_callback = shift; + + unless ($response->is_success) { + return $self->process_json_error_response($response, $error_callback); + } + + my $content_type = $response->header('Content-Type'); + die "Invalid Content-Type\n".$response->as_string + unless $content_type && $content_type =~ m!application/json!; + my $content = $response->decoded_content + or die $self->invalid_response_exception_string($response); + + local $@; + + my $data = $content ? eval { from_json( $content ) } : {}; + die "$@\nResponse:\n".$response->as_string if $@; + + return $data unless $success_callback; + + my $res = eval { + $success_callback->($data); + }; + die "$@\nResponse:\n$content" if $@; + return $res; +} + +sub process_json_error_response { + my $self = shift; + my $response = shift or croak "No response"; + my $error_callback = shift; + + my $content_type = $response->header('Content-Type'); + if ($content_type && $content_type =~ m!application/json!) { + my $content = $response->decoded_content + or die $self->invalid_response_exception_string($response); + + my $data = eval { from_json( $content ) }; + die $content || $self->invalid_response_exception_string($response) if $@; + + if ($error_callback) { + return $error_callback->($data); + } + + die $self->_error_from_json($data) || "Invalid response:\n$content"; + } + die $self->invalid_response_exception_string($response); +} + +sub _error_from_json {}; + +# wrapper around error response handlers to include some debugging if the debug flag is set +sub _error_result { + my $self = shift; + my $process_sub = shift or croak "No process sub"; + my $request = shift or croak "No HTTP request"; + my $response = shift or croak "No HTTP response"; + + return $process_sub->() unless $DEBUG; + + local $@; + my $ret = eval { $process_sub->() }; + die join "\n", $@, "Request:", $request->as_string, "Response:", $response->as_string + if $@; + return $ret; +} + +sub _result_xlate { + my $self = shift; + my $res = shift; + my $xlate_table = shift; + + return { + map { + my $val = $res->{$_}; + defined($val) ? ($xlate_table->{$_} => $val) : () + } keys %$xlate_table + }; +} + + +=head1 TODO + +Federated search + +=cut + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/JSON.pm b/lib/WebService/ILS/JSON.pm new file mode 100644 index 0000000000..d4495a55a1 --- /dev/null +++ b/lib/WebService/ILS/JSON.pm @@ -0,0 +1,141 @@ +package WebService::ILS::JSON; + +use Modern::Perl; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS::JSON - WebService::ILS module for services with JSON API + +=head1 DESCRIPTION + +To be subclassed + +See L<WebService::ILS> + +=cut + +use Carp; +use HTTP::Request::Common; +use JSON qw(encode_json); +use URI; + +use parent qw(WebService::ILS); + +sub with_get_request { + my $self = shift; + my $callback = shift or croak "No callback"; + 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->_request_with_auth($request); + return $self->process_json_response($response, $callback); +} + +sub with_delete_request { + my $self = shift; + my $callback = shift or croak "No callback"; + my $error_callback = shift; + my $url = shift or croak "No url"; + + my $request = HTTP::Request::Common::DELETE( $url ); + my $response = $self->_request_with_auth($request); + return $response->content ? $self->process_json_response($response, $callback) : 1 + if $response->is_success; + + return $self->_error_result( + sub { $self->process_json_error_response($response, $error_callback); }, + $request, + $response + ); +} + +sub with_post_request { + my $self = shift; + my $callback = shift or croak "No callback"; + my $url = shift or croak "No url"; + my $post_params = shift || {}; # hash ref + + my $request = HTTP::Request::Common::POST( $url, $post_params ); + my $response = $self->_request_with_auth($request); + return $self->process_json_response($response, $callback); +} + +# This will probably not suit everyone +sub with_put_request { + my $self = shift; + my $callback = shift or croak "No callback"; + my $url = shift or croak "No url"; + my $put_params = shift; + + my $request = HTTP::Request::Common::PUT( $url ); + my $content; + if ($put_params) { + my $url = URI->new('http:'); + $url->query_form(ref($put_params) eq "HASH" ? %$put_params : @$put_params); + $content = $url->query; + } + if( $content ) { + # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A') + $content =~ s/(?<!%0D)%0A/%0D%0A/go; + + $request->content_type("application/x-www-form-urlencoded"); + $request->content_length(length $content); + $request->content($content); + } + else { + $request->content_length(0); + } + + my $response = $self->_request_with_auth($request); + return $self->process_json_response($response, $callback); +} + +sub with_json_request { + my $self = shift; + my $callback = shift or croak "No callback"; + my $error_callback = shift; + my $url = shift or croak "No url"; + my $post_params = shift || {}; # hashref + my $method = shift || 'post'; + + my $req_builder = "HTTP::Request::Common::".uc( $method ); + no strict 'refs'; + my $request = $req_builder->( $url ); + $self->_json_request_content($request, $post_params); + my $response = $self->_request_with_auth($request); + return $self->process_json_response($response, $callback, $error_callback); +} + +sub _json_request_content { + my $self = shift; + my $request = shift or croak "No request"; + my $data = shift or croak "No data"; # hashref + + $request->header( 'Content-Type' => 'application/json; charset=utf-8' ); + $request->content( encode_json($data) ); + $request->header( 'Content-Length' => bytes::length($request->content)); + return $request; +} + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/OverDrive.pm b/lib/WebService/ILS/OverDrive.pm new file mode 100644 index 0000000000..27c18c4026 --- /dev/null +++ b/lib/WebService/ILS/OverDrive.pm @@ -0,0 +1,383 @@ +package WebService::ILS::OverDrive; + +use Modern::Perl; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS::OverDrive - WebService::ILS module for OverDrive services + +=head1 SYNOPSIS + + use WebService::ILS::OverDrive::Library; + or + use WebService::ILS::OverDrive::Patron; + +=head1 DESCRIPTION + +L<WebService::ILS::OverDrive::Library> - anonymous discovery +services - no individual user credentials required + +L<WebService::ILS::OverDrive::Patron> - discovery and circulation +services that require individual user credentials + +See L<WebService::ILS> + +=cut + +use Carp; +use HTTP::Request::Common; +use URI::Escape; + +use parent qw(WebService::ILS::JSON); + +use constant API_VERSION => "v1"; + +use constant DISCOVERY_API_URL => "http://api.overdrive.com/"; +use constant TEST_DISCOVERY_API_URL => "http://integration.api.overdrive.com/"; + +=head1 CONSTRUCTOR + +=head2 new (%params_hash or $params_hashref) + +=head3 Additional constructor params: + +=over 10 + +=item C<test> => if set to true use OverDrive test API urls + +=back + +=cut + +use Class::Tiny qw( + collection_token + test +), { + _discovery_api_url => sub { $_[0]->test ? TEST_DISCOVERY_API_URL : DISCOVERY_API_URL }, +}; + +__PACKAGE__->_set_param_spec({ + test => { required => 0 }, +}); + +=head1 DISCOVERY METHODS + +=head2 search ($params_hashref) + +=head3 Additional input params: + +=over 16 + +=item C<no_details> => if true, no metadata calls will be made for result items; + +only id, title, rating and media will be available + +=back + +=cut + +my %SORT_XLATE = ( + available_date => "dateadded", + rating => "starrating", + publication_date => undef, # not available +); +sub search { + my $self = shift; + my $params = shift || {}; + + my $short_response = delete $params->{no_details}; + + my $url = $self->products_url; + + if (my $query = delete $params->{query}) { + $query = join " ", @$query if ref $query; + $params->{q} = $query; + } + my $page_size = delete $params->{page_size}; + $params->{limit} = $page_size if $page_size; + if (my $page_number = delete $params->{page}) { + croak "page_size must be specified for paging" unless $params->{limit}; + $params->{offset} = ($page_number - 1)*$page_size; + } + if (my $sort = delete $params->{sort}) { + $params->{sort} = join ",", @{ $self->_parse_sort_string($sort, \%SORT_XLATE) }; + } + $params->{formats} = join ",", @{$params->{formats}} if ref $params->{formats}; + + my $res = $self->get_response($url, $params); + my @items; + foreach (@{$res->{products} || []}) { + my $item; + if ($short_response) { + $item = $self->_item_xlate($_); + } else { + my $native_metadata = $self->native_item_metadata($_) or next; + $item = $self->_item_metadata_xlate($native_metadata); + } + next unless $item; + push @items, $item; + } + my $tot = $res->{totalItems}; + my %ret = ( + total => $tot, + items => \@items, + ); + if (my $page_size = $res->{limit}) { + my $pages = int($tot/$page_size); + $pages++ if $tot > $page_size*$pages; + $ret{pages} = $pages; + $ret{page_size} = $page_size; + $ret{page} = $res->{offset}/$page_size + 1; + } + return \%ret; +} + +my %SEARCH_RESULT_ITEM_XLATE = ( + id => "id", + title => "title", + subtitle => "subtitle", + starRating => "rating", + mediaType => "media", +); +sub _item_xlate { + my $self = shift; + my $item = shift; + + my $std_item = $self->_result_xlate($item, \%SEARCH_RESULT_ITEM_XLATE); + + if (my $formats = $item->{formats}) { + $std_item->{formats} = [map $_->{id}, @$formats]; + } + + if (my $images = $item->{images}) { + $std_item->{images} = {map { $_ => $images->{$_}{href} } keys %$images}; + } + + # XXX + #if (my $details = $item->{contentDetails}) { + # $std_item->{details_url} = $details->{href}; + #} + + return $std_item; +} + +my %METADATA_XLATE = ( + id => "id", + mediaType => "media", + title => "title", + publisher => "publisher", + shortDescription => "subtitle", + starRating => "rating", + popularity => "popularity", +); +sub item_metadata { + my $self = shift; + my $id = shift or croak "No item id"; + my $native_metadata = $self->get_response($self->products_url."/$id/metadata"); + return $self->_item_metadata_xlate($native_metadata); +} + +sub _item_metadata_xlate { + my $self = shift; + my $metadata = shift or croak "No native metadata"; + + my $item = $self->_result_xlate($metadata, \%METADATA_XLATE); + + my @authors; + foreach (@{ $metadata->{creators} }) { + push @authors, $_->{name} if $_->{role} eq "Author"; + } + $item->{author} = join ", ", @authors; + + if (my $images = $metadata->{images}) { + $item->{images} = {map { $_ => $images->{$_}{href} } keys %$images}; + } + + if (my $languages = $metadata->{languages}) { + $item->{languages} = [map $_->{name}, @$languages]; + } + + if (my $subjects = $metadata->{subjects}) { + $item->{subjects} = [map $_->{value}, @$subjects]; + } + + if (my $formats = $metadata->{formats}) { + $item->{formats} = [map $_->{id}, @$formats]; + } + + return $item; +} + +my %AVAILABILITY_RESULT_XLATE = ( + id => "id", + available => "available", + copiesAvailable => "copies_available", + copiesOwned => "copies_owned", + availabilityType => "type", +); +sub item_availability { + my $self = shift; + my $id = shift or croak "No item id"; + return $self->_result_xlate( + $self->get_response($self->products_url."/$id/availability"), + \%AVAILABILITY_RESULT_XLATE + ); +} + +sub is_item_available { + my $self = shift; + my $id = shift or croak "No item id"; + my $type = shift; + + my $availability = $self->item_availability($id) or return; + return unless $availability->{available}; + return !$type || $type eq $availability->{type}; +} + +=head1 NATIVE METHODS + +=head2 native_search ($params_hashref) + +See L<https://developer.overdrive.com/apis/search> + +=head2 native_search_[next|prev|first|last] ($data_as returned_by_native_search*) + +For iterating through search result pages. Each native_search_*() method +accepts record returned by any native_search*() method as input. + +Example: + + my $res = $od->native_search({q => "Dogs"}); + while ($res) { + do_something($res); + $res = $od->native_search_next($res); + } + or + my $res = $od->native_search({q => "Dogs"}); + my $last = $od->native_search_last($res); + my $next_to_last = $od->native_search_prev($last); + my $first = $od->native_search_first($next_to_last) + # Same as $od->native_search_first($last) + # Same as $res + +=cut + +# params: q, limit, offset, formats, sort ? availability +sub native_search { + my $self = shift; + my $search_params = shift; + + return $self->get_response($self->products_url, $search_params); +} + +foreach my $f (qw(next prev first last)) { + no strict 'refs'; + my $method = "native_search_$f"; + *$method = sub { + my $self = shift; + my $search_data = shift or croak "No search result data"; + my $url = _extract_link($search_data, $f) or return; + return $self->get_response($url); + } +} + +# Item API + +=head2 native_item_metadata ($item_data as returned by native_search*) + +=head2 native_item_availability ($item_data as returned by native_search*) + +Example: + + my $res = $od->native_search({q => "Dogs"}); + foreach (@{ $res->{products} }) { + my $meta = $od->native_item_metadata($_); + my $availability = $od->native_item_availability($_); + ... + } + +=cut + +sub native_item_metadata { + my $self = shift; + my $item = shift or croak "No item record"; + + my $url = _extract_link($item, 'metadata') or die "No metadata link\n"; + return $self->get_response($url); +} + +sub native_item_availability { + my $self = shift; + my $item = shift or croak "No item record"; + return $self->get_response(_extract_link($item, 'availability')); +} + +# Discovery helpers + +sub discovery_action_url { + my $self = shift; + my $action = shift; + return $self->_discovery_api_url.$self->API_VERSION.$action; +} + +sub products_url { + my $self = shift; + + my $collection_token = $self->collection_token or die "No collection token"; + + if ($collection_token) { + return $self->_discovery_api_url.$self->API_VERSION."/collections/$collection_token/products"; + } +} + +# API helpers + +sub _extract_link { + my ($data, $link) = @_; + my $href = $data->{links}{$link}{href} + or croak "No '$link' url in data"; +} + +# Utility methods + +sub _basic_callback { return $_[0]; } + +# This is not exatly how we meant to use with_get_request() +# ie processing should be placed within the callback. +# However, if all goes well, it is faster (from the development perspective) +# this way. +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"; + my $error = join " ", grep defined($_), $data->{errorCode}, $data->{error_description} || $data->{error} || $data->{message} || $data->{Message}; + $error = "$error\n" if $error; # strip code line when dying + return $error; +} + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/OverDrive/Library.pm b/lib/WebService/ILS/OverDrive/Library.pm new file mode 100644 index 0000000000..2e18a97d3d --- /dev/null +++ b/lib/WebService/ILS/OverDrive/Library.pm @@ -0,0 +1,93 @@ +package WebService::ILS::OverDrive::Library; + +use Modern::Perl; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS::OverDrive::Library - WebService::ILS module for OverDrive +discovery only services + +=head1 SYNOPSIS + + use WebService::ILS::OverDrive::Library; + +=head1 DESCRIPTION + +See L<WebService::ILS::OverDrive> + +=cut + +use Carp; +use HTTP::Request::Common; + +use parent qw(WebService::ILS::OverDrive); + +__PACKAGE__->_set_param_spec({ + library_id => { required => 1, defined => 1 }, +}); + +sub make_access_token_request { + my $self = shift; + + return HTTP::Request::Common::POST( 'https://oauth.overdrive.com/token', { + grant_type => 'client_credentials' + } ); +} + +sub collection_token { + my $self = shift; + + if (my $collection_token = $self->SUPER::collection_token) { + return $collection_token; + } + + $self->native_library_account; + my $collection_token = $self->SUPER::collection_token + or die "Library has no collections\n"; + return $collection_token; +} + +=head1 NATIVE METHODS + +=head2 native_library_account () + +See L<https://developer.overdrive.com/apis/library-account> + +=cut + +sub native_library_account { + my $self = shift; + + my $library = $self->get_response($self->library_url); + if (my $collection_token = $library->{collectionToken}) { + $self->SUPER::collection_token( $collection_token); + } + return $library; +} + +# Discovery helpers + +sub library_url { + my $self = shift; + return $self->discovery_action_url("/libraries/".$self->library_id); +} + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/OverDrive/Patron.pm b/lib/WebService/ILS/OverDrive/Patron.pm new file mode 100644 index 0000000000..ccb1b7fd83 --- /dev/null +++ b/lib/WebService/ILS/OverDrive/Patron.pm @@ -0,0 +1,777 @@ +# Copyright 2015 Catalyst + +package WebService::ILS::OverDrive::Patron; + +use Modern::Perl; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS::OverDrive::Patron - WebService::ILS module for OverDrive +circulation services + +=head1 SYNOPSIS + + use WebService::ILS::OverDrive::Patron; + +=head1 DESCRIPTION + +These services require individual user credentials. +See L<WebService::ILS INDIVIDUAL USER AUTHENTICATION AND METHODS> + +See L<WebService::ILS::OverDrive> + +=cut + +use Carp; +use HTTP::Request::Common; +use URI::Escape; +use Data::Dumper; + +use parent qw(WebService::ILS::OverDrive); + +use constant CIRCULATION_API_URL => "http://patron.api.overdrive.com/"; +use constant TEST_CIRCULATION_API_URL => "http://integration-patron.api.overdrive.com/"; +use constant OAUTH_BASE_URL => "https://oauth.overdrive.com/"; +use constant TOKEN_URL => OAUTH_BASE_URL . 'token'; +use constant AUTH_URL => OAUTH_BASE_URL . 'auth'; + +=head1 CONSTRUCTOR + +=head2 new (%params_hash or $params_hashref) + +=head3 Additional constructor params: + +=over 16 + +=item C<auth_token> => auth token as previously obtained + +=back + +=cut + +use Class::Tiny qw( + user_id password website_id authorization_name + auth_token +), { + _circulation_api_url => sub { $_[0]->test ? TEST_CIRCULATION_API_URL : CIRCULATION_API_URL }, +}; + +__PACKAGE__->_set_param_spec({ + auth_token => { required => 0 }, +}); + +=head1 INDIVIDUAL USER AUTHENTICATION METHODS + +=head2 auth_by_user_id ($user_id, $password, $website_id, $authorization_name) + +C<website_id> and C<authorization_name> (domain) are provided by OverDrive + +=head3 Returns (access_token, access_token_type) or access_token + +=cut + +sub auth_by_user_id { + my $self = shift; + my $user_id = shift or croak "No user id"; + my $password = shift; # can be blank + my $website_id = shift or croak "No website id"; + my $authorization_name = shift or croak "No authorization name"; + + my $request = $self->_make_access_token_by_user_id_request($user_id, $password, $website_id, $authorization_name); + $self->_request_access_token($request); + + $self->user_id($user_id); + $self->password($password); + $self->website_id($website_id); + $self->authorization_name($authorization_name); + return wantarray ? ($self->access_token, $self->access_token_type) : $self->access_token; +} + +sub _make_access_token_by_user_id_request { + my $self = shift; + my $user_id = shift or croak "No user id"; + my $password = shift; # can be blank + my $website_id = shift or croak "No website id"; + my $authorization_name = shift or croak "No authorization name"; + + my %params = ( + grant_type => 'password', + username => $user_id, + scope => "websiteid:".$website_id." authorizationname:".$authorization_name, + ); + if ($password) { + $params{password} = $password; + } else { + $params{password} = "[ignore]"; + $params{password_required} = "false"; + } + return HTTP::Request::Common::POST( 'https://oauth-patron.overdrive.com/patrontoken', \%params ); +} + +=head2 Authentication at OverDrive - Granted or "3-Legged" Authorization + +With OverDrive there's an extra step - an auth code is returned to the +redirect back handler that needs to make an API call to convert it into +a auth token. + +An example: + + my $overdrive = WebService::ILS::OverDrive::Patron({ + client_id => $client_id, + client_secret => $client_secret, + library_id => $library_id, + }); + my $redirect_url = $overdrive->auth_url("http://myapp.com/overdrive-auth"); + $response->redirect($redirect_url); + ... + /overdrive-auth handler: + my $auth_code = $req->param( $overdrive->auth_code_param_name ) + or some_error_handling(), return; + # my $state = $req->param( $overdrive->state_token_param_name )... + local $@; + eval { $overdrive->auth_by_code( $auth_code ) }; + if ($@) { some_error_handling(); return; } + $session{overdrive_access_token} = $access_token; + $session{overdrive_access_token_type} = $access_token_type; + $session{overdrive_auth_token} = $auth_token; + ... + Somewhere else in your app: + my $ils = WebService::ILS::Provider({ + client_id => $client_id, + client_secret => $client_secret, + access_token => $session{overdrive_access_token}, + access_token_type => $session{overdrive_access_token_type}, + auth_token = $session{overdrive_auth_token} + }); + my $checkouts = $overdrive->checkouts; + +=head2 auth_url ($redirect_uri, $state_token) + +=head3 Input params: + +=over 18 + +=item C<redirect_uri> => return url which will handle redirect back after auth + +=item C<state_token> => a token that is returned back unchanged; + +for additional security; not required + +=back + +=cut + +sub auth_url { + my $self = shift; + my $redirect_uri = shift or croak "Redirect URI not specified"; + my $state_token = shift; + + my $library_id = $self->library_id or croak "No Library Id"; + + return sprintf AUTH_URL . + "?client_id=%s" . + "&redirect_uri=%s" . + "&scope=%s" . + "&response_type=code" . + "&state=%s", + map uri_escape($_), + $self->client_id, + $redirect_uri, + "accountid:$library_id", + defined ($state_token) ? $state_token : "" + ; +} + +=head2 auth_code_param_name () + +=head2 state_token_param_name () + +=cut + +use constant auth_code_param_name => "code"; +use constant state_token_param_name => "code"; + +=head2 auth_by_code ($provider_code, $redirect_uri) + +=head3 Returns (access_token, access_token_type, auth_token) or access_token + +=cut + +sub auth_by_code { + my $self = shift; + my $code = shift or croak "No authorization code"; + my $redirect_uri = shift or croak "Redirect URI not specified"; + + my $auth_type = 'authorization_code'; + + my $request = HTTP::Request::Common::POST( TOKEN_URL, { + grant_type => 'authorization_code', + code => $code, + redirect_uri => $redirect_uri, + } ); + $self->_request_access_token($request); + return wantarray ? ($self->access_token, $self->access_token_type, $self->auth_token) : $self->access_token; +} + +=head2 auth_by_token ($provider_token) + +=head3 Returns (access_token, access_token_type, auth_token) or access_token + +=cut + +sub auth_by_token { + my $self = shift; + my $auth_token = shift or croak "No authorization token"; + + $self->auth_token($auth_token); + my $request = $self->_make_access_token_by_auth_token_request($auth_token); + $self->_request_access_token($request); + + return wantarray ? ($self->access_token, $self->access_token_type, $self->auth_token) : $self->access_token; +} + +sub _make_access_token_by_auth_token_request { + my $self = shift; + my $auth_token = shift or croak "No authorization token"; + + return HTTP::Request::Common::POST( TOKEN_URL, { + grant_type => 'refresh_token', + refresh_token => $auth_token, + } ); +} + +sub make_access_token_request { + my $self = shift; + + if (my $auth_token = $self->auth_token) { + return $self->_make_access_token_by_auth_token_request($auth_token); + } + elsif (my $user_id = $self->user_id) { + return $self->_make_access_token_by_user_id_request( + $user_id, $self->password, $self->website_id, $self->authorization_name + ); + } + + die $self->ERROR_NOT_AUTHENTICATED."\n"; +} + +sub _request_access_token { + my $self = shift; + my $request = shift or croak "No request"; + + my $data = $self->SUPER::_request_access_token($request) + or die "Unsuccessful access token request"; + + if (my $auth_token = $data->{refresh_token}) { + $self->auth_token($auth_token); + } + + return $data; +} + +sub collection_token { + my $self = shift; + + if (my $collection_token = $self->SUPER::collection_token) { + return $collection_token; + } + + $self->native_patron; # sets collection_token as a side-effect + my $collection_token = $self->SUPER::collection_token + or die "Patron has no collections\n"; + return $collection_token; +} + +=head1 CIRCULATION METHOD SPECIFICS + +Differences to general L<WebService::ILS> interface + +=cut + +my %PATRON_XLATE = ( + checkoutLimit => "checkout_limit", + existingPatron => 'active', + patronId => 'id', + holdLimit => 'hold_limit', +); +sub patron { + my $self = shift; + return $self->_result_xlate($self->native_patron, \%PATRON_XLATE); +} + +my %HOLDS_XLATE = ( + totalItems => 'total', +); +my %HOLDS_ITEM_XLATE = ( + reserveId => 'id', + holdPlacedDate => 'placed_datetime', + holdListPosition => 'queue_position', +); +sub holds { + my $self = shift; + + my $holds = $self->native_holds; + my $items = delete ($holds->{holds}) || []; + + my $res = $self->_result_xlate($holds, \%HOLDS_XLATE); + $res->{items} = [ + map { + my $item = $self->_result_xlate($_, \%HOLDS_ITEM_XLATE); + my $item_id = $item->{id}; + my $metadata = $self->item_metadata($item_id); + my $i = {%$item, %$metadata}; # we need my $i, don't ask me why... + } @$items + ]; + return $res; +} + +=head2 place_hold ($item_id, $notification_email_address, $auto_checkout) + +C<$notification_email_address> and C<$auto_checkout> are optional. +C<$auto_checkout> defaults to false. + +=head3 Returns holds item record + +It is prefered that the C<$notification_email_address> is specified. + +If C<$auto_checkout> is set to true, the item will be checked out as soon as +it becomes available. + +=cut + +sub place_hold { + my $self = shift; + + my $hold = $self->native_place_hold(@_) or return; + my $res = $self->_result_xlate($hold, \%HOLDS_ITEM_XLATE); + $res->{total} = $hold->{numberOfHolds}; + return $res; +} + +# sub suspend_hold { - not really useful + +sub remove_hold { + my $self = shift; + my $item_id = shift or croak "No item id"; + + my $url = $self->circulation_action_url("/holds/$item_id"); + return $self->with_delete_request( + \&_basic_callback, + sub { + my ($data) = @_; + return 1 if $data->{errorCode} eq "PatronDoesntHaveTitleOnHold"; + die ($data->{message} || $data->{errorCode})."\n"; + }, + $url + ); +} + +=head2 checkouts () + +For formats see C<checkout_formats()> below + +=cut + +my %CHECKOUTS_XLATE = ( + totalItems => 'total', + totalCheckouts => 'total_format', +); +sub checkouts { + my $self = shift; + + my $checkouts = $self->native_checkouts; + my $items = delete ($checkouts->{checkouts}) || []; + + my $res = $self->_result_xlate($checkouts, \%CHECKOUTS_XLATE); + $res->{items} = [ + map { + my $item = $self->_checkout_item_xlate($_); + my $item_id = $item->{id}; + my $formats = delete ($_->{formats}); + my $actions = delete ($_->{actions}); + my $metadata = $self->item_metadata($item_id); + if ($formats) { + $formats = $self->_formats_xlate($item_id, $formats); + } + else { + $formats = {}; + } + if ($actions) { + if (my $format_action = $actions->{format}) { + foreach (@{$format_action->{fields}}) { + next unless $_->{name} eq "formatType"; + + foreach my $format (@{$_->{options}}) { + $formats->{$format} = undef unless exists $formats->{$format}; + } + last; + } + } + } + my $i = {%$item, %$metadata, formats => $formats}; # we need my $i, don't ask me why... + } @$items + ]; + return $res; +} + +my %CHECKOUT_ITEM_XLATE = ( + reserveId => 'id', + checkoutDate => 'checkout_datetime', + expires => 'expires', +); +sub _checkout_item_xlate { + my $self = shift; + my $item = shift; + + my $i = $self->_result_xlate($item, \%CHECKOUT_ITEM_XLATE); + if ($item->{isFormatLockedIn}) { + my $formats = $item->{formats} or die "Item $item->{reserveId}: Format locked in, but no formats returned\n"; + $i->{format} = $formats->[0]{formatType}; + } + return $i; +} + +=head2 checkout ($item_id, $format, $allow_multiple_format_checkouts) + +C<$format> and C<$allow_multiple_format_checkouts> are optional. +C<$allow_multiple_format_checkouts> defaults to false. + +=head3 Returns checkout item record + +An item can be available in multiple formats. Checkout is complete only +when the format is specified. + +Checkout can be actioned without format being specified. In that case an +early return can be actioned. To complete checkout format must be locked +later (see L<lock_format()> below). That would be the case with +L<place_hold()> with C<$auto_checkout> set to true. Once format is locked, +an early return is not possible. + +If C<$allow_multiple_format_checkouts> flag is set to true, mutiple formats +of the same item can be acioned. If it is false (default) and the item was +already checked out, the checked out item record will be returned regardless +of the format. + +Checkout record will have an extra field C<format> if format is locked in. + +=cut + +sub checkout { + my $self = shift; + + my $checkout = $self->native_checkout(@_) or return; + return $self->_checkout_item_xlate($checkout); +} + +=head2 checkout_formats ($item_id) + +=head3 Returns a hashref of available title formats and immediate availability + + { format => available, ... } + +If format is not immediately available it must be locked first + +=cut + +sub checkout_formats { + my $self = shift; + my $id = shift or croak "No item id"; + + my $formats = $self->native_checkout_formats($id) or return; + $formats = $formats->{'formats'} or return; + return $self->_formats_xlate($id, $formats); +} + +sub _formats_xlate { + my $self = shift; + my $id = shift or croak "No item id"; + my $formats = shift or croak "No formats"; + + my %ret; + my $id_uc = uc $id; + foreach (@$formats) { + die "Non-matching item id\nExpected $id\nGot $_->{reserveId}" unless uc($_->{reserveId}) eq $id_uc; + my $format = $_->{formatType}; + my $available; + if (my $lt = $_->{linkTemplates}) { + $available = grep /^downloadLink/, keys %$lt; + } + $ret{$format} = $available; + } + return \%ret; +} + +sub is_lockable { + my $self = shift; + my $checkout_formats = shift or croak "No checkout formats"; + while (my ($format, $available) = each %$checkout_formats) { + return 1 unless $available; + } + return 0; +} + +=head2 lock_format ($item_id, $format) + +=head3 Returns locked format (should be the same as the input value) + +=cut + +sub lock_format { + my $self = shift; + my $item_id = shift or croak "No item id"; + my $format = shift or croak "No format"; + + my $lock = $self->native_lock_format($item_id, $format) or return; + die "Non-matching item id\nExpected $item_id\nGot $lock->{reserveId}" unless uc($lock->{reserveId}) eq uc($item_id); + return $lock->{formatType}; +} + +=head2 checkout_download_url ($item_id, $format, $error_url, $success_url) + +=head3 Returns OverDrive download url + +Checked out items must be downloaded by users on the OverDrive site. +This method returns the url where the user should be sent to (redirected). +Once the download is complete, user will be redirected back to +C<$error_url> in case of an error, otherwise to optional C<$success_url> +if specified. + +See L<https://developer.overdrive.com/apis/download> + +=cut + +sub checkout_download_url { + my $self = shift; + my $item_id = shift or croak "No item id"; + my $format = shift or croak "No format"; + my $error_url = shift or die "No error url"; + my $success_url = shift; + + $error_url = uri_escape($error_url); + $success_url = $success_url ? uri_escape($success_url) : ''; + my $url = $self->circulation_action_url("/checkouts/$item_id/formats/$format/downloadlink?errorurl=$error_url&successurl=$success_url"); + my $response_data = $self->get_response($url); + my $download_url = + _extract_link($response_data, 'contentLink') || + _extract_link($response_data, 'contentlink') + or die "Cannot get download url\n".Dumper($response_data); + return $download_url; +} + +sub return { + my $self = shift; + my $item_id = shift or croak "No item id"; + + my $url = $self->circulation_action_url("/checkouts/$item_id"); + return $self->with_delete_request( + \&_basic_callback, + sub { + my ($data) = @_; + return 1 if $data->{errorCode} eq "PatronDoesntHaveTitleCheckedOut"; + die ($data->{message} || $data->{errorCode})."\n"; + }, + $url + ); +} + +=head1 NATIVE METHODS + +=head2 native_patron () + +See L<https://developer.overdrive.com/apis/patron-information> + +=cut + +sub native_patron { + my $self = shift; + + my $url = $self->circulation_action_url(""); + my $patron = $self->get_response($url) or return; + if (my $collection_token = $patron->{collectionToken}) { + $self->SUPER::collection_token( $collection_token); + } + return $patron; +} + +=head2 native_holds () + +=head2 native_place_hold ($item_id, $notification_email_address, $auto_checkout) + +See L<https://developer.overdrive.com/apis/holds> + +=cut + +sub native_holds { + my $self = shift; + my $url = $self->circulation_action_url("/holds"); + return $self->get_response($url); +} + +sub native_place_hold { + my $self = shift; + my $item_id = shift or croak "No item id"; + my $email = shift; + my $auto_checkout = shift; + + my @fields = ( {name => "reserveId", value => $item_id } ); + push @fields, {name => "autoCheckout", value => "true"} if $auto_checkout; + if ($email) { + push @fields, {name => "emailAddress", value => $email}; + } else { + push @fields, {name => "ignoreHoldEmail", value => "true"}; + } + + my $url = $self->circulation_action_url("/holds"); + return $self->with_json_request( + \&_basic_callback, + sub { + my ($data) = @_; + if ($data->{errorCode} eq "AlreadyOnWaitList") { + if (my $holds = $self->native_holds) { + my $item_id_uc = uc $item_id; + foreach (@{ $holds->{holds} || [] }) { + if ( uc($_->{reserveId}) eq $item_id_uc ) { + $_->{numberOfHolds} = $holds->{totalItems}; + return $_; + } + } + } + } + + die ($data->{message} || $data->{errorCode})."\n"; + }, + $url, + {fields => \@fields} + ); +} + +=head2 native_checkouts () + +=head2 native_checkout_info ($item_id) + +=head2 native_checkout ($item_id, $format, $allow_multiple_format_checkouts) + +=head2 native_checkout_formats ($item_id) + +=head2 native_lock_format ($item_id, $format) + +See L<https://developer.overdrive.com/apis/checkouts> + +=cut + +sub native_checkouts { + my $self = shift; + + my $url = $self->circulation_action_url("/checkouts"); + return $self->get_response($url); +} + +sub native_checkout_info { + my $self = shift; + my $id = shift or croak "No item id"; + + my $url = $self->circulation_action_url("/checkouts/$id"); + return $self->get_response($url); +} + +sub native_checkout_formats { + my $self = shift; + my $id = shift or croak "No item id"; + + my $url = $self->circulation_action_url("/checkouts/$id/formats"); + return $self->get_response($url); +} + +sub native_checkout { + my $self = shift; + my $item_id = shift or croak "No item id"; + my $format = shift; + my $allow_multi = shift; + + if (my $checkouts = $self->native_checkouts) { + my $item_id_uc = uc $item_id; + foreach (@{ $checkouts->{checkouts} || [] }) { + if ( uc($_->{reserveId}) eq $item_id_uc ) { + if ($format) { + if ($_->{isFormatLockedIn}) { + return $_ if lc($_->{formats}[0]{formatType}) eq lc($format); + die "Item $item_id has already been locked for different format '$_->{formats}[0]{formatType}'\n" + unless $allow_multi; + } +# else { $self->native_lock_format()? } + } +# else { die if !$allow_multi ? } + return $_; + } + } + } + + my $url = $self->circulation_action_url("/checkouts"); + return $self->with_json_request( + \&_basic_callback, + undef, + $url, + {fields => _build_checkout_fields($item_id, $format)} + ); +} + +sub native_lock_format { + my $self = shift; + my $item_id = shift or croak "No item id"; + my $format = shift or croak "No format"; + + my $url = $self->circulation_action_url("/checkouts/$item_id/formats"); + return $self->with_json_request( + \&_basic_callback, + sub { + my ($data) = @_; + die "$format ".($data->{message} || $data->{errorCode})."\n"; + }, + $url, + {fields => _build_checkout_fields($item_id, $format)} + ); +} + +sub _build_checkout_fields { + my ($id, $format) = @_; + my @fields = ( {name => "reserveId", value => $id } ); + push @fields, {name => "formatType", value => $format} if $format; + return \@fields; +} + +# Circulation helpers + +sub circulation_action_url { + my $self = shift; + my $action = shift; + return $self->_circulation_api_url.$self->API_VERSION."/patrons/me$action"; +} + +# API helpers + +sub _extract_link { + my ($data, $link) = @_; + return $data->{links}{$link}->{href}; +} + +sub _basic_callback { return $_[0]; } + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/RecordedBooks.pm b/lib/WebService/ILS/RecordedBooks.pm new file mode 100644 index 0000000000..5508f82745 --- /dev/null +++ b/lib/WebService/ILS/RecordedBooks.pm @@ -0,0 +1,698 @@ +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<WebService::ILS::RecordedBooks::Partner> - services +that use partner credentials, for any patron + +L<WebService::ILS::RecordedBooks::PartnerPatron> - same as above, +except it operates on a single patron account + +L<WebService::ILS::RecordedBooks::Patron> - services +that use individual patron credentials, in addition to partner credentials + +L<WebService::ILS::RecordedBooks::PartnerPatron> is preferred over +L<WebService::ILS::RecordedBooks::Patron> 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<WebService::ILS> + +=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<ssl> => if set to true use https + +=item C<domain> => RecordedBooks domain for title url + +=back + +C<client_id> is either RecordedBooks id (barcode) or email + +C<domain> 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<facets> => 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<native_named_query_search()> 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<native_facet_search()> 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<WebService::ILS> 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<https://developer.overdrive.com/apis/search> + +=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<http://developer.rbdigital.com/endpoints/title-holds> + +=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__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/RecordedBooks/Partner.pm b/lib/WebService/ILS/RecordedBooks/Partner.pm new file mode 100644 index 0000000000..424398c5e5 --- /dev/null +++ b/lib/WebService/ILS/RecordedBooks/Partner.pm @@ -0,0 +1,126 @@ +package WebService::ILS::RecordedBooks::Partner; + +use Modern::Perl; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS::RecordedBooks::Partner - RecordedBooks partner API + +=head1 SYNOPSIS + + use WebService::ILS::RecordedBooks::Partner; + +=head1 DESCRIPTION + +L<WebService::ILS::RecordedBooks::Partner> - services +that use trusted partner credentials + +See L<WebService::ILS::RecordedBooks> + +=cut + +use Carp; + +use parent qw(WebService::ILS::RecordedBooks::PartnerBase); + +sub circulation_action_base_url { + my $self = shift; + my $patron_id = shift or croak "No patron id"; + + return $self->library_action_base_url."/patrons/${patron_id}"; +} + +=head1 DISCOVERY METHODS + +=head2 facet_search ($facets) + + See C<native_facet_search()> below for $facets + +=head2 named_query_search ($query, $media) + + See C<native_named_query_search()> below for $query, $media + +=head1 CIRCULATION METHOD SPECIFICS + +Differences to general L<WebService::ILS> interface + +=head2 patron_id ($email_or_id) + +=head2 holds ($patron_id) + +=head2 place_hold ($patron_id, $isbn) + +=head2 checkouts ($patron_id) + +=head2 checkout ($patron_id, $isbn) + +=head2 renew ($patron_id, $isbn) + +=head2 return ($patron_id, $isbn) + +=cut + +foreach my $sub (qw(place_hold remove_hold renew return)) { + no strict "refs"; + *$sub = sub { + my $self = shift; + my $patron_id = shift or croak "No patron id"; + my $isbn = shift or croak "No isbn"; + my $supersub = "SUPER::$sub"; + return $self->$supersub($isbn, $patron_id); + }; +} + +sub checkout { + my $self = shift; + my $patron_id = shift or croak "No patron id"; + my $isbn = shift or croak "No isbn"; + my $days = shift; + return $self->SUPER::checkout($isbn, $days, $patron_id); +} + + +=head1 NATIVE METHODS + +=head2 native_quick_search ($query, $category) + + $category can be one of 'all', 'title', 'author', or 'narrator'; + optional, defaults to 'all' + +=cut + +=head2 native_facet_search ($facets) + + $facets can be either: + * a hashref of facet => [values], + * an arrayref of values + * a single value + +=head2 native_named_query_search ($query, $media) + + $query can be one of 'bestsellers', 'most-popular', 'newly-added' + $media can be 'eaudio' or 'ebook' + +=head2 native_patron ($email_or_id) + +=cut + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/RecordedBooks/PartnerBase.pm b/lib/WebService/ILS/RecordedBooks/PartnerBase.pm new file mode 100644 index 0000000000..fe287a3fa6 --- /dev/null +++ b/lib/WebService/ILS/RecordedBooks/PartnerBase.pm @@ -0,0 +1,90 @@ +package WebService::ILS::RecordedBooks::PartnerBase; + +use Modern::Perl; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS::RecordedBooks::PartnerBase - RecordedBooks partner API + +=head1 SYNOPSIS + +See L<WebService::ILS::RecordedBooks::Partner> +and L<WebService::ILS::RecordedBooks::PartnerPatron>; + +=cut + +use Carp; +use URI::Escape; + +use parent qw(WebService::ILS::RecordedBooks); + +sub title_url { + my $self = shift; + my $isbn = shift or croak "No isbn"; + return $self->library_action_base_url."/titles/$isbn"; +} + +sub _request_with_token { + my $self = shift; + my $request = shift or croak "No request"; + + $request->header( Authorization => "Basic ".$self->client_secret ); + return $self->user_agent->request( $request ); +} + +=head1 CIRCULATION METHOD SPECIFICS + +=cut + +use constant NATIVE_PATRON_ID_KEY => "patronId"; +my %PATRON_XLATE = ( + NATIVE_PATRON_ID_KEY() => 'id', +); +sub patron { + my $self = shift; + return $self->_result_xlate($self->native_patron(@_), \%PATRON_XLATE); +} + +=head2 patron_id ($email_or_id) + +=cut + +sub patron_id { + my $self = shift; + my $patron = $self->native_patron(@_) or return; + return $patron->{NATIVE_PATRON_ID_KEY()}; +} + +=head1 NATIVE METHODS + +=head2 native_patron ($email_or_id) + +=cut + +sub native_patron { + my $self = shift; + my $cardnum_or_email = shift or croak "No patron identification"; + + my $url = $self->api_url("/rpc/libraries/".$self->library_id."/patrons/".uri_escape($cardnum_or_email)); + return $self->get_response($url); +} + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/RecordedBooks/PartnerPatron.pm b/lib/WebService/ILS/RecordedBooks/PartnerPatron.pm new file mode 100644 index 0000000000..a5f39c0c68 --- /dev/null +++ b/lib/WebService/ILS/RecordedBooks/PartnerPatron.pm @@ -0,0 +1,103 @@ +package WebService::ILS::RecordedBooks::PartnerPatron; + +use Modern::Perl; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS::RecordedBooks::PartnerPatron - RecordedBooks patner API +for an individual patron + +=head1 SYNOPSIS + + use WebService::ILS::RecordedBooks::PartnerPatron; + +=head1 DESCRIPTION + +L<WebService::ILS::RecordedBooks::PartnerPatron> - services +that use trusted partner credentials to operat on behalf of a specified patron + +See L<WebService::ILS::RecordedBooks::Partner> + +=cut + +use Carp; + +use parent qw(WebService::ILS::RecordedBooks::PartnerBase); + +=head1 CONSTRUCTOR + +=head2 new (%params_hash or $params_hashref) + +=head3 Additional constructor params: + +=over 12 + +=item C<user_id> => RecordedBooks user id (barcode), or email + +=back + +C<client_id> is either RecordedBooks id (barcode) or email + +=cut + +use Class::Tiny qw( + user_id +); + +__PACKAGE__->_set_param_spec({ + user_id => { required => 1 }, +}); + +sub BUILD { + my $self = shift; + my $params = shift; + + local $@; + my $patron_id = eval { $self->SUPER::patron_id($self->user_id) } + or croak "Invalid user_id ".$self->user_id.($@ ? "\n$@" : ""); + $self->user_id($patron_id); +} + +sub circulation_action_base_url { + my $self = shift; + + return $self->library_action_base_url."/patrons/".$self->user_id; +} + +sub patron_id { + my $self = shift; + return $self->user_id; +} + +sub patron { + my $self = shift; + return {id => $self->user_id}; +} + +=head1 NATIVE METHODS + +=head2 native_patron () + +This method cannot be called + +=cut + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/RecordedBooks/Patron.pm b/lib/WebService/ILS/RecordedBooks/Patron.pm new file mode 100644 index 0000000000..8c30b6268a --- /dev/null +++ b/lib/WebService/ILS/RecordedBooks/Patron.pm @@ -0,0 +1,109 @@ +package WebService::ILS::RecordedBooks::Patron; + +use Modern::Perl; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS::RecordedBooks::Patron - RecordedBooks patron API + +=head1 SYNOPSIS + + use WebService::ILS::RecordedBooks::Patron; + +=cut + +=head1 DESCRIPTION + +L<WebService::ILS::RecordedBooks::Patron> - services +that require patron credentials + +See L<WebService::ILS::RecordedBooks> + +=cut + +use Carp; + +use parent qw(WebService::ILS::RecordedBooks); + +=head1 CONSTRUCTOR + +=head2 new (%params_hash or $params_hashref) + +=head3 Additional constructor params: + +=over 16 + +=item C<user_id> + +=item C<password> + +=back + +=cut + +use Class::Tiny qw( + user_id password +); + +__PACKAGE__->_set_param_spec({ + user_id => { required => 1 }, + password => { required => 1 }, +}); + + +sub _access_auth_string { + my $self = shift; + return $self->client_secret; +} + +sub _extract_token_from_response { + my $self = shift; + my $data = shift; + + return ($data->{bearer}, "bearer"); +} + +sub make_access_token_request { + my $self = shift; + + my $url = $self->api_url("/tokens"); + my %params = ( + UserName => $self->user_id, + Password => $self->password, + LibraryId => $self->library_id, + ); + my $req = HTTP::Request::Common::POST( $url ); + return $self->_json_request_content($req, \%params); +} + +sub title_url { + my $self = shift; + my $isbn = shift or croak "No isbn"; + return $self->api_url("/titles/$isbn"); +} + +sub circulation_action_base_url { + my $self = shift; + + return $self->api_url("/transactions"); +} + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut diff --git a/lib/WebService/ILS/XML.pm b/lib/WebService/ILS/XML.pm new file mode 100644 index 0000000000..dd7c72359f --- /dev/null +++ b/lib/WebService/ILS/XML.pm @@ -0,0 +1,184 @@ +package WebService::ILS::XML; + +use Modern::Perl; + +=encoding utf-8 + +=head1 NAME + +WebService::ILS::JSON - WebService::ILS module for services with XML API + +=head1 DESCRIPTION + +To be subclassed + +See L<WebService::ILS> + +=cut + +use Carp; +use HTTP::Request::Common; +use URI; +use XML::LibXML; + +use parent qw(WebService::ILS); + +sub with_get_request { + my $self = shift; + my $callback = shift or croak "No callback"; + 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->_request_with_auth($request); + return $self->process_xml_response($response, $callback); +} + +sub with_delete_request { + my $self = shift; + my $callback = shift or croak "No callback"; + my $error_callback = shift; + my $url = shift or croak "No url"; + + my $request = HTTP::Request::Common::DELETE( $url ); + my $response = $self->_request_with_auth($request); + return 1 if $response->is_success; + + return $self->_error_result( + sub { $self->process_invalid_xml_response($response, $error_callback); }, + $request, + $response + ); +} + +sub with_post_request { + my $self = shift; + my $callback = shift or croak "No callback"; + my $url = shift or croak "No url"; + my $post_params = shift || {}; # hash ref + + my $request = HTTP::Request::Common::POST( $url, $post_params ); + my $response = $self->_request_with_auth($request); + return $self->process_xml_response($response, $callback); +} + +sub with_xml_request { + my $self = shift; + my $callback = shift or croak "No callback"; + my $error_callback = shift; + my $url = shift or croak "No url"; + my $dom = shift or croak "No XML document"; + my $method = shift || 'post'; + + my $req_builder = "HTTP::Request::Common::".uc( $method ); + no strict 'refs'; + my $request = $req_builder->( $url ); + $request->header( 'Content-Type' => 'application/xml; charset=utf-8' ); + $request->content( $dom->toeString ); + $request->header( 'Content-Length' => bytes::length($request->content)); + my $response = $self->_request_with_auth($request); + return $self->process_xml_response($response, $callback, $error_callback); +} + +sub process_xml_response { + my $self = shift; + my $response = shift or croak "No response"; + my $success_callback = shift; + my $error_callback = shift; + + unless ($response->is_success) { + return $self->process_xml_error_response($response, $error_callback); + } + + my $content_type = $response->header('Content-Type'); + die $response->as_string + unless $content_type && $content_type =~ m!application/xml!; + my $content = $response->decoded_content + or die $self->invalid_response_exception_string($response); + + local $@; + + my $doc = eval { XML::LibXML->load_xml( string => $content )->documentElement() }; + #XXX check XML::LibXML::Error + die "$@\nResponse:\n".$response->as_string if $@; + + return $doc unless $success_callback; + + my $res = eval { + $success_callback->($doc); + }; + die "$@\nResponse:\n$content" if $@; + return $res; +} + +sub process_xml_error_response { + my $self = shift; + my $response = shift or croak "No response"; + my $error_callback = shift; + + my $content_type = $response->header('Content-Type'); + if ($content_type && $content_type =~ m!application/xml!) { + my $content = $response->decoded_content + or die $self->invalid_response_exception_string($response); + + my $doc = eval { XML::LibXML->load_xml( string => $content )->documentElement() }; + #XXX check XML::LibXML::Error + die "$@\nResponse:\n$content" if $@; + + if ($error_callback) { + return $error_callback->($doc); + } + + die $self->_error_from_xml($doc) || "Invalid response:\n$content"; + } + die $self->invalid_response_exception_string($response); +} + +sub _error_from_xml {}; + +sub _first_child_content { + my $self = shift; + my $parent_elt = shift or croak "No parent element"; + my $tag = shift or croak "No child tag name"; + + my $child_elts = $parent_elt->getElementsByTagName($tag) or return; + my $child_elt = $child_elts->shift or return; + return $child_elt->textContent; +} + +sub _children_content { + my $self = shift; + my $parent_elt = shift or croak "No parent element"; + my $tag = shift or croak "No child tag name"; + + my $child_elts = $parent_elt->getElementsByTagName($tag) or return; + return [ $child_elts->map( sub { $_[0]->textContent } ) ]; +} + +sub _xml_to_hash { + my $self = shift; + my $parent_elt = shift or croak "No parent element"; + my $tags = shift or croak "No children tag names"; + + return { map { $_ => $self->_first_child_content($parent_elt, $_) } @$tags }; +} + +1; + +__END__ + +=head1 LICENSE + +Copyright (C) Catalyst IT NZ Ltd +Copyright (C) Bywater Solutions + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt> + +=cut -- 2.53.0