Bug 41521: Add WebService::ILS to lib/

Signed-off-by: Victor Grousset/tuxayo <victor@tuxayo.net>
Signed-off-by: David Cook <dcook@prosentient.com.au>
Signed-off-by: Martin Renvoize <martin.renvoize@openfifth.co.uk>

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

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

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

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

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

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

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

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

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

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

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