View | Details | Raw Unified | Return to bug 41521
Collapse All | Expand All

(-)a/lib/WebService/ILS.pm (+810 lines)
Line 0 Link Here
1
package WebService::ILS;
2
3
use Modern::Perl;
4
5
our $VERSION = "0.18";
6
7
=encoding utf-8
8
9
=head1 NAME
10
11
WebService::ILS - Standardised library discovery/circulation services
12
13
=head1 SYNOPSIS
14
15
    use WebService::ILS::<Provider Subclass>;
16
    my $ils = WebService::ILS::<Provider Subclass>->new({
17
        client_id => $client_id,
18
        client_secret => $client_secret
19
    });
20
    my %search_params = (
21
        query => "Some keyword",
22
        sort => "rating",
23
    );
24
    my $result = $ils->search(\%search_params);
25
    foreach (@{ $result->{items} }) {
26
        ...
27
    }
28
    foreach (2..$result->{pages}) {
29
        $search_params{page} = $_;
30
        my $next_results = $ils->search(\%search_params);
31
        ...
32
    }
33
34
    or
35
36
    my $native_result = $ils->native_search(\%native_search_params);
37
38
=head1 DESCRIPTION
39
40
WebService::ILS is an attempt to create a standardised interface for
41
online library services providers.
42
43
In addition, native API interface is provided.
44
45
Here we will describe constructor parameters and methods common to all
46
service providers. Diversions and native interfaces are documented
47
in corresponding modules.
48
49
=head2 Supported service providers
50
51
=over 4
52
53
=item B<WebService::ILS::OverDrive::Library>
54
55
OverDrive Library API L<https://developer.overdrive.com/discovery-apis>
56
57
=item B<WebService::ILS::OverDrive::Patron>
58
59
OverDrive Circulation API L<https://developer.overdrive.com/circulation-apis>
60
61
=back
62
63
=head1 INTERFACE
64
65
=head2 Error handling
66
67
Method calls will die on error. $@ will contain a multi-line string.
68
See C<error_message()> below.
69
70
=head2 Item record
71
72
Item record is returned by many methods, so we specify it here.
73
74
=over 12
75
76
=item C<id>
77
78
=item C<isbn>
79
80
=item C<title>
81
82
=item C<subtitle>
83
84
=item C<description>
85
86
=item C<author>
87
88
=item C<publisher>
89
90
=item C<publication_date>
91
92
=item C<language>
93
94
=item C<rating>         => user ratings metrics
95
96
=item C<popularity>     => checkout metrics
97
98
=item C<subjects>       => subject categories (tags)
99
100
=item C<facets>         => a hashref of facet => [values]
101
102
=item C<media>          => book, e-book, video, audio etc
103
104
=item C<formats>        => an arrayref of available formats
105
106
=item C<images>         => a hashref of size => url
107
108
=item C<encryption_key> => for decryption purposes
109
110
=item C<drm>            => subject to drm
111
112
=back
113
114
Not all fields are available for all service providers.
115
Field values are not standardised.
116
117
=cut
118
119
use Carp;
120
use Hash::Merge;
121
use Params::Check;
122
use LWP::UserAgent;
123
use HTTP::Status qw(:constants);
124
use MIME::Base64 qw();
125
use JSON qw(from_json);
126
127
our $DEBUG;
128
129
my %CONSTRUCTOR_PARAMS_SPEC;
130
sub _set_param_spec {
131
    my $class = shift;
132
    my $param_spec = shift;
133
134
    $CONSTRUCTOR_PARAMS_SPEC{$class} = $param_spec;
135
}
136
sub _get_param_spec {
137
    my $class = shift;
138
    if (my $ref = ref($class)) {
139
        $class = $ref;
140
    }
141
142
    my $p_s = $CONSTRUCTOR_PARAMS_SPEC{$class};
143
    return $p_s if $class eq __PACKAGE__;
144
145
    (my $superclass = $class) =~ s/::\w+$//o;
146
    return Hash::Merge::merge($p_s || {}, $superclass->_get_param_spec);
147
}
148
149
=head1 CONSTRUCTOR
150
151
=head2 new (%params_hash or $params_hashref)
152
153
=head3 Client (vendor) related constructor params, given by service provider:
154
155
=over 12
156
157
=item C<client_id>     => client (vendor) identifier
158
159
=item C<client_secret> => secret key (password)
160
161
=item C<library_id>    => sometimes service providers provide access
162
                          to differnt "libraries"
163
164
=back
165
166
=head3 General constructor params:
167
168
=over 12
169
170
=item C<user_agent>        => LWP::UserAgent or a derivative;
171
                              usually not needed, one is created for you.
172
173
=item C<user_agent_params> => LWP::UserAgent constructor params
174
                              so you don't need to create user agent yourself
175
176
=item C<access_token>      => as returned from the provider authentication system
177
178
=item C<access_token_type> => as returned from the provider authentication system
179
180
=back
181
182
These are also read-only attributes
183
184
Not all of client/library params are required for all service providers.
185
186
=cut
187
188
use Class::Tiny qw(
189
    user_agent
190
    client_id client_secret library_id
191
    access_token access_token_type
192
);
193
194
__PACKAGE__->_set_param_spec({
195
    client_id         => { required => 1, defined => 1 },
196
    client_secret     => { required => 1, defined => 1 },
197
    library_id        => { required => 0, defined => 1 },
198
    access_token      => { required => 0 },
199
    access_token_type => { required => 0 },
200
    user_agent        => { required => 0 },
201
    user_agent_params => { required => 0 },
202
});
203
204
sub BUILDARGS {
205
    my $self = shift;
206
    my $params = shift || {};
207
    if (!ref( $params )) {
208
        $params = {$params, @_};
209
    }
210
211
    local $Params::Check::WARNINGS_FATAL = 1;
212
    $params = Params::Check::check($self->_get_param_spec, $params)
213
        or croak "Invalid parameters: ".Params::Check::last_error();
214
    return $params;
215
}
216
217
sub BUILD {
218
    my $self = shift;
219
    my $params = shift;
220
221
    my $ua_params = delete $params->{user_agent_params} || {};
222
    $self->user_agent( LWP::UserAgent->new(%$ua_params) ) unless $self->user_agent;
223
    delete $self->{user_agent_params};
224
}
225
226
=head1 ATTRIBUTES
227
228
=head2 user_agent
229
230
As provided to constructor, or auto created. Useful if one wants to
231
change user agent attributes on the fly, eg 
232
233
    $ils->user_agent->timeout(120);
234
235
=head1 DISCOVERY METHODS
236
237
=head2 search ($params_hashref)
238
239
=head3 Input params:
240
241
=over 12
242
243
=item C<query>     => query (search) string
244
245
=item C<page_size> => number of items per results page
246
247
=item C<page>      => wanted page number
248
249
=item C<sort>      => resultset sort option (see below)
250
251
=back
252
253
Sort  options are either an array or a comma separated string of options:
254
255
=over 12
256
257
=item C<publication_date> => date title was published
258
259
=item C<available_date>   => date title became available for users
260
261
=item C<rating>           => number of items per results page
262
263
=back
264
265
Sort order can be added after option with ":", eg
266
"publication_date:desc,rating:desc"
267
268
=head3 Returns search results record:
269
270
=over 12
271
272
=item C<items>      => an array of item records
273
274
=item C<page_size>  => number of items per results page
275
276
=item C<page>       => results page number
277
278
=item C<pages>      => total number of pages
279
280
=item C<total>      => total number of items found by the search
281
282
=back
283
284
=head2 item_metadata ($item_id)
285
286
=head3 Returns item record
287
288
=head2 item_availability ($item_id)
289
290
=head3 Returns item availability record:
291
292
=over 12
293
294
=item C<id>
295
296
=item C<available>        => boolean
297
298
=item C<copies_available> => number of copies available
299
300
=item C<copies_owned>     => number of copies owned
301
302
=item C<type>             => availability type, provider dependant
303
304
=back
305
306
Not all fields are available for all service providers.
307
For example, some will provide "copies_available", making "available"
308
redundant, whereas others will just provide "available".
309
310
=head2 is_item_available ($item_id)
311
312
=head3 Returns boolean
313
314
Simplified version of L<item_availability()>
315
316
=cut
317
318
sub search {
319
    die "search() not implemented";
320
}
321
322
# relevancy availability available_date title author popularity rating price publisher publication_date
323
sub _parse_sort_string {
324
    my $self = shift;
325
    my $sort = shift or croak "No sort options";
326
    my $xlate_table = shift || {};
327
    my $camelise = shift;
328
329
    $sort = [split /\s*,\s*/, $sort] unless ref $sort;
330
331
    foreach (@$sort) {
332
        my ($s,$d) = split ':';
333
        if (exists $xlate_table->{$s}) {
334
            next unless $xlate_table->{$s};
335
            $_ = $xlate_table->{$s};
336
        }
337
        else {
338
            $_ = $s;
339
        }
340
        #   join('', map{ ucfirst $_ } split(/(?<=[A-Za-z])_(?=[A-Za-z])|\b/, $s));
341
        $_ = join '', map ucfirst, split /(?<=[A-Za-z])_(?=[A-Za-z])|\b/ if $camelise;
342
        $_ = "$_:$d" if $d;
343
    }
344
345
    return $sort;
346
}
347
348
sub item_metadata {
349
    die "item_metadata() not implemented";
350
}
351
352
sub item_availability {
353
    die "item_availability() not implemented";
354
}
355
356
=head1 INDIVIDUAL USER AUTHENTICATION AND METHODS
357
358
=head2 user_id / password
359
360
Provider authentication API is used to get an authorized session.
361
362
=head3 auth_by_user_id($user_id, $password)
363
364
An example:
365
366
    my $ils = WebService::ILS::Provider({
367
        client_id => $client_id,
368
        client_secret => $client_secret,
369
    });
370
    eval { $ils->auth_by_user_id( $user_id, $password ) };
371
    if ($@) { some_error_handling(); return; }
372
    $session{ils_access_token} = $ils->access_token;
373
    $session{ils_access_token_type} = $ils->access_token_type;
374
    ...
375
    Somewhere else in your app:
376
    my $ils = WebService::ILS::Provider({
377
        client_id => $client_id,
378
        client_secret => $client_secret,
379
        access_token => $session{ils_access_token},
380
        access_token_type => $session{ils_access_token_type},
381
    });
382
 
383
    my $checkouts = $ils->checkouts;
384
385
=head2 Authentication at the provider
386
387
User is redirected to the provider authentication url, and after
388
authenticating at the provider redirected back with some kind of auth token.
389
Requires url to handle return redirect from the provider.
390
391
It can be used as an alternative to FB and Google auth.
392
393
This is just to give an idea, specifics heavily depend on the provider
394
395
=head3 auth_url ($redirect_back_uri)
396
397
Returns provider authentication url to redirect to
398
399
=head3 auth_token_param_name ()
400
401
Returns auth code url param name
402
403
=head3 auth_by_token ($provider_token)
404
405
An example:
406
407
    my $ils = WebService::ILS::Provider({
408
        client_id => $client_id,
409
        client_secret => $client_secret,
410
    });
411
    my $redirect_url = $ils->auth_url("http://myapp.com/ils-auth");
412
    $response->redirect($redirect_url);
413
    ...
414
    After successful authentication at the provider, provider redirects
415
    back to specified app url (http://myapp.com/ils-auth)
416
417
    /ils-auth handler:
418
    my $auth_token = $req->param( $ils->auth_token_param_name )
419
        or some_error_handling(), return;
420
    local $@;
421
    eval { $ils->auth_by_token( $auth_token ) };
422
    if ($@) { some_error_handling(); return; }
423
    $session{ils_access_token} = $ils->access_token;
424
    $session{ils_access_token_type} = $ils->access_token_type;
425
    ...
426
    Somewhere else in your app:
427
    passing access token to the constructor as above
428
429
=cut
430
431
=head1 CIRCULATION METHODS
432
433
=head2 patron ()
434
435
=head3 Returns patron record:
436
437
=over 12
438
439
=item C<id>
440
441
=item C<active>            => boolean
442
443
=item C<copies_available>  => number of copies available
444
445
=item C<checkout_limit>    => number of checkouts allowed
446
447
=item C<hold_limit>        => number of holds allowed
448
449
=back
450
451
=head2 holds ()
452
453
=head3 Returns holds record:
454
455
=over 12
456
457
=item C<total>             => number of items on hold
458
459
=item C<items>             => list of individual items
460
461
=back
462
463
In addition to Item record fields described above,
464
item records will have:
465
466
=over 12
467
468
=item C<placed_datetime>   => hold timestamp, with or without timezone
469
470
=item C<queue_position>    => user's position in the waiting queue,
471
                              if available
472
473
=back
474
475
=head2 place_hold ($item_id)
476
477
=head3 Returns holds item record (as described above)
478
479
In addition, C<total> field will be incorported as well.
480
481
=head2 remove_hold ($item_id)
482
483
=head3 Returns true to indicate success
484
485
Returns true in case user does not have a hold on the item.
486
Throws exception in case of any other failure.
487
488
=head2 checkouts ()
489
490
=head3 Returns checkout record:
491
492
=over 12
493
494
=item C<total>             => number of items on hold
495
496
=item C<items>             => list of individual items
497
498
=back
499
500
In addition to Item record fields described above,
501
item records will have:
502
503
=over 12
504
505
=item C<checkout_datetime> => checkout timestamp, with or without timezone
506
507
=item C<expires>           => date (time) checkout expires
508
509
=item C<url>               => download/stream url
510
511
=item C<files>             => an arrayref of downloadable file details
512
                              title, url, size
513
514
=back
515
516
=head2 checkout ($item_id)
517
518
=head3 Returns checkout item record (as described above)
519
520
In addition, C<total> field will be incorported as well.
521
522
=head2 return ($item_id)
523
524
=head3 Returns true to indicate success
525
526
Returns true in case user does not have the item checked out.
527
Throws exception in case of any other failure.
528
529
=cut
530
531
=head1 NATIVE METHODS
532
533
All Discovery and Circulation methods (with exception of remove_hold()
534
and return(), where it does not make sense) have native_*() counterparts,
535
eg native_search(), native_item_availability(), native_checkout() etc.
536
537
In case of single item methods, native_item_availability(),
538
native_checkout() etc, they take item_id as parameter. Otherwise, it's a
539
hashref of HTTP request params (GET or POST).
540
541
Return value is a record as returned by API.
542
543
Individual provider subclasses provide additional provider specific
544
native methods.
545
546
=head1 UTILITY METHODS
547
548
=head2 Error constants
549
550
=over 4
551
552
=item C<ERROR_ACCESS_TOKEN>
553
554
=item C<ERROR_NOT_AUTHENTICATED>
555
556
=back
557
558
=cut
559
560
use constant ERROR_ACCESS_TOKEN => "Error: Authorization Failed";
561
use constant ERROR_NOT_AUTHENTICATED => "Error: User Not Authenticated";
562
563
sub invalid_response_exception_string {
564
    my $self = shift;
565
    my $response = shift;
566
567
    return join "\n",
568
        $response->message,
569
        "Request:" => $response->request->as_string,
570
        "Response:" => $response->as_string
571
    ;
572
}
573
574
sub check_response {
575
    my $self = shift;
576
    my $response = shift;
577
578
    die $self->invalid_response_exception_string($response) unless $response->is_success;
579
}
580
581
=head2 error_message ($exception_string)
582
583
=head3 Returns error message probably suitable for displaying to the user
584
585
Example:
586
587
    my $res = eval { $ils->checkout($id) }; 
588
    if ($@) {
589
        my $msg = $ils->error_message($@);
590
        display($msg);
591
        log_error($@);
592
    }
593
594
=head2 is_access_token_error ($exception_string)
595
596
=head3 Returns true if the error is access token related
597
598
=head2 is_not_authenticated_error ($exception_string)
599
600
=head3 Returns true if the error is "Not authenticated"
601
602
=cut
603
604
sub error_message {
605
    my $self = shift;
606
    my $die_string = shift or return;
607
    $die_string =~ m/(.*?)\n/o;
608
    (my $msg = $1 || $die_string) =~ s! at /.* line \d+\.$!!;
609
    return $msg;
610
}
611
612
sub is_access_token_error {
613
    my $self = shift;
614
    my $die_string = shift or croak "No error message";
615
    return $self->error_message($die_string) eq ERROR_ACCESS_TOKEN;
616
}
617
618
sub is_not_authenticated_error {
619
    my $self = shift;
620
    my $die_string = shift or croak "No error message";
621
    return $self->error_message($die_string) eq ERROR_NOT_AUTHENTICATED;
622
}
623
624
# Client access authorization
625
#
626
sub _request_with_auth {
627
    my $self = shift;
628
    my $request = shift or croak "No request";
629
630
    my $has_token = $self->access_token;
631
    my $response = $self->_request_with_token($request);
632
    # token expired?
633
    $response = $self->_request_with_token($request, "FRESH TOKEN")
634
      if $response->code == HTTP_UNAUTHORIZED && $has_token;
635
    return $response;
636
}
637
638
sub make_access_token_request {
639
    die "make_access_token_request() not implemented";
640
}
641
642
sub _request_access_token {
643
    my $self = shift;
644
    my $request = shift or croak "No request";
645
646
    $request->header(
647
        Authorization => "Basic " . $self->_access_auth_string
648
    );
649
650
    my $response = $self->user_agent->request( $request );
651
    # XXX check content type
652
    return $self->process_json_response(
653
        $response,
654
        sub {
655
            my ($data) = @_;
656
657
            my ($token, $token_type) = $self->_extract_token_from_response($data);
658
            $token or die "No access token\n";
659
            $self->access_token($token);
660
            $self->access_token_type($token_type || 'Bearer');
661
            return $data;
662
        },
663
        sub {
664
            my ($data) = @_;
665
666
            die join "\n", ERROR_ACCESS_TOKEN, $self->_error_from_json($data) || $response->decoded_content;
667
        }
668
    );
669
}
670
671
sub _access_auth_string {
672
    my $self = shift;
673
    return MIME::Base64::encode( join(":", $self->client_id, $self->client_secret) );
674
}
675
676
sub _extract_token_from_response {
677
    my $self = shift;
678
    my $data = shift;
679
680
    return ($data->{access_token}, $data->{token_type});
681
}
682
683
sub _request_with_token {
684
    my $self = shift;
685
    my $request = shift or croak "No request";
686
    my $force_fresh = shift;
687
688
    my $token = $force_fresh ? undef : $self->access_token;
689
    unless ($token) {
690
        my $request = $self->make_access_token_request;
691
        $self->_request_access_token($request);
692
        $token = $self->access_token;
693
    }
694
    die "No access token" unless $token;
695
    my $token_type = $self->access_token_type;
696
697
    $request->header( Authorization => "$token_type $token" );
698
    return $self->user_agent->request( $request );
699
}
700
701
# Strictly speaking process_json_response() and process_json_error_response()
702
# should go to ::JSON. However, JSON is used for authentication services even for
703
# APIs that are XML, so need to be available
704
sub process_json_response {
705
    my $self = shift;
706
    my $response = shift or croak "No response";
707
    my $success_callback = shift;
708
    my $error_callback = shift;
709
710
    unless ($response->is_success) {
711
        return $self->process_json_error_response($response, $error_callback);
712
    }
713
714
    my $content_type = $response->header('Content-Type');
715
    die "Invalid Content-Type\n".$response->as_string
716
        unless $content_type && $content_type =~ m!application/json!;
717
    my $content = $response->decoded_content
718
        or die $self->invalid_response_exception_string($response);
719
720
    local $@;
721
722
    my $data = $content ? eval { from_json( $content ) } : {};
723
    die "$@\nResponse:\n".$response->as_string if $@;
724
725
    return $data unless $success_callback;
726
727
    my $res = eval {
728
        $success_callback->($data);
729
    };
730
    die "$@\nResponse:\n$content" if $@;
731
    return $res;
732
}
733
734
sub process_json_error_response {
735
    my $self = shift;
736
    my $response = shift or croak "No response";
737
    my $error_callback = shift;
738
739
    my $content_type = $response->header('Content-Type');
740
    if ($content_type && $content_type =~ m!application/json!) {
741
        my $content = $response->decoded_content
742
            or die $self->invalid_response_exception_string($response);
743
744
        my $data = eval { from_json( $content ) };
745
        die $content || $self->invalid_response_exception_string($response) if $@;
746
747
        if ($error_callback) {
748
            return $error_callback->($data);
749
        }
750
751
        die $self->_error_from_json($data) || "Invalid response:\n$content";
752
    }
753
    die $self->invalid_response_exception_string($response);
754
}
755
756
sub _error_from_json {};
757
758
# wrapper around error response handlers to include some debugging if the debug flag is set
759
sub _error_result {
760
    my $self = shift;
761
    my $process_sub = shift or croak "No process sub";
762
    my $request = shift or croak "No HTTP request";
763
    my $response = shift or croak "No HTTP response";
764
765
    return $process_sub->() unless $DEBUG;
766
767
    local $@;
768
    my $ret = eval { $process_sub->() };
769
    die join "\n", $@, "Request:", $request->as_string, "Response:", $response->as_string
770
        if $@;
771
    return $ret;
772
}
773
774
sub _result_xlate {
775
    my $self = shift;
776
    my $res = shift;
777
    my $xlate_table = shift;
778
779
    return {
780
        map {
781
            my $val = $res->{$_};
782
            defined($val) ? ($xlate_table->{$_} => $val) : ()
783
        } keys %$xlate_table
784
    };
785
}
786
787
788
=head1 TODO
789
790
Federated search
791
792
=cut
793
794
1;
795
796
__END__
797
798
=head1 LICENSE
799
800
Copyright (C) Catalyst IT NZ Ltd
801
Copyright (C) Bywater Solutions
802
803
This library is free software; you can redistribute it and/or modify
804
it under the same terms as Perl itself.
805
806
=head1 AUTHOR
807
808
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
809
810
=cut
(-)a/lib/WebService/ILS/JSON.pm (+141 lines)
Line 0 Link Here
1
package WebService::ILS::JSON;
2
3
use Modern::Perl;
4
5
=encoding utf-8
6
7
=head1 NAME
8
9
WebService::ILS::JSON - WebService::ILS module for services with JSON API
10
11
=head1 DESCRIPTION
12
13
To be subclassed
14
15
See L<WebService::ILS>
16
17
=cut
18
19
use Carp;
20
use HTTP::Request::Common;
21
use JSON qw(encode_json);
22
use URI;
23
24
use parent qw(WebService::ILS);
25
26
sub with_get_request {
27
    my $self = shift;
28
    my $callback = shift or croak "No callback";
29
    my $url = shift or croak "No url";
30
    my $get_params = shift; # hash ref
31
32
    my $uri = URI->new($url);
33
    $uri->query_form($get_params) if $get_params;
34
    my $request = HTTP::Request::Common::GET( $uri );
35
    my $response = $self->_request_with_auth($request);
36
    return $self->process_json_response($response, $callback);
37
}
38
39
sub with_delete_request {
40
    my $self = shift;
41
    my $callback = shift or croak "No callback";
42
    my $error_callback = shift;
43
    my $url = shift or croak "No url";
44
45
    my $request = HTTP::Request::Common::DELETE( $url );
46
    my $response = $self->_request_with_auth($request);
47
    return $response->content ? $self->process_json_response($response, $callback) : 1
48
      if $response->is_success;
49
50
    return $self->_error_result(
51
        sub { $self->process_json_error_response($response, $error_callback); },
52
        $request,
53
        $response
54
    );
55
}
56
57
sub with_post_request {
58
    my $self = shift;
59
    my $callback = shift or croak "No callback";
60
    my $url = shift or croak "No url";
61
    my $post_params = shift || {}; # hash ref
62
63
    my $request = HTTP::Request::Common::POST( $url, $post_params );
64
    my $response = $self->_request_with_auth($request);
65
    return $self->process_json_response($response, $callback);
66
}
67
68
# This will probably not suit everyone
69
sub with_put_request {
70
    my $self = shift;
71
    my $callback = shift or croak "No callback";
72
    my $url = shift or croak "No url";
73
    my $put_params = shift;
74
75
    my $request = HTTP::Request::Common::PUT( $url );
76
    my $content;
77
    if ($put_params) {
78
        my $url = URI->new('http:');
79
        $url->query_form(ref($put_params) eq "HASH" ? %$put_params : @$put_params);
80
        $content = $url->query;
81
    }
82
    if( $content ) {
83
        # HTML/4.01 says that line breaks are represented as "CR LF" pairs (i.e., `%0D%0A')
84
        $content =~ s/(?<!%0D)%0A/%0D%0A/go;
85
86
        $request->content_type("application/x-www-form-urlencoded");
87
        $request->content_length(length $content);
88
        $request->content($content);
89
    }
90
    else {
91
        $request->content_length(0);
92
    }
93
94
    my $response = $self->_request_with_auth($request);
95
    return $self->process_json_response($response, $callback);
96
}
97
98
sub with_json_request {
99
    my $self = shift;
100
    my $callback = shift or croak "No callback";
101
    my $error_callback = shift;
102
    my $url = shift or croak "No url";
103
    my $post_params = shift || {}; # hashref
104
    my $method = shift || 'post';
105
106
    my $req_builder = "HTTP::Request::Common::".uc( $method );
107
    no strict 'refs';
108
    my $request = $req_builder->( $url );
109
    $self->_json_request_content($request, $post_params);
110
    my $response = $self->_request_with_auth($request);
111
    return $self->process_json_response($response, $callback, $error_callback);
112
}
113
114
sub _json_request_content {
115
    my $self = shift;
116
    my $request = shift or croak "No request";
117
    my $data = shift or croak "No data"; # hashref
118
119
    $request->header( 'Content-Type' => 'application/json; charset=utf-8' );
120
    $request->content( encode_json($data) );
121
    $request->header( 'Content-Length' => bytes::length($request->content));
122
    return $request;
123
}
124
125
1;
126
127
__END__
128
129
=head1 LICENSE
130
131
Copyright (C) Catalyst IT NZ Ltd
132
Copyright (C) Bywater Solutions
133
134
This library is free software; you can redistribute it and/or modify
135
it under the same terms as Perl itself.
136
137
=head1 AUTHOR
138
139
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
140
141
=cut
(-)a/lib/WebService/ILS/OverDrive.pm (+383 lines)
Line 0 Link Here
1
package WebService::ILS::OverDrive;
2
3
use Modern::Perl;
4
5
=encoding utf-8
6
7
=head1 NAME
8
9
WebService::ILS::OverDrive - WebService::ILS module for OverDrive services
10
11
=head1 SYNOPSIS
12
13
    use WebService::ILS::OverDrive::Library;
14
    or
15
    use WebService::ILS::OverDrive::Patron;
16
17
=head1 DESCRIPTION
18
19
L<WebService::ILS::OverDrive::Library> - anonymous discovery
20
services - no individual user credentials required
21
22
L<WebService::ILS::OverDrive::Patron> - discovery and circulation
23
services that require individual user credentials
24
25
See L<WebService::ILS>
26
27
=cut
28
29
use Carp;
30
use HTTP::Request::Common;
31
use URI::Escape;
32
33
use parent qw(WebService::ILS::JSON);
34
35
use constant API_VERSION => "v1";
36
37
use constant DISCOVERY_API_URL => "http://api.overdrive.com/";
38
use constant TEST_DISCOVERY_API_URL => "http://integration.api.overdrive.com/";
39
40
=head1 CONSTRUCTOR
41
42
=head2 new (%params_hash or $params_hashref)
43
44
=head3 Additional constructor params:
45
46
=over 10
47
48
=item C<test> => if set to true use OverDrive test API urls
49
50
=back
51
52
=cut
53
54
use Class::Tiny qw(
55
    collection_token
56
    test
57
), {
58
    _discovery_api_url => sub { $_[0]->test ? TEST_DISCOVERY_API_URL : DISCOVERY_API_URL },
59
};
60
61
__PACKAGE__->_set_param_spec({
62
    test       => { required => 0 },
63
});
64
65
=head1 DISCOVERY METHODS
66
67
=head2 search ($params_hashref)
68
69
=head3 Additional input params:
70
71
=over 16
72
73
=item C<no_details> => if true, no metadata calls will be made for result items;
74
75
only id, title, rating and media will be available
76
77
=back
78
79
=cut
80
81
my %SORT_XLATE = (
82
    available_date => "dateadded",
83
    rating => "starrating",
84
    publication_date => undef, # not available
85
);
86
sub search {
87
    my $self = shift;
88
    my $params = shift || {};
89
90
    my $short_response = delete $params->{no_details};
91
92
    my $url = $self->products_url;
93
94
    if (my $query = delete $params->{query}) {
95
        $query = join " ", @$query if ref $query;
96
        $params->{q} = $query;
97
    }
98
    my $page_size = delete $params->{page_size};
99
    $params->{limit} = $page_size if $page_size;
100
    if (my $page_number = delete $params->{page}) {
101
        croak "page_size must be specified for paging" unless $params->{limit};
102
        $params->{offset} = ($page_number - 1)*$page_size;
103
    }
104
    if (my $sort = delete $params->{sort}) {
105
        $params->{sort} = join ",", @{ $self->_parse_sort_string($sort, \%SORT_XLATE) };
106
    }
107
    $params->{formats} = join ",", @{$params->{formats}} if ref $params->{formats};
108
109
    my $res = $self->get_response($url, $params);
110
    my @items;
111
    foreach (@{$res->{products} || []}) {
112
        my $item;
113
        if ($short_response) {
114
            $item = $self->_item_xlate($_);
115
        } else {
116
            my $native_metadata = $self->native_item_metadata($_) or next;
117
            $item = $self->_item_metadata_xlate($native_metadata);
118
        }
119
        next unless $item;
120
        push @items, $item;
121
    }
122
    my $tot = $res->{totalItems};
123
    my %ret = (
124
        total => $tot,
125
        items => \@items,
126
    );
127
    if (my $page_size = $res->{limit}) {
128
        my $pages = int($tot/$page_size);
129
        $pages++ if $tot > $page_size*$pages;
130
        $ret{pages} = $pages;
131
        $ret{page_size} = $page_size;
132
        $ret{page} = $res->{offset}/$page_size + 1;
133
    }
134
    return \%ret;
135
}
136
137
my %SEARCH_RESULT_ITEM_XLATE = (
138
    id => "id",
139
    title => "title",
140
    subtitle => "subtitle",
141
    starRating => "rating",
142
    mediaType => "media",
143
);
144
sub _item_xlate {
145
    my $self = shift;
146
    my $item = shift;
147
148
    my $std_item = $self->_result_xlate($item, \%SEARCH_RESULT_ITEM_XLATE);
149
150
    if (my $formats = $item->{formats}) {
151
        $std_item->{formats} = [map $_->{id}, @$formats];
152
    }
153
154
    if (my $images = $item->{images}) {
155
        $std_item->{images} = {map { $_ => $images->{$_}{href} } keys %$images};
156
    }
157
158
    # XXX
159
    #if (my $details = $item->{contentDetails}) {
160
    #    $std_item->{details_url} = $details->{href};
161
    #}
162
163
    return $std_item;
164
}
165
166
my %METADATA_XLATE = (
167
    id => "id",
168
    mediaType => "media",
169
    title => "title",
170
    publisher => "publisher",
171
    shortDescription => "subtitle",
172
    starRating => "rating",
173
    popularity => "popularity",
174
);
175
sub item_metadata {
176
    my $self = shift;
177
    my $id = shift or croak "No item id";
178
    my $native_metadata = $self->get_response($self->products_url."/$id/metadata");
179
    return $self->_item_metadata_xlate($native_metadata);
180
}
181
182
sub _item_metadata_xlate {
183
    my $self = shift;
184
    my $metadata = shift or croak "No native metadata";
185
186
    my $item = $self->_result_xlate($metadata, \%METADATA_XLATE);
187
188
    my @authors;
189
    foreach (@{ $metadata->{creators} }) {
190
        push @authors, $_->{name} if $_->{role} eq "Author";
191
    }
192
    $item->{author} = join ", ", @authors;
193
194
    if (my $images = $metadata->{images}) {
195
        $item->{images} = {map { $_ => $images->{$_}{href} } keys %$images};
196
    }
197
198
    if (my $languages = $metadata->{languages}) {
199
        $item->{languages} = [map $_->{name}, @$languages];
200
    }
201
202
    if (my $subjects = $metadata->{subjects}) {
203
        $item->{subjects} = [map $_->{value}, @$subjects];
204
    }
205
206
    if (my $formats = $metadata->{formats}) {
207
        $item->{formats} = [map $_->{id}, @$formats];
208
    }
209
210
    return $item;
211
}
212
213
my %AVAILABILITY_RESULT_XLATE = (
214
    id => "id",
215
    available => "available",
216
    copiesAvailable => "copies_available",
217
    copiesOwned => "copies_owned",
218
    availabilityType => "type",
219
);
220
sub item_availability {
221
    my $self = shift;
222
    my $id = shift or croak "No item id";
223
    return $self->_result_xlate(
224
        $self->get_response($self->products_url."/$id/availability"),
225
        \%AVAILABILITY_RESULT_XLATE
226
    );
227
}
228
229
sub is_item_available {
230
    my $self = shift;
231
    my $id = shift or croak "No item id";
232
    my $type = shift;
233
234
    my $availability = $self->item_availability($id) or return;
235
    return unless $availability->{available};
236
    return !$type || $type eq $availability->{type};
237
}
238
239
=head1 NATIVE METHODS
240
241
=head2 native_search ($params_hashref)
242
243
See L<https://developer.overdrive.com/apis/search>
244
245
=head2 native_search_[next|prev|first|last] ($data_as returned_by_native_search*)
246
247
For iterating through search result pages. Each native_search_*() method
248
accepts record returned by any native_search*() method as input.
249
250
Example:
251
252
    my $res = $od->native_search({q => "Dogs"});
253
    while ($res) {
254
        do_something($res);
255
        $res = $od->native_search_next($res);
256
    }
257
    or
258
    my $res = $od->native_search({q => "Dogs"});
259
    my $last = $od->native_search_last($res);
260
    my $next_to_last = $od->native_search_prev($last);
261
    my $first = $od->native_search_first($next_to_last)
262
    # Same as $od->native_search_first($last)
263
    # Same as $res
264
265
=cut
266
267
# params: q, limit, offset, formats, sort ? availability
268
sub native_search {
269
    my $self = shift;
270
    my $search_params = shift;
271
272
    return $self->get_response($self->products_url, $search_params);
273
}
274
275
foreach my $f (qw(next prev first last)) {
276
    no strict 'refs';
277
    my $method = "native_search_$f";
278
    *$method = sub {
279
        my $self = shift;
280
        my $search_data = shift or croak "No search result data";
281
        my $url = _extract_link($search_data, $f) or return;
282
        return $self->get_response($url);
283
    }
284
}
285
286
# Item API
287
288
=head2 native_item_metadata ($item_data as returned by native_search*)
289
290
=head2 native_item_availability ($item_data as returned by native_search*)
291
292
Example:
293
294
    my $res = $od->native_search({q => "Dogs"});
295
    foreach (@{ $res->{products} }) {
296
        my $meta = $od->native_item_metadata($_);
297
        my $availability = $od->native_item_availability($_);
298
        ...
299
    }
300
301
=cut
302
303
sub native_item_metadata {
304
    my $self = shift;
305
    my $item = shift or croak "No item record";
306
307
    my $url = _extract_link($item, 'metadata') or die "No metadata link\n";
308
    return $self->get_response($url);
309
}
310
311
sub native_item_availability {
312
    my $self = shift;
313
    my $item = shift or croak "No item record";
314
    return $self->get_response(_extract_link($item, 'availability'));
315
}
316
317
# Discovery helpers
318
319
sub discovery_action_url {
320
    my $self = shift;
321
    my $action = shift;
322
    return $self->_discovery_api_url.$self->API_VERSION.$action;
323
}
324
325
sub products_url {
326
    my $self = shift;
327
328
    my $collection_token = $self->collection_token or die "No collection token";
329
330
    if ($collection_token) {
331
        return $self->_discovery_api_url.$self->API_VERSION."/collections/$collection_token/products";
332
    }
333
}
334
335
# API helpers
336
337
sub _extract_link {
338
    my ($data, $link) = @_;
339
    my $href = $data->{links}{$link}{href}
340
        or croak "No '$link' url in data";
341
}
342
343
# Utility methods
344
345
sub _basic_callback { return $_[0]; }
346
347
# This is not exatly how we meant to use with_get_request()
348
# ie processing should be placed within the callback.
349
# However, if all goes well, it is faster (from the development perspective)
350
# this way.
351
sub get_response {
352
    my $self = shift;
353
    my $url = shift or croak "No url";
354
    my $get_params = shift; # hash ref
355
356
    return $self->with_get_request(\&_basic_callback, $url, $get_params);
357
}
358
359
sub _error_from_json {
360
    my $self = shift;
361
    my $data = shift or croak "No json data";
362
    my $error = join " ", grep defined($_), $data->{errorCode}, $data->{error_description} || $data->{error} || $data->{message} || $data->{Message};
363
    $error = "$error\n" if $error; # strip code line when dying
364
    return $error;
365
}
366
367
1;
368
369
__END__
370
371
=head1 LICENSE
372
373
Copyright (C) Catalyst IT NZ Ltd
374
Copyright (C) Bywater Solutions
375
376
This library is free software; you can redistribute it and/or modify
377
it under the same terms as Perl itself.
378
379
=head1 AUTHOR
380
381
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
382
383
=cut
(-)a/lib/WebService/ILS/OverDrive/Library.pm (+93 lines)
Line 0 Link Here
1
package WebService::ILS::OverDrive::Library;
2
3
use Modern::Perl;
4
5
=encoding utf-8
6
7
=head1 NAME
8
9
WebService::ILS::OverDrive::Library - WebService::ILS module for OverDrive
10
discovery only services
11
12
=head1 SYNOPSIS
13
14
    use WebService::ILS::OverDrive::Library;
15
16
=head1 DESCRIPTION
17
18
See L<WebService::ILS::OverDrive>
19
20
=cut
21
22
use Carp;
23
use HTTP::Request::Common;
24
25
use parent qw(WebService::ILS::OverDrive);
26
27
__PACKAGE__->_set_param_spec({
28
    library_id        => { required => 1, defined => 1 },
29
});
30
31
sub make_access_token_request {
32
    my $self = shift;
33
34
    return HTTP::Request::Common::POST( 'https://oauth.overdrive.com/token', {
35
        grant_type => 'client_credentials'
36
    } );
37
}
38
39
sub collection_token {
40
    my $self = shift;
41
42
    if (my $collection_token = $self->SUPER::collection_token) {
43
        return $collection_token;
44
    }
45
    
46
    $self->native_library_account;
47
    my $collection_token = $self->SUPER::collection_token
48
      or die "Library has no collections\n";
49
    return $collection_token;
50
}
51
52
=head1 NATIVE METHODS
53
54
=head2 native_library_account ()
55
56
See L<https://developer.overdrive.com/apis/library-account>
57
58
=cut
59
60
sub native_library_account {
61
    my $self = shift;
62
63
    my $library = $self->get_response($self->library_url);
64
    if (my $collection_token = $library->{collectionToken}) {
65
        $self->SUPER::collection_token( $collection_token);
66
    }
67
    return $library;
68
}
69
70
# Discovery helpers
71
72
sub library_url {
73
    my $self = shift;
74
    return $self->discovery_action_url("/libraries/".$self->library_id);
75
}
76
77
1;
78
79
__END__
80
81
=head1 LICENSE
82
83
Copyright (C) Catalyst IT NZ Ltd
84
Copyright (C) Bywater Solutions
85
86
This library is free software; you can redistribute it and/or modify
87
it under the same terms as Perl itself.
88
89
=head1 AUTHOR
90
91
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
92
93
=cut
(-)a/lib/WebService/ILS/OverDrive/Patron.pm (+777 lines)
Line 0 Link Here
1
# Copyright 2015 Catalyst
2
3
package WebService::ILS::OverDrive::Patron;
4
5
use Modern::Perl;
6
7
=encoding utf-8
8
9
=head1 NAME
10
11
WebService::ILS::OverDrive::Patron - WebService::ILS module for OverDrive
12
circulation services
13
14
=head1 SYNOPSIS
15
16
    use WebService::ILS::OverDrive::Patron;
17
18
=head1 DESCRIPTION
19
20
These services require individual user credentials.
21
See L<WebService::ILS INDIVIDUAL USER AUTHENTICATION AND METHODS>
22
23
See L<WebService::ILS::OverDrive>
24
25
=cut
26
27
use Carp;
28
use HTTP::Request::Common;
29
use URI::Escape;
30
use Data::Dumper;
31
32
use parent qw(WebService::ILS::OverDrive);
33
34
use constant CIRCULATION_API_URL => "http://patron.api.overdrive.com/";
35
use constant TEST_CIRCULATION_API_URL => "http://integration-patron.api.overdrive.com/";
36
use constant OAUTH_BASE_URL => "https://oauth.overdrive.com/";
37
use constant TOKEN_URL => OAUTH_BASE_URL . 'token';
38
use constant AUTH_URL => OAUTH_BASE_URL . 'auth';
39
40
=head1 CONSTRUCTOR
41
42
=head2 new (%params_hash or $params_hashref)
43
44
=head3 Additional constructor params:
45
46
=over 16
47
48
=item C<auth_token> => auth token as previously obtained
49
50
=back
51
52
=cut
53
54
use Class::Tiny qw(
55
    user_id password website_id authorization_name
56
    auth_token
57
), {
58
    _circulation_api_url => sub { $_[0]->test ? TEST_CIRCULATION_API_URL : CIRCULATION_API_URL },
59
};
60
61
__PACKAGE__->_set_param_spec({
62
    auth_token      => { required => 0 },
63
});
64
65
=head1 INDIVIDUAL USER AUTHENTICATION METHODS
66
67
=head2 auth_by_user_id ($user_id, $password, $website_id, $authorization_name)
68
69
C<website_id> and C<authorization_name> (domain) are provided by OverDrive
70
71
=head3 Returns (access_token, access_token_type) or access_token
72
73
=cut
74
75
sub auth_by_user_id {
76
    my $self = shift;
77
    my $user_id = shift or croak "No user id";
78
    my $password = shift; # can be blank
79
    my $website_id = shift or croak "No website id";
80
    my $authorization_name = shift or croak "No authorization name";
81
82
    my $request = $self->_make_access_token_by_user_id_request($user_id, $password, $website_id, $authorization_name);
83
    $self->_request_access_token($request);
84
85
    $self->user_id($user_id);
86
    $self->password($password);
87
    $self->website_id($website_id);
88
    $self->authorization_name($authorization_name);
89
    return wantarray ? ($self->access_token, $self->access_token_type) : $self->access_token;
90
}
91
92
sub _make_access_token_by_user_id_request {
93
    my $self = shift;
94
    my $user_id = shift or croak "No user id";
95
    my $password = shift; # can be blank
96
    my $website_id = shift or croak "No website id";
97
    my $authorization_name = shift or croak "No authorization name";
98
99
    my %params = (
100
        grant_type => 'password',
101
        username => $user_id,
102
        scope => "websiteid:".$website_id." authorizationname:".$authorization_name,
103
    );
104
    if ($password) {
105
        $params{password} = $password;
106
    } else {
107
        $params{password} = "[ignore]";
108
        $params{password_required} = "false";
109
    }
110
    return HTTP::Request::Common::POST( 'https://oauth-patron.overdrive.com/patrontoken', \%params );
111
}
112
113
=head2 Authentication at OverDrive - Granted or "3-Legged" Authorization
114
115
With OverDrive there's an extra step - an auth code is returned to the
116
redirect back handler that needs to make an API call to convert it into
117
a auth token.
118
119
An example:
120
121
    my $overdrive = WebService::ILS::OverDrive::Patron({
122
        client_id => $client_id,
123
        client_secret => $client_secret,
124
        library_id => $library_id,
125
    });
126
    my $redirect_url = $overdrive->auth_url("http://myapp.com/overdrive-auth");
127
    $response->redirect($redirect_url);
128
    ...
129
    /overdrive-auth handler:
130
    my $auth_code = $req->param( $overdrive->auth_code_param_name )
131
        or some_error_handling(), return;
132
    # my $state = $req->param( $overdrive->state_token_param_name )...
133
    local $@;
134
    eval { $overdrive->auth_by_code( $auth_code ) };
135
    if ($@) { some_error_handling(); return; }
136
    $session{overdrive_access_token} = $access_token;
137
    $session{overdrive_access_token_type} = $access_token_type;
138
    $session{overdrive_auth_token} = $auth_token;
139
    ...
140
    Somewhere else in your app:
141
    my $ils = WebService::ILS::Provider({
142
        client_id => $client_id,
143
        client_secret => $client_secret,
144
        access_token => $session{overdrive_access_token},
145
        access_token_type => $session{overdrive_access_token_type},
146
        auth_token = $session{overdrive_auth_token}
147
    });
148
    my $checkouts = $overdrive->checkouts;
149
150
=head2 auth_url ($redirect_uri, $state_token)
151
152
=head3 Input params:
153
154
=over 18
155
156
=item C<redirect_uri> => return url which will handle redirect back after auth
157
158
=item C<state_token>  => a token that is returned back unchanged;
159
160
for additional security; not required
161
162
=back
163
164
=cut
165
166
sub auth_url {
167
    my $self = shift;
168
    my $redirect_uri = shift or croak "Redirect URI not specified";
169
    my $state_token = shift;
170
171
    my $library_id = $self->library_id or croak "No Library Id";
172
173
    return sprintf AUTH_URL .
174
            "?client_id=%s" .
175
            "&redirect_uri=%s" .
176
            "&scope=%s" .
177
            "&response_type=code" .
178
            "&state=%s",
179
        map uri_escape($_),
180
            $self->client_id,
181
            $redirect_uri,
182
            "accountid:$library_id",
183
            defined ($state_token) ? $state_token : ""
184
    ;
185
}
186
187
=head2 auth_code_param_name ()
188
189
=head2 state_token_param_name ()
190
191
=cut
192
193
use constant auth_code_param_name => "code";
194
use constant state_token_param_name => "code";
195
196
=head2 auth_by_code ($provider_code, $redirect_uri)
197
198
=head3 Returns (access_token, access_token_type, auth_token) or access_token
199
200
=cut
201
202
sub auth_by_code {
203
    my $self = shift;
204
    my $code = shift or croak "No authorization code";
205
    my $redirect_uri = shift or croak "Redirect URI not specified";
206
207
    my $auth_type = 'authorization_code';
208
209
    my $request = HTTP::Request::Common::POST( TOKEN_URL, {
210
        grant_type => 'authorization_code',
211
        code => $code,
212
        redirect_uri => $redirect_uri,
213
    } );
214
    $self->_request_access_token($request);
215
    return wantarray ? ($self->access_token, $self->access_token_type, $self->auth_token) : $self->access_token;
216
}
217
218
=head2 auth_by_token ($provider_token)
219
220
=head3 Returns (access_token, access_token_type, auth_token) or access_token
221
222
=cut
223
224
sub auth_by_token {
225
    my $self = shift;
226
    my $auth_token = shift or croak "No authorization token";
227
228
    $self->auth_token($auth_token);
229
    my $request = $self->_make_access_token_by_auth_token_request($auth_token);
230
    $self->_request_access_token($request);
231
232
    return wantarray ? ($self->access_token, $self->access_token_type, $self->auth_token) : $self->access_token;
233
}
234
235
sub _make_access_token_by_auth_token_request {
236
    my $self = shift;
237
    my $auth_token = shift or croak "No authorization token";
238
239
    return HTTP::Request::Common::POST( TOKEN_URL, {
240
            grant_type => 'refresh_token',
241
            refresh_token => $auth_token,
242
    } );
243
}
244
245
sub make_access_token_request {
246
    my $self = shift;
247
248
    if (my $auth_token = $self->auth_token) {
249
        return $self->_make_access_token_by_auth_token_request($auth_token);
250
    }
251
    elsif (my $user_id = $self->user_id) {
252
        return $self->_make_access_token_by_user_id_request(
253
            $user_id, $self->password, $self->website_id, $self->authorization_name
254
        );
255
    }
256
    
257
    die $self->ERROR_NOT_AUTHENTICATED."\n";
258
}
259
260
sub _request_access_token {
261
    my $self = shift;
262
    my $request = shift or croak "No request";
263
264
    my $data = $self->SUPER::_request_access_token($request)
265
      or die "Unsuccessful access token request";
266
267
    if (my $auth_token = $data->{refresh_token}) {
268
        $self->auth_token($auth_token);
269
    }
270
271
    return $data;
272
}
273
274
sub collection_token {
275
    my $self = shift;
276
277
    if (my $collection_token = $self->SUPER::collection_token) {
278
        return $collection_token;
279
    }
280
    
281
    $self->native_patron; # sets collection_token as a side-effect
282
    my $collection_token = $self->SUPER::collection_token
283
      or die "Patron has no collections\n";
284
    return $collection_token;
285
}
286
287
=head1 CIRCULATION METHOD SPECIFICS
288
289
Differences to general L<WebService::ILS> interface
290
291
=cut
292
293
my %PATRON_XLATE = (
294
    checkoutLimit => "checkout_limit",
295
    existingPatron => 'active',
296
    patronId => 'id',
297
    holdLimit => 'hold_limit',
298
);
299
sub patron {
300
    my $self = shift;
301
    return $self->_result_xlate($self->native_patron, \%PATRON_XLATE);
302
}
303
304
my %HOLDS_XLATE = (
305
    totalItems => 'total',
306
);
307
my %HOLDS_ITEM_XLATE = (
308
    reserveId => 'id',
309
    holdPlacedDate => 'placed_datetime',
310
    holdListPosition => 'queue_position',
311
);
312
sub holds {
313
    my $self = shift;
314
315
    my $holds = $self->native_holds;
316
    my $items = delete ($holds->{holds}) || [];
317
318
    my $res = $self->_result_xlate($holds, \%HOLDS_XLATE);
319
    $res->{items} = [
320
        map {
321
            my $item = $self->_result_xlate($_, \%HOLDS_ITEM_XLATE);
322
            my $item_id = $item->{id};
323
            my $metadata = $self->item_metadata($item_id);
324
            my $i = {%$item, %$metadata}; # we need my $i, don't ask me why...
325
        } @$items
326
    ];
327
    return $res;
328
}
329
330
=head2 place_hold ($item_id, $notification_email_address, $auto_checkout)
331
332
C<$notification_email_address> and C<$auto_checkout> are optional.
333
C<$auto_checkout> defaults to false.
334
335
=head3 Returns holds item record
336
337
It is prefered that the C<$notification_email_address> is specified.
338
339
If C<$auto_checkout> is set to true, the item will be checked out as soon as
340
it becomes available.
341
342
=cut
343
344
sub place_hold {
345
    my $self = shift;
346
347
    my $hold = $self->native_place_hold(@_) or return;
348
    my $res = $self->_result_xlate($hold, \%HOLDS_ITEM_XLATE);
349
    $res->{total} = $hold->{numberOfHolds};
350
    return $res;
351
}
352
353
# sub suspend_hold { - not really useful
354
355
sub remove_hold {
356
    my $self = shift;
357
    my $item_id = shift or croak "No item id";
358
359
    my $url = $self->circulation_action_url("/holds/$item_id");
360
    return $self->with_delete_request(
361
        \&_basic_callback,
362
        sub {
363
            my ($data) = @_;
364
            return 1 if $data->{errorCode} eq "PatronDoesntHaveTitleOnHold";
365
            die ($data->{message} || $data->{errorCode})."\n";
366
        },
367
        $url
368
    );
369
}
370
371
=head2 checkouts ()
372
373
For formats see C<checkout_formats()> below
374
375
=cut
376
377
my %CHECKOUTS_XLATE = (
378
    totalItems => 'total',
379
    totalCheckouts => 'total_format',
380
);
381
sub checkouts {
382
    my $self = shift;
383
384
    my $checkouts = $self->native_checkouts;
385
    my $items = delete ($checkouts->{checkouts}) || [];
386
387
    my $res = $self->_result_xlate($checkouts, \%CHECKOUTS_XLATE);
388
    $res->{items} = [
389
        map {
390
            my $item = $self->_checkout_item_xlate($_);
391
            my $item_id = $item->{id};
392
            my $formats = delete ($_->{formats});
393
            my $actions = delete ($_->{actions});
394
            my $metadata = $self->item_metadata($item_id);
395
            if ($formats) {
396
                $formats = $self->_formats_xlate($item_id, $formats);
397
            }
398
            else {
399
                $formats = {};
400
            }
401
            if ($actions) {
402
                if (my $format_action = $actions->{format}) {
403
                    foreach (@{$format_action->{fields}}) {
404
                        next unless $_->{name} eq "formatType";
405
406
                        foreach my $format (@{$_->{options}}) {
407
                            $formats->{$format} = undef unless exists $formats->{$format};
408
                        }
409
                        last;
410
                    }
411
                }
412
            }
413
            my $i = {%$item, %$metadata, formats => $formats}; # we need my $i, don't ask me why...
414
        } @$items
415
    ];
416
    return $res;
417
}
418
419
my %CHECKOUT_ITEM_XLATE = (
420
    reserveId => 'id',
421
    checkoutDate => 'checkout_datetime',
422
    expires => 'expires',
423
);
424
sub _checkout_item_xlate {
425
    my $self = shift;
426
    my $item = shift;
427
428
    my $i = $self->_result_xlate($item, \%CHECKOUT_ITEM_XLATE);
429
    if ($item->{isFormatLockedIn}) {
430
        my $formats = $item->{formats} or die "Item $item->{reserveId}: Format locked in, but no formats returned\n";
431
        $i->{format} = $formats->[0]{formatType};
432
    }
433
    return $i;
434
}
435
436
=head2 checkout ($item_id, $format, $allow_multiple_format_checkouts)
437
438
C<$format> and C<$allow_multiple_format_checkouts> are optional.
439
C<$allow_multiple_format_checkouts> defaults to false.
440
441
=head3 Returns checkout item record
442
443
An item can be available in multiple formats. Checkout is complete only
444
when the format is specified.
445
446
Checkout can be actioned without format being specified. In that case an
447
early return can be actioned. To complete checkout format must be locked
448
later (see L<lock_format()> below). That would be the case with
449
L<place_hold()> with C<$auto_checkout> set to true. Once format is locked,
450
an early return is not possible.
451
452
If C<$allow_multiple_format_checkouts> flag is set to true, mutiple formats
453
of the same item can be acioned. If it is false (default) and the item was
454
already checked out, the checked out item record will be returned regardless
455
of the format.
456
457
Checkout record will have an extra field C<format> if format is locked in.
458
459
=cut
460
461
sub checkout {
462
    my $self = shift;
463
464
    my $checkout = $self->native_checkout(@_) or return;
465
    return $self->_checkout_item_xlate($checkout);
466
}
467
468
=head2 checkout_formats ($item_id)
469
470
=head3 Returns a hashref of available title formats and immediate availability
471
472
  { format => available, ... }
473
474
If format is not immediately available it must be locked first
475
476
=cut
477
478
sub checkout_formats {
479
    my $self = shift;
480
    my $id = shift or croak "No item id";
481
482
    my $formats = $self->native_checkout_formats($id) or return;
483
    $formats = $formats->{'formats'} or return;
484
    return $self->_formats_xlate($id, $formats);
485
}
486
487
sub _formats_xlate {
488
    my $self = shift;
489
    my $id = shift or croak "No item id";
490
    my $formats = shift or croak "No formats";
491
492
    my %ret;
493
    my $id_uc = uc $id;
494
    foreach (@$formats) {
495
        die "Non-matching item id\nExpected $id\nGot $_->{reserveId}" unless uc($_->{reserveId}) eq $id_uc;
496
        my $format = $_->{formatType};
497
        my $available;
498
        if (my $lt = $_->{linkTemplates}) {
499
            $available = grep /^downloadLink/, keys %$lt;
500
        }
501
        $ret{$format} = $available;
502
    }
503
    return \%ret;
504
}
505
506
sub is_lockable {
507
    my $self = shift;
508
    my $checkout_formats = shift or croak "No checkout formats";
509
    while (my ($format, $available) = each %$checkout_formats) {
510
        return 1 unless $available;
511
    }
512
    return 0;
513
}
514
515
=head2 lock_format ($item_id, $format)
516
517
=head3 Returns locked format (should be the same as the input value)
518
519
=cut
520
521
sub lock_format {
522
    my $self = shift;
523
    my $item_id = shift or croak "No item id";
524
    my $format = shift or croak "No format";
525
526
    my $lock = $self->native_lock_format($item_id, $format) or return;
527
    die "Non-matching item id\nExpected $item_id\nGot $lock->{reserveId}" unless uc($lock->{reserveId}) eq uc($item_id);
528
    return $lock->{formatType};
529
}
530
531
=head2 checkout_download_url ($item_id, $format, $error_url, $success_url)
532
533
=head3 Returns OverDrive download url
534
535
Checked out items must be downloaded by users on the OverDrive site.
536
This method returns the url where the user should be sent to (redirected).
537
Once the download is complete, user will be redirected back to
538
C<$error_url> in case of an error, otherwise to optional C<$success_url>
539
if specified.
540
541
See L<https://developer.overdrive.com/apis/download>
542
543
=cut
544
545
sub checkout_download_url {
546
    my $self = shift;
547
    my $item_id = shift or croak "No item id";
548
    my $format = shift or croak "No format";
549
    my $error_url = shift or die "No error url";
550
    my $success_url = shift;
551
552
    $error_url = uri_escape($error_url);
553
    $success_url = $success_url ? uri_escape($success_url) : '';
554
    my $url = $self->circulation_action_url("/checkouts/$item_id/formats/$format/downloadlink?errorurl=$error_url&successurl=$success_url");
555
    my $response_data = $self->get_response($url);
556
    my $download_url =
557
        _extract_link($response_data, 'contentLink') ||
558
        _extract_link($response_data, 'contentlink')
559
        or die "Cannot get download url\n".Dumper($response_data);
560
    return $download_url;
561
}
562
563
sub return {
564
    my $self = shift;
565
    my $item_id = shift or croak "No item id";
566
567
    my $url = $self->circulation_action_url("/checkouts/$item_id");
568
    return $self->with_delete_request(
569
        \&_basic_callback,
570
        sub {
571
            my ($data) = @_;
572
            return 1 if $data->{errorCode} eq "PatronDoesntHaveTitleCheckedOut";
573
            die ($data->{message} || $data->{errorCode})."\n";
574
        },
575
        $url
576
    );
577
}
578
579
=head1 NATIVE METHODS
580
581
=head2 native_patron ()
582
583
See L<https://developer.overdrive.com/apis/patron-information>
584
585
=cut
586
587
sub native_patron {
588
    my $self = shift;
589
590
    my $url = $self->circulation_action_url("");
591
    my $patron = $self->get_response($url) or return;
592
    if (my $collection_token = $patron->{collectionToken}) {
593
        $self->SUPER::collection_token( $collection_token);
594
    }
595
    return $patron;
596
}
597
598
=head2 native_holds ()
599
600
=head2 native_place_hold ($item_id, $notification_email_address, $auto_checkout)
601
602
See L<https://developer.overdrive.com/apis/holds>
603
604
=cut
605
606
sub native_holds {
607
    my $self = shift;
608
    my $url = $self->circulation_action_url("/holds");
609
    return $self->get_response($url);
610
}
611
612
sub native_place_hold {
613
    my $self = shift;
614
    my $item_id = shift or croak "No item id";
615
    my $email = shift;
616
    my $auto_checkout = shift;
617
618
    my @fields = ( {name => "reserveId", value => $item_id } );
619
    push @fields, {name => "autoCheckout", value => "true"} if $auto_checkout;
620
    if ($email) {
621
        push @fields, {name => "emailAddress", value => $email};
622
    } else {
623
        push @fields, {name => "ignoreHoldEmail", value => "true"};
624
    }
625
626
    my $url = $self->circulation_action_url("/holds");
627
    return $self->with_json_request(
628
        \&_basic_callback,
629
        sub {
630
            my ($data) = @_;
631
            if ($data->{errorCode} eq "AlreadyOnWaitList") {
632
                if (my $holds = $self->native_holds) {
633
                    my $item_id_uc = uc $item_id;
634
                    foreach (@{ $holds->{holds} || [] }) {
635
                        if ( uc($_->{reserveId}) eq $item_id_uc ) {
636
                            $_->{numberOfHolds} = $holds->{totalItems};
637
                            return $_;
638
                        }
639
                    }
640
                }
641
            }
642
643
            die ($data->{message} || $data->{errorCode})."\n";
644
        },
645
        $url,
646
        {fields => \@fields}
647
    );
648
}
649
650
=head2 native_checkouts ()
651
652
=head2 native_checkout_info ($item_id)
653
654
=head2 native_checkout ($item_id, $format, $allow_multiple_format_checkouts)
655
656
=head2 native_checkout_formats ($item_id)
657
658
=head2 native_lock_format ($item_id, $format)
659
660
See L<https://developer.overdrive.com/apis/checkouts>
661
662
=cut
663
664
sub native_checkouts {
665
    my $self = shift;
666
667
    my $url = $self->circulation_action_url("/checkouts");
668
    return $self->get_response($url);
669
}
670
671
sub native_checkout_info {
672
    my $self = shift;
673
    my $id = shift or croak "No item id";
674
675
    my $url = $self->circulation_action_url("/checkouts/$id");
676
    return $self->get_response($url);
677
}
678
679
sub native_checkout_formats {
680
    my $self = shift;
681
    my $id = shift or croak "No item id";
682
683
    my $url = $self->circulation_action_url("/checkouts/$id/formats");
684
    return $self->get_response($url);
685
}
686
687
sub native_checkout {
688
    my $self = shift;
689
    my $item_id = shift or croak "No item id";
690
    my $format = shift;
691
    my $allow_multi = shift;
692
693
    if (my $checkouts = $self->native_checkouts) {
694
        my $item_id_uc = uc $item_id;
695
        foreach (@{ $checkouts->{checkouts} || [] }) {
696
            if ( uc($_->{reserveId}) eq $item_id_uc ) {
697
                if ($format) {
698
                    if ($_->{isFormatLockedIn}) {
699
                        return $_ if lc($_->{formats}[0]{formatType}) eq lc($format);
700
                        die "Item $item_id has already been locked for different format '$_->{formats}[0]{formatType}'\n"
701
                            unless $allow_multi;
702
                    }
703
#                   else { $self->native_lock_format()? }
704
                }
705
#               else { die if !$allow_multi ? }
706
                return $_;
707
            }
708
        }
709
    }
710
711
    my $url = $self->circulation_action_url("/checkouts");
712
    return $self->with_json_request(
713
        \&_basic_callback,
714
        undef,
715
        $url,
716
        {fields => _build_checkout_fields($item_id, $format)}
717
    );
718
}
719
720
sub native_lock_format {
721
    my $self = shift;
722
    my $item_id = shift or croak "No item id";
723
    my $format = shift or croak "No format";
724
725
    my $url = $self->circulation_action_url("/checkouts/$item_id/formats");
726
    return $self->with_json_request(
727
        \&_basic_callback,
728
        sub {
729
            my ($data) = @_;
730
            die "$format ".($data->{message} || $data->{errorCode})."\n";
731
        },
732
        $url,
733
        {fields => _build_checkout_fields($item_id, $format)}
734
    );
735
}
736
737
sub _build_checkout_fields {
738
    my ($id, $format) = @_;
739
    my @fields = ( {name => "reserveId", value => $id } );
740
    push @fields, {name => "formatType", value => $format} if $format;
741
    return \@fields;
742
}
743
744
# Circulation helpers
745
746
sub circulation_action_url {
747
    my $self = shift;
748
    my $action = shift;
749
    return $self->_circulation_api_url.$self->API_VERSION."/patrons/me$action";
750
}
751
752
# API helpers
753
754
sub _extract_link {
755
    my ($data, $link) = @_;
756
    return $data->{links}{$link}->{href};
757
}
758
759
sub _basic_callback { return $_[0]; }
760
761
1;
762
763
__END__
764
765
=head1 LICENSE
766
767
Copyright (C) Catalyst IT NZ Ltd
768
Copyright (C) Bywater Solutions
769
770
This library is free software; you can redistribute it and/or modify
771
it under the same terms as Perl itself.
772
773
=head1 AUTHOR
774
775
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
776
777
=cut
(-)a/lib/WebService/ILS/RecordedBooks.pm (+698 lines)
Line 0 Link Here
1
package WebService::ILS::RecordedBooks;
2
3
use Modern::Perl;
4
5
=encoding utf-8
6
7
=head1 NAME
8
9
WebService::ILS::RecordedBooks - WebService::ILS module for RecordedBooks services
10
11
=head1 SYNOPSIS
12
13
    use WebService::ILS::RecordedBooks::Partner;
14
    or
15
    use WebService::ILS::RecordedBooks::Patron;
16
17
=head1 DESCRIPTION
18
19
L<WebService::ILS::RecordedBooks::Partner> - services
20
that use partner credentials, for any patron
21
22
L<WebService::ILS::RecordedBooks::PartnerPatron> - same as above,
23
except it operates on a single patron account
24
25
L<WebService::ILS::RecordedBooks::Patron> - services
26
that use individual patron credentials, in addition to partner credentials
27
28
L<WebService::ILS::RecordedBooks::PartnerPatron> is preferred over
29
L<WebService::ILS::RecordedBooks::Patron> because the later requires patron
30
credentials - username and password. However, if you do not know patron's
31
email or RecordedBooks id (barcode) you are stuck with Patron interface.
32
33
See L<WebService::ILS>
34
35
=cut
36
37
use Carp;
38
use HTTP::Request::Common;
39
use URI::Escape;
40
use JSON qw(to_json);
41
42
use parent qw(WebService::ILS::JSON);
43
44
use constant API_VERSION => "v1";
45
use constant BASE_DOMAIN => "rbdigital.com";
46
47
=head1 CONSTRUCTOR
48
49
=head2 new (%params_hash or $params_hashref)
50
51
=head3 Additional constructor params:
52
53
=over 12
54
55
=item C<ssl>            => if set to true use https
56
57
=item C<domain>         => RecordedBooks domain for title url
58
59
=back
60
61
C<client_id> is either RecordedBooks id (barcode) or email
62
63
C<domain> if set is either "whatever.rbdigital.com" or "whatever",
64
in which case rbdigital.com is appended.
65
66
=cut
67
68
use Class::Tiny qw(
69
    ssl
70
    domain
71
    _api_base_url
72
);
73
74
__PACKAGE__->_set_param_spec({
75
    client_id  => { required => 0 },
76
    library_id => { required => 1 },
77
    domain     => { required => 0 },
78
    ssl        => { required => 0, default => 1 },
79
});
80
81
sub BUILD {
82
    my $self = shift;
83
    my $params = shift;
84
85
    if (my $domain = $self->domain) {
86
        $self->domain("$domain.".BASE_DOMAIN) unless $domain =~ m/\./;
87
    }
88
89
    my $ssl = $self->ssl;
90
    my $ua = $self->user_agent;
91
    $ua->ssl_opts( verify_hostname => 0 ) if $ssl;
92
93
    my $api_url = sprintf "%s://api.%s", $ssl ? "https" : "http", BASE_DOMAIN;
94
    $self->_api_base_url($api_url);
95
}
96
97
sub api_url {
98
    my $self = shift;
99
    my $action = shift or croak "No action";
100
101
    return sprintf "%s/%s%s", $self->_api_base_url, API_VERSION, $action;
102
}
103
104
sub library_action_base_url {
105
    my $self = shift;
106
107
    return $self->api_url("/libraries/".$self->library_id);
108
}
109
110
sub products_url {
111
    my $self = shift;
112
    return $self->library_action_base_url."/search";
113
}
114
115
sub circulation_action_url {
116
    my $self = shift;
117
    my $action = shift or croak "No action";
118
119
    return $self->circulation_action_base_url(@_).$action;
120
}
121
122
sub _access_auth_string {
123
    my $self = shift;
124
    return $self->client_secret;
125
}
126
127
sub native_countries {
128
    my $self = shift;
129
130
    my $url = $self->api_url("/countries");
131
    return $self->get_without_auth($url);
132
}
133
134
sub native_facets {
135
    my $self = shift;
136
137
    my $url = $self->api_url("/facets");
138
    return $self->get_response($url);
139
}
140
141
142
sub native_facet_values {
143
    my $self = shift;
144
    my $facet = shift or croak "No facet";
145
146
    my $url = $self->api_url("/facets/$facet");
147
    return $self->get_without_auth($url);
148
}
149
150
sub native_libraries_search {
151
    my $self = shift;
152
    my $query = shift or croak "No query";
153
    my $region = shift;
154
155
    my %search_params = ( term => $query );
156
    $search_params{ar} = $region if $region;
157
    my $url = $self->api_url("/suggestive/libraries");
158
    return $self->get_without_auth($url, \%search_params);
159
}
160
161
sub get_without_auth {
162
    my $self = shift;
163
    my $url = shift or croak "No url";
164
    my $get_params = shift; # hash ref
165
166
    my $uri = URI->new($url);
167
    $uri->query_form($get_params) if $get_params;
168
    my $request = HTTP::Request::Common::GET( $uri );
169
    my $response = $self->user_agent->request( $request );
170
    $self->check_response($response);
171
172
    return $self->process_json_response($response, sub {
173
        my ($data) = @_;
174
        die "No data\n" unless $data;
175
        return $data;
176
    });
177
}
178
179
=head1 DISCOVERY METHODS
180
181
=head2 facets ()
182
183
=head3 Returns a hashref of facet => [values]
184
185
=cut
186
187
sub facets {
188
    my $self = shift;
189
190
    my $facets = $self->native_facets;
191
    my %facet_values;
192
    foreach (@$facets) {
193
        my $f = $_->{facetToken};
194
        $facet_values{$f} = [map $_->{valueToken}, @{ $self->native_facet_values($f) }];
195
    }
196
    return \%facet_values;
197
}
198
199
=head2 search ($params_hashref)
200
201
=head3 Additional input params:
202
203
=over 12
204
205
=item C<facets> => a hashref of facet values
206
207
=back
208
209
=cut
210
211
my %SORT_XLATE = (
212
    rating => undef,
213
    publication_date => undef, # not available
214
);
215
sub search {
216
    my $self = shift;
217
    my $params = shift || {};
218
219
    my $url = $self->products_url;
220
221
    if (my $query = delete $params->{query}) {
222
        $query = join " ", @$query if ref $query;
223
        $params->{all} = $query;
224
    }
225
    if (my $page_size = delete $params->{page_size}) {
226
        $params->{'page-size'} = $page_size;
227
    }
228
    if (my $page_number = delete $params->{page}) {
229
        die "page_size must be specified for paging" unless $params->{'page-size'};
230
        $params->{'page-index'} = $page_number - 1;
231
    }
232
    if (my $sort = delete $params->{sort}) {
233
        my $sa = $self->_parse_sort_string($sort, \%SORT_XLATE);
234
        if (@$sa) {
235
            my @params = %$params;
236
            foreach (@$sa) {
237
                my ($s, $d) = split ':';
238
                push @params, "sort-by", $s;
239
                push @params, "sort-order", $d if $d;
240
            }
241
            return $self->_search_result_xlate( $self->get_response($url, \@params) );
242
        }
243
    }
244
245
    return $self->_search_result_xlate( $self->get_response($url, $params) );
246
}
247
248
sub _search_result_xlate {
249
    my $self = shift;
250
    my $res = shift or return;
251
252
    my $domain = $self->domain;
253
    return {
254
        items => [ map {
255
            my $i = $self->_item_xlate($_->{item});
256
            $i->{url} ||= "https://$domain/#titles/$i->{isbn}" if $domain;
257
            $i->{available} = $_->{interest}{isAvailable};
258
            $i;
259
        } @{$res->{items} || []} ],
260
        page_size => $res->{pageSize},
261
        page => $res->{pageIndex} + 1,
262
        pages => $res->{pageCount},
263
    };
264
}
265
266
my %SEARCH_RESULT_ITEM_XLATE = (
267
    id => "id",
268
    title => "title",
269
    subtitle => "subtitle",
270
    shortDescription => "description",
271
    mediaType => "media",
272
    downloadUrl => "url",
273
    encryptionKey => "encryption_key",
274
    isbn => "isbn",
275
    hasDrm => "drm",
276
    releasedDate => "publication_date",
277
    size => "size",
278
    language => "language",
279
    expiration => "expires",
280
);
281
my %ITEM_FILES_XLATE = (
282
    id => "id",
283
    filename => "filename",
284
    display => "title",
285
    downloadUrl => "url",
286
    size => "size",
287
);
288
sub _item_xlate {
289
    my $self = shift;
290
    my $item = shift;
291
292
    my $std_item = $self->_result_xlate($item, \%SEARCH_RESULT_ITEM_XLATE);
293
294
    if (my $images = delete $item->{images}) { # XXX let's say that caller wouldn't mind
295
        $std_item->{images} = {map { $_->{name} => $_->{url} } @$images};
296
    }
297
298
    if (my $files = delete $item->{files}) {
299
        $std_item->{files} = [ map $self->_result_xlate($_, \%ITEM_FILES_XLATE), @$files ];
300
    }
301
302
    my %facets;
303
    if (my $publisher = delete $item->{publisher}) {
304
        if (ref $publisher) {
305
            if (my $f = $publisher->{facet}) {
306
                $facets{$f} = [$publisher->{token}];
307
            }
308
            $publisher = $publisher->{text};
309
        }
310
        $std_item->{publisher} = $publisher;
311
    }
312
    if (my $authors = delete $item->{authors}) {
313
        my @a;
314
        if (ref $authors) {
315
            foreach (@$authors) {
316
                push @a, $_->{text} if $_->{text};
317
                if (my $f = $_->{facet}) {
318
                    my $f_a = $facets{$f} ||= [];
319
                    push @$f_a, $_->{token};
320
                }
321
            }
322
        }
323
        else {
324
            push @a, $authors;
325
        }
326
        $std_item->{author} = join ", ", @a;
327
    }
328
    foreach my $v (values %$item) {
329
        my $ref = ref $v or next;
330
        $v = [$v] if $ref eq "HASH";
331
        next unless ref($v) eq "ARRAY";
332
        foreach (@$v) {
333
            if (my $f = $_->{facet}) {
334
                my $f_a = $facets{$f} ||= [];
335
                push @$f_a, $_->{token};
336
            }
337
        }
338
    }
339
    $std_item->{facets} = \%facets if keys %facets;
340
341
    return $std_item;
342
}
343
344
=head2 named_query_search ($query, $media)
345
346
  See C<native_named_query_search()> below for $query, $media
347
348
=cut
349
350
sub named_query_search {
351
    my $self = shift;
352
    return $self->_search_result_xlate( $self->native_named_query_search(@_) );
353
}
354
355
=head2 facet_search ($facets)
356
357
  See C<native_facet_search()> below for $facets
358
359
=cut
360
361
sub facet_search {
362
    my $self = shift;
363
    return $self->_search_result_xlate( $self->native_facet_search(@_) );
364
}
365
366
sub item_metadata {
367
    my $self = shift;
368
    my $ni = $self->native_item(@_) or return;
369
    return $self->_item_xlate( $ni->{item} );
370
}
371
372
=head1 CIRCULATION METHOD SPECIFICS
373
374
Differences to general L<WebService::ILS> interface
375
376
=cut
377
378
=head2 holds ()
379
380
=head2 place_hold ($isbn)
381
382
=head2 remove_hold ($isbn)
383
384
=cut
385
386
sub holds {
387
    my $self = shift;
388
389
    my $items = $self->native_holds(@_);
390
    return {
391
        total => scalar @$items,
392
        items => [ map {
393
            my $i = $self->_item_xlate($_);
394
            $i->{hold_id} = $_->{transactionId};
395
            $i;
396
        } @$items ],
397
    };
398
}
399
400
sub place_hold {
401
    my $self = shift;
402
    my $isbn = shift or croak "No isbn";
403
404
    my $url = $self->circulation_action_url("/holds/$isbn", @_);
405
    my $request = HTTP::Request::Common::POST( $url );
406
    my $response = $self->_request_with_auth($request);
407
    unless ($response->is_success) {
408
        $self->process_json_error_response($response, sub {
409
            my ($data) = @_;
410
            if (my $message = $data->{message}) {
411
                return 1 if $message =~ m/already exists/i;
412
                die $message;
413
            }
414
            die $self->_error_from_json($data) || "Cannot place hold: ".to_json($data);
415
        });
416
    }
417
418
    if (my $holds = $self->holds(@_)) {
419
        foreach my $i (@{ $holds->{items} }) {
420
            if ($i->{isbn} eq $isbn) {
421
                $i->{total} = $holds->{total};
422
                return $i;
423
            }
424
        }
425
    }
426
427
    my $content = $response->decoded_content;
428
    my $content_type = $response->header('Content-Type');
429
    my $error;
430
    if ($content_type && $content_type =~ m!application/json!) {
431
        if (my $data = eval { from_json( $content ) }) {
432
            $error = $self->_error_from_json($data);
433
        }
434
    }
435
436
    die $error || "Cannot place hold:\n$content";
437
}
438
439
sub remove_hold {
440
    my $self = shift;
441
    my $isbn = shift or croak "No isbn";
442
443
    my $url = $self->circulation_action_url("/holds/$isbn", @_);
444
    my $request = HTTP::Request::Common::DELETE( $url );
445
    my $response = $self->_request_with_auth($request);
446
    unless ($response->is_success) {
447
        return $self->process_json_error_response($response, sub {
448
            my ($data) = @_;
449
            if (my $message = $data->{message}) {
450
                return 1 if $message =~ m/not exists|expired/i;
451
                die $message;
452
            }
453
            die $self->_error_from_json($data) || "Cannot remove hold: ".to_json($data);
454
        });
455
    }
456
    return 1;
457
}
458
459
=head2 checkouts ()
460
461
=head2 checkout ($isbn, $days)
462
463
=head2 renew ($isbn)
464
465
=head2 return ($isbn)
466
467
=cut
468
469
sub checkouts {
470
    my $self = shift;
471
472
    my $items = $self->native_checkouts(@_);
473
    return {
474
        total => scalar @$items,
475
        items => [ map {
476
            my $i = $self->_item_xlate($_);
477
            $i->{checkout_id} = $_->{transactionId};
478
            $i;
479
        } @$items ],
480
    };
481
}
482
483
sub checkout {
484
    my $self = shift;
485
    my $isbn = shift or croak "No isbn";
486
    my $days = shift;
487
488
    if (my $checkouts = $self->checkouts(@_)) {
489
        foreach my $i (@{ $checkouts->{items} }) {
490
            if ( $i->{isbn} eq $isbn ) {
491
                $i->{total} = scalar @{ $checkouts->{items} };
492
                return $i;
493
            }
494
        }
495
    }
496
497
    my $url = $self->circulation_action_url("/checkouts/$isbn", @_);
498
    $url .= "?days=$days" if $days;
499
    my $res = $self->with_post_request(
500
        \&_basic_callback,
501
        $url
502
    );
503
504
    my $checkouts = $self->checkouts(@_) or die "Cannot checkout, unknown error";
505
    foreach my $i (@{ $checkouts->{items} }) {
506
        if ($i->{isbn} eq $isbn) {
507
            $i->{total} = scalar @{ $checkouts->{items} };
508
            return $i;
509
        }
510
    }
511
    die $res->{message} || "Cannot checkout, unknown error";
512
}
513
514
sub renew {
515
    my $self = shift;
516
    my $isbn = shift or croak "No isbn";
517
518
    my $url = $self->circulation_action_url("/checkouts/$isbn", @_);
519
    my $res = $self->with_put_request(
520
        \&_basic_callback,
521
        $url
522
    );
523
524
    my $checkouts = $self->checkouts(@_) or die "Cannot renew, unkmown error";
525
    foreach my $i (@{ $checkouts->{items} }) {
526
        if ($i->{isbn} eq $isbn) {
527
            $i->{total} = scalar @{ $checkouts->{items} };
528
            return $i;
529
        }
530
    }
531
    die $res->{output} || "Cannot renew, unknown error";
532
}
533
534
sub return {
535
    my $self = shift;
536
    my $isbn = shift or croak "No isbn";
537
538
    my $url = $self->circulation_action_url("/checkouts/$isbn", @_);
539
    my $request = HTTP::Request::Common::DELETE( $url );
540
    my $response = $self->_request_with_auth($request);
541
    unless ($response->is_success) {
542
        return $self->process_json_error_response($response, sub {
543
            my ($data) = @_;
544
            if (my $message = $data->{message}) {
545
                return 1 if $message =~ m/not exists|expired/i;
546
                die $message;
547
            }
548
            die "Cannot return: ".to_json($data);
549
        });
550
    }
551
    return 1;
552
}
553
554
=head1 NATIVE METHODS
555
556
=head2 native_search ($params_hashref)
557
558
See L<https://developer.overdrive.com/apis/search>
559
560
=cut
561
562
sub native_search {
563
    my $self = shift;
564
    my $search_params = shift;
565
566
    return $self->get_response($self->products_url, $search_params);
567
}
568
569
=head2 native_named_query_search ($query, $media)
570
571
  $query can be one of 'bestsellers', 'most-popular', 'newly-added'
572
  $media can be 'eaudio' or 'ebook'
573
574
=cut
575
576
my @MEDIA = qw( eaudio ebook );
577
my @NAMED_QUERY = ( 'bestsellers', 'most-popular', 'newly-added' );
578
sub native_named_query_search {
579
    my $self = shift;
580
    my $query = shift or croak "No query";
581
    my $media = shift or croak "No media";
582
583
    croak "Invalid media $media - should be one of ".join(", ", @MEDIA)
584
      unless grep { $_ eq $media } @MEDIA;
585
    croak "Invalid named query $query - should be one of ".join(", ", @NAMED_QUERY)
586
      unless grep { $_ eq $query } @NAMED_QUERY;
587
588
    my $url = $self->products_url."/$media/$query";
589
    return $self->get_response($url);
590
}
591
592
=head2 native_facet_search ($facets)
593
594
  $facets can be either:
595
  * a hashref of facet => [values],
596
  * an arrayref of values
597
  * a single value
598
599
=cut
600
601
sub native_facet_search {
602
    my $self = shift;
603
    my $facets = shift or croak "No facets";
604
    $facets = [$facets] unless ref $facets;
605
606
    my $url = $self->products_url;
607
    if (ref ($facets) eq "ARRAY") {
608
        $url = join "/", $url, @$facets;
609
        undef $facets;
610
    }
611
    return $self->get_response($url, $facets);
612
}
613
614
# Item API
615
616
=head2 native_item ($isbn)
617
618
=head2 native_item_summary ($isbn)
619
620
=head3 Returns subset of item fields, with addition of summary field
621
622
=cut
623
624
sub native_item {
625
    my $self = shift;
626
    my $isbn = shift or croak "No isbn";
627
628
    my $url = $self->title_url($isbn);
629
    return $self->get_response($url);
630
}
631
632
sub native_item_summary {
633
    my $self = shift;
634
    my $isbn = shift or croak "No isbn";
635
636
    my $url = $self->title_url("$isbn/summary");
637
    return $self->get_response($url);
638
}
639
640
=head2 native_holds ()
641
642
See L<http://developer.rbdigital.com/endpoints/title-holds>
643
644
=cut
645
646
sub native_holds {
647
    my $self = shift;
648
649
    my $url = $self->circulation_action_url("/holds/all", @_);
650
    return $self->get_response($url);
651
}
652
653
=head2 native_checkouts ()
654
655
=cut
656
657
sub native_checkouts {
658
    my $self = shift;
659
660
    my $url = $self->circulation_action_url("/checkouts/all", @_);
661
    return $self->get_response($url);
662
}
663
664
# Utility methods
665
666
sub _basic_callback { return $_[0]; }
667
668
sub get_response {
669
    my $self = shift;
670
    my $url = shift or croak "No url";
671
    my $get_params = shift; # hash ref
672
673
    return $self->with_get_request(\&_basic_callback, $url, $get_params);
674
}
675
676
sub _error_from_json {
677
    my $self = shift;
678
    my $data = shift or croak "No json data";
679
    return join " ", grep defined, $data->{errorCode}, $data->{message};
680
}
681
682
1;
683
684
__END__
685
686
=head1 LICENSE
687
688
Copyright (C) Catalyst IT NZ Ltd
689
Copyright (C) Bywater Solutions
690
691
This library is free software; you can redistribute it and/or modify
692
it under the same terms as Perl itself.
693
694
=head1 AUTHOR
695
696
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
697
698
=cut
(-)a/lib/WebService/ILS/RecordedBooks/Partner.pm (+126 lines)
Line 0 Link Here
1
package WebService::ILS::RecordedBooks::Partner;
2
3
use Modern::Perl;
4
5
=encoding utf-8
6
7
=head1 NAME
8
9
WebService::ILS::RecordedBooks::Partner - RecordedBooks partner API
10
11
=head1 SYNOPSIS
12
13
    use WebService::ILS::RecordedBooks::Partner;
14
15
=head1 DESCRIPTION
16
17
L<WebService::ILS::RecordedBooks::Partner> - services
18
that use trusted partner credentials
19
20
See L<WebService::ILS::RecordedBooks>
21
22
=cut
23
24
use Carp;
25
26
use parent qw(WebService::ILS::RecordedBooks::PartnerBase);
27
28
sub circulation_action_base_url {
29
    my $self = shift;
30
    my $patron_id = shift or croak "No patron id";
31
32
    return $self->library_action_base_url."/patrons/${patron_id}";
33
}
34
35
=head1 DISCOVERY METHODS
36
37
=head2 facet_search ($facets)
38
39
  See C<native_facet_search()> below for $facets
40
41
=head2 named_query_search ($query, $media)
42
43
  See C<native_named_query_search()> below for $query, $media
44
45
=head1 CIRCULATION METHOD SPECIFICS
46
47
Differences to general L<WebService::ILS> interface
48
49
=head2 patron_id ($email_or_id)
50
51
=head2 holds ($patron_id)
52
53
=head2 place_hold ($patron_id, $isbn)
54
55
=head2 checkouts ($patron_id)
56
57
=head2 checkout ($patron_id, $isbn)
58
59
=head2 renew ($patron_id, $isbn)
60
61
=head2 return ($patron_id, $isbn)
62
63
=cut
64
65
foreach my $sub (qw(place_hold remove_hold renew return)) {
66
    no strict "refs";
67
    *$sub = sub {
68
        my $self = shift;
69
        my $patron_id = shift or croak "No patron id";
70
        my $isbn = shift or croak "No isbn";
71
        my $supersub = "SUPER::$sub";
72
        return $self->$supersub($isbn, $patron_id);
73
    };
74
}
75
76
sub checkout {
77
    my $self = shift;
78
    my $patron_id = shift or croak "No patron id";
79
    my $isbn = shift or croak "No isbn";
80
    my $days = shift;
81
    return $self->SUPER::checkout($isbn, $days, $patron_id);
82
}
83
84
85
=head1 NATIVE METHODS
86
87
=head2 native_quick_search ($query, $category)
88
89
  $category can be one of 'all', 'title', 'author', or  'narrator';
90
    optional, defaults to 'all'
91
92
=cut
93
94
=head2 native_facet_search ($facets)
95
96
  $facets can be either:
97
  * a hashref of facet => [values],
98
  * an arrayref of values
99
  * a single value
100
101
=head2 native_named_query_search ($query, $media)
102
103
  $query can be one of 'bestsellers', 'most-popular', 'newly-added'
104
  $media can be 'eaudio' or 'ebook'
105
106
=head2 native_patron ($email_or_id)
107
108
=cut
109
110
1;
111
112
__END__
113
114
=head1 LICENSE
115
116
Copyright (C) Catalyst IT NZ Ltd
117
Copyright (C) Bywater Solutions
118
119
This library is free software; you can redistribute it and/or modify
120
it under the same terms as Perl itself.
121
122
=head1 AUTHOR
123
124
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
125
126
=cut
(-)a/lib/WebService/ILS/RecordedBooks/PartnerBase.pm (+90 lines)
Line 0 Link Here
1
package WebService::ILS::RecordedBooks::PartnerBase;
2
3
use Modern::Perl;
4
5
=encoding utf-8
6
7
=head1 NAME
8
9
WebService::ILS::RecordedBooks::PartnerBase - RecordedBooks partner API
10
11
=head1 SYNOPSIS
12
13
See L<WebService::ILS::RecordedBooks::Partner>
14
and L<WebService::ILS::RecordedBooks::PartnerPatron>;
15
16
=cut
17
18
use Carp;
19
use URI::Escape;
20
21
use parent qw(WebService::ILS::RecordedBooks);
22
23
sub title_url {
24
    my $self = shift;
25
    my $isbn = shift or croak "No isbn";
26
    return $self->library_action_base_url."/titles/$isbn";
27
}
28
29
sub _request_with_token {
30
    my $self = shift;
31
    my $request = shift or croak "No request";
32
33
    $request->header( Authorization => "Basic ".$self->client_secret );
34
    return $self->user_agent->request( $request );
35
}
36
37
=head1 CIRCULATION METHOD SPECIFICS
38
39
=cut
40
41
use constant NATIVE_PATRON_ID_KEY => "patronId";
42
my %PATRON_XLATE = (
43
    NATIVE_PATRON_ID_KEY() => 'id',
44
);
45
sub patron {
46
    my $self = shift;
47
    return $self->_result_xlate($self->native_patron(@_), \%PATRON_XLATE);
48
}
49
50
=head2 patron_id ($email_or_id)
51
52
=cut
53
54
sub patron_id {
55
    my $self = shift;
56
    my $patron = $self->native_patron(@_) or return;
57
    return $patron->{NATIVE_PATRON_ID_KEY()};
58
}
59
60
=head1 NATIVE METHODS
61
62
=head2 native_patron ($email_or_id)
63
64
=cut
65
66
sub native_patron {
67
    my $self = shift;
68
    my $cardnum_or_email = shift or croak "No patron identification";
69
70
    my $url = $self->api_url("/rpc/libraries/".$self->library_id."/patrons/".uri_escape($cardnum_or_email));
71
    return $self->get_response($url);
72
}
73
74
1;
75
76
__END__
77
78
=head1 LICENSE
79
80
Copyright (C) Catalyst IT NZ Ltd
81
Copyright (C) Bywater Solutions
82
83
This library is free software; you can redistribute it and/or modify
84
it under the same terms as Perl itself.
85
86
=head1 AUTHOR
87
88
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
89
90
=cut
(-)a/lib/WebService/ILS/RecordedBooks/PartnerPatron.pm (+103 lines)
Line 0 Link Here
1
package WebService::ILS::RecordedBooks::PartnerPatron;
2
3
use Modern::Perl;
4
5
=encoding utf-8
6
7
=head1 NAME
8
9
WebService::ILS::RecordedBooks::PartnerPatron - RecordedBooks patner API
10
for an individual patron
11
12
=head1 SYNOPSIS
13
14
    use WebService::ILS::RecordedBooks::PartnerPatron;
15
16
=head1 DESCRIPTION
17
18
L<WebService::ILS::RecordedBooks::PartnerPatron> - services
19
that use trusted partner credentials to operat on behalf of a specified patron
20
21
See L<WebService::ILS::RecordedBooks::Partner>
22
23
=cut
24
25
use Carp;
26
27
use parent qw(WebService::ILS::RecordedBooks::PartnerBase);
28
29
=head1 CONSTRUCTOR
30
31
=head2 new (%params_hash or $params_hashref)
32
33
=head3 Additional constructor params:
34
35
=over 12
36
37
=item C<user_id>        => RecordedBooks user id (barcode), or email
38
39
=back
40
41
C<client_id> is either RecordedBooks id (barcode) or email
42
43
=cut
44
45
use Class::Tiny qw(
46
    user_id
47
);
48
49
__PACKAGE__->_set_param_spec({
50
    user_id => { required => 1 },
51
});
52
53
sub BUILD {
54
    my $self = shift;
55
    my $params = shift;
56
57
    local $@;
58
    my $patron_id = eval { $self->SUPER::patron_id($self->user_id) }
59
      or croak "Invalid user_id ".$self->user_id.($@ ? "\n$@" : "");
60
    $self->user_id($patron_id);
61
}
62
63
sub circulation_action_base_url {
64
    my $self = shift;
65
66
    return $self->library_action_base_url."/patrons/".$self->user_id;
67
}
68
69
sub patron_id {
70
    my $self = shift;
71
    return $self->user_id;
72
}
73
74
sub patron {
75
    my $self = shift;
76
    return {id => $self->user_id};
77
}
78
79
=head1 NATIVE METHODS
80
81
=head2 native_patron ()
82
83
This method cannot be called
84
85
=cut
86
87
1;
88
89
__END__
90
91
=head1 LICENSE
92
93
Copyright (C) Catalyst IT NZ Ltd
94
Copyright (C) Bywater Solutions
95
96
This library is free software; you can redistribute it and/or modify
97
it under the same terms as Perl itself.
98
99
=head1 AUTHOR
100
101
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
102
103
=cut
(-)a/lib/WebService/ILS/RecordedBooks/Patron.pm (+109 lines)
Line 0 Link Here
1
package WebService::ILS::RecordedBooks::Patron;
2
3
use Modern::Perl;
4
5
=encoding utf-8
6
7
=head1 NAME
8
9
WebService::ILS::RecordedBooks::Patron - RecordedBooks patron API
10
11
=head1 SYNOPSIS
12
13
    use WebService::ILS::RecordedBooks::Patron;
14
15
=cut
16
17
=head1 DESCRIPTION
18
19
L<WebService::ILS::RecordedBooks::Patron> - services
20
that require patron credentials
21
22
See L<WebService::ILS::RecordedBooks>
23
24
=cut
25
26
use Carp;
27
28
use parent qw(WebService::ILS::RecordedBooks);
29
30
=head1 CONSTRUCTOR
31
32
=head2 new (%params_hash or $params_hashref)
33
34
=head3 Additional constructor params:
35
36
=over 16
37
38
=item C<user_id>
39
40
=item C<password>
41
42
=back
43
44
=cut
45
46
use Class::Tiny qw(
47
    user_id password
48
);
49
50
__PACKAGE__->_set_param_spec({
51
    user_id       => { required => 1 },
52
    password      => { required => 1 },
53
});
54
55
56
sub _access_auth_string {
57
    my $self = shift;
58
    return $self->client_secret;
59
}
60
61
sub _extract_token_from_response {
62
    my $self = shift;
63
    my $data = shift;
64
65
    return ($data->{bearer}, "bearer");
66
}
67
68
sub make_access_token_request {
69
    my $self = shift;
70
71
    my $url = $self->api_url("/tokens");
72
    my %params = (
73
        UserName => $self->user_id,
74
        Password => $self->password,
75
        LibraryId => $self->library_id,
76
    );
77
    my $req = HTTP::Request::Common::POST( $url );
78
    return $self->_json_request_content($req, \%params);
79
}
80
81
sub title_url {
82
    my $self = shift;
83
    my $isbn = shift or croak "No isbn";
84
    return $self->api_url("/titles/$isbn");
85
}
86
87
sub circulation_action_base_url {
88
    my $self = shift;
89
90
    return $self->api_url("/transactions");
91
}
92
93
1;
94
95
__END__
96
97
=head1 LICENSE
98
99
Copyright (C) Catalyst IT NZ Ltd
100
Copyright (C) Bywater Solutions
101
102
This library is free software; you can redistribute it and/or modify
103
it under the same terms as Perl itself.
104
105
=head1 AUTHOR
106
107
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
108
109
=cut
(-)a/lib/WebService/ILS/XML.pm (-1 / +184 lines)
Line 0 Link Here
0
- 
1
package WebService::ILS::XML;
2
3
use Modern::Perl;
4
5
=encoding utf-8
6
7
=head1 NAME
8
9
WebService::ILS::JSON - WebService::ILS module for services with XML API
10
11
=head1 DESCRIPTION
12
13
To be subclassed
14
15
See L<WebService::ILS>
16
17
=cut
18
19
use Carp;
20
use HTTP::Request::Common;
21
use URI;
22
use XML::LibXML;
23
24
use parent qw(WebService::ILS);
25
26
sub with_get_request {
27
    my $self = shift;
28
    my $callback = shift or croak "No callback";
29
    my $url = shift or croak "No url";
30
    my $get_params = shift; # hash ref
31
32
    my $uri = URI->new($url);
33
    $uri->query_form($get_params) if $get_params;
34
    my $request = HTTP::Request::Common::GET( $uri );
35
    my $response = $self->_request_with_auth($request);
36
    return $self->process_xml_response($response, $callback);
37
}
38
39
sub with_delete_request {
40
    my $self = shift;
41
    my $callback = shift or croak "No callback";
42
    my $error_callback = shift;
43
    my $url = shift or croak "No url";
44
45
    my $request = HTTP::Request::Common::DELETE( $url );
46
    my $response = $self->_request_with_auth($request);
47
    return 1 if $response->is_success;
48
49
    return $self->_error_result(
50
        sub { $self->process_invalid_xml_response($response, $error_callback); },
51
        $request,
52
        $response
53
    );
54
}
55
56
sub with_post_request {
57
    my $self = shift;
58
    my $callback = shift or croak "No callback";
59
    my $url = shift or croak "No url";
60
    my $post_params = shift || {}; # hash ref
61
62
    my $request = HTTP::Request::Common::POST( $url, $post_params );
63
    my $response = $self->_request_with_auth($request);
64
    return $self->process_xml_response($response, $callback);
65
}
66
67
sub with_xml_request {
68
    my $self = shift;
69
    my $callback = shift or croak "No callback";
70
    my $error_callback = shift;
71
    my $url = shift or croak "No url";
72
    my $dom = shift or croak "No XML document";
73
    my $method = shift || 'post';
74
75
    my $req_builder = "HTTP::Request::Common::".uc( $method );
76
    no strict 'refs';
77
    my $request = $req_builder->( $url );
78
    $request->header( 'Content-Type' => 'application/xml; charset=utf-8' );
79
    $request->content( $dom->toeString );
80
    $request->header( 'Content-Length' => bytes::length($request->content));
81
    my $response = $self->_request_with_auth($request);
82
    return $self->process_xml_response($response, $callback, $error_callback);
83
}
84
85
sub process_xml_response {
86
    my $self = shift;
87
    my $response = shift or croak "No response";
88
    my $success_callback = shift;
89
    my $error_callback = shift;
90
91
    unless ($response->is_success) {
92
        return $self->process_xml_error_response($response, $error_callback);
93
    }
94
95
    my $content_type = $response->header('Content-Type');
96
    die $response->as_string
97
        unless $content_type && $content_type =~ m!application/xml!;
98
    my $content = $response->decoded_content
99
        or die $self->invalid_response_exception_string($response);
100
101
    local $@;
102
103
    my $doc = eval { XML::LibXML->load_xml( string => $content )->documentElement() };
104
    #XXX check XML::LibXML::Error
105
    die "$@\nResponse:\n".$response->as_string if $@;
106
107
    return $doc unless $success_callback;
108
109
    my $res = eval {
110
        $success_callback->($doc);
111
    };
112
    die "$@\nResponse:\n$content" if $@;
113
    return $res;
114
}
115
116
sub process_xml_error_response {
117
    my $self = shift;
118
    my $response = shift or croak "No response";
119
    my $error_callback = shift;
120
121
    my $content_type = $response->header('Content-Type');
122
    if ($content_type && $content_type =~ m!application/xml!) {
123
        my $content = $response->decoded_content
124
            or die $self->invalid_response_exception_string($response);
125
126
        my $doc = eval { XML::LibXML->load_xml( string => $content )->documentElement() };
127
        #XXX check XML::LibXML::Error
128
        die "$@\nResponse:\n$content" if $@;
129
130
        if ($error_callback) {
131
            return $error_callback->($doc);
132
        }
133
134
        die $self->_error_from_xml($doc) || "Invalid response:\n$content";
135
    }
136
    die $self->invalid_response_exception_string($response);
137
}
138
139
sub _error_from_xml {};
140
141
sub _first_child_content {
142
    my $self = shift;
143
    my $parent_elt = shift or croak "No parent element";
144
    my $tag = shift or croak "No child tag name";
145
146
    my $child_elts = $parent_elt->getElementsByTagName($tag) or return;
147
    my $child_elt = $child_elts->shift or return;
148
    return $child_elt->textContent;
149
}
150
151
sub _children_content {
152
    my $self = shift;
153
    my $parent_elt = shift or croak "No parent element";
154
    my $tag = shift or croak "No child tag name";
155
156
    my $child_elts = $parent_elt->getElementsByTagName($tag) or return;
157
    return [ $child_elts->map( sub { $_[0]->textContent } ) ];
158
}
159
160
sub _xml_to_hash {
161
    my $self = shift;
162
    my $parent_elt = shift or croak "No parent element";
163
    my $tags = shift or croak "No children tag names";
164
165
    return { map { $_ => $self->_first_child_content($parent_elt, $_) } @$tags };
166
}
167
168
1;
169
170
__END__
171
172
=head1 LICENSE
173
174
Copyright (C) Catalyst IT NZ Ltd
175
Copyright (C) Bywater Solutions
176
177
This library is free software; you can redistribute it and/or modify
178
it under the same terms as Perl itself.
179
180
=head1 AUTHOR
181
182
Srdjan Janković E<lt>srdjan@catalyst.net.nzE<gt>
183
184
=cut

Return to bug 41521