Bugzilla – Attachment 191917 Details for
Bug 41521
WebService::ILS::OverDrive not passing pl_valid
Home
|
New
|
Browse
|
Search
|
[?]
|
Reports
|
Help
|
New Account
|
Log In
[x]
|
Forgot Password
Login:
[x]
[patch]
Bug 41521: Add WebService::ILS to lib/
a34697d.patch (text/plain), 92.23 KB, created by
Jonathan Druart
on 2026-01-23 11:05:25 UTC
(
hide
)
Description:
Bug 41521: Add WebService::ILS to lib/
Filename:
MIME Type:
Creator:
Jonathan Druart
Created:
2026-01-23 11:05:25 UTC
Size:
92.23 KB
patch
obsolete
>From a34697d245d079bfdcc91fee1ece87511c66e51f Mon Sep 17 00:00:00 2001 >From: Jonathan Druart <jonathan.druart@bugs.koha-community.org> >Date: Fri, 23 Jan 2026 09:29:51 +0100 >Subject: [PATCH] Bug 41521: Add WebService::ILS to lib/ > >--- > 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 00000000000..34357a10029 >--- /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::<Provider Subclass>; >+ my $ils = WebService::ILS::<Provider Subclass>->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<WebService::ILS::OverDrive::Library> >+ >+OverDrive Library API L<https://developer.overdrive.com/discovery-apis> >+ >+=item B<WebService::ILS::OverDrive::Patron> >+ >+OverDrive Circulation API L<https://developer.overdrive.com/circulation-apis> >+ >+=back >+ >+=head1 INTERFACE >+ >+=head2 Error handling >+ >+Method calls will die on error. $@ will contain a multi-line string. >+See C<error_message()> below. >+ >+=head2 Item record >+ >+Item record is returned by many methods, so we specify it here. >+ >+=over 12 >+ >+=item C<id> >+ >+=item C<isbn> >+ >+=item C<title> >+ >+=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 00000000000..d4495a55a11 >--- /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 00000000000..27c18c40268 >--- /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 00000000000..eb2719897ae >--- /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 00000000000..f7927ce511f >--- /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 00000000000..5508f82745f >--- /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 00000000000..424398c5e53 >--- /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 00000000000..fe287a3fa66 >--- /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 00000000000..a5f39c0c688 >--- /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 00000000000..8c30b6268a9 >--- /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 00000000000..dd7c72359fb >--- /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.43.0 >
You cannot view the attachment while viewing its details because your browser does not support IFRAMEs.
View the attachment on a separate page
.
View Attachment As Diff
View Attachment As Raw
Actions:
View
|
Diff
|
Splinter Review
Attachments on
bug 41521
:
191897
|
191898
|
191899
|
191900
|
191901
|
191902
|
191903
|
191904
|
191905
|
191917
|
191918
|
191919
|
192669
|
192670
|
192671
|
192672
|
192673
|
192674
|
192675
|
192676