73f26a095491df8841b25af134dbc5748880fa53
[working/NCIPServer.git] / lib / NCIP / ILS.pm
1 # ---------------------------------------------------------------
2 # Copyright © 2014 Jason J.A. Stephenson <jason@sigio.com>
3 #
4 # This file is part of NCIPServer.
5 #
6 # NCIPServer is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 2 of the License, or
9 # (at your option) any later version.
10 #
11 # NCIPServer is distributed in the hope that it will be useful, but
12 # WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14 # General Public License for more details.
15 #
16 # You should have received a copy of the GNU General Public License
17 # along with NCIPServer.  If not, see <http://www.gnu.org/licenses/>.
18 # ---------------------------------------------------------------
19 package NCIP::ILS;
20
21 use Modern::Perl;
22 use NCIP::Const;
23 use NCIP::Header;
24 use NCIP::Problem;
25 use NCIP::Response;
26
27 =head1 NAME
28
29 NCIP::ILS - A base class for NIPServer ILS drivers.
30
31 =head1 SYNOPSIS
32
33 C<use NCIP::ILS;>
34
35 C<my $ils = NCIP::ILS-E<gt>new(name =E<gt> $config-E<gt>{NCIP.ils.value});>
36
37 =head1 DESCRIPTION
38
39 NCIP::ILS is meant as a base class and test implementation of the ILS
40 specific drivers of NCIPServer.  If you wish to implement a driver for
41 your specific ILS, then it is recommended you subclass this module and
42 reimplement the methods as necessary.
43
44 =cut
45
46 sub new {
47     my $invocant = shift;
48     my $class = ref $invocant || $invocant;
49     my $self = bless {@_}, $class;
50     return $self;
51 }
52
53 =head1 HANDLER METHODS
54
55 When NCIPServer receives an incoming message, it translates the
56 requested service into lower case and then checks if the ILS has a
57 method by that name.  If it does that method is called with a single
58 argument consisting of the XML request converted to a hash ref via
59 XML::LibXML::Simple.  If the ILS does not support that service, then
60 the unsupportedservice method of the ILS is called and the resulting
61 problem response returned to the client.
62
63 All handler methods must return a NCIP::Response object.
64
65 The handler methods provided in this base class implementation are
66 those that were required for the initial implemenation of NCIPServer
67 to be used with a particular initiator software.  You may add any
68 additional handlers to your implementation as required without needing
69 to alter this base class.
70
71 =cut
72
73 # Methods required for SHAREit:
74
75 =head2 acceptitem
76
77 Called to handle the AcceptItem service request.  The inherited
78 implementation returns the Unsupported Service problem response.
79
80 =cut
81
82 sub acceptitem {
83     my $self = shift;
84     my $request = shift;
85
86     return $self->unsupportedservice($request);
87 }
88
89 =head2 cancelrequestitem
90
91 Called to handle the CancelRequestItem service request.  The inherited
92 implementation returns the Unsupported Service problem response.
93
94 =cut
95
96 sub cancelrequestitem {
97     my $self = shift;
98     my $request = shift;
99
100     return $self->unsupportedservice($request);
101 }
102
103 =head2 checkinitem
104
105 Called to handle the CheckInItem service request.  The inherited
106 implementation returns the Unsupported Service problem response.
107
108 =cut
109
110 sub checkinitem {
111     my $self = shift;
112     my $request = shift;
113
114     return $self->unsupportedservice($request);
115 }
116
117 =head2 checkoutitem
118
119 Called to handle the CheckOutItem service request.  The inherited
120 implementation returns the Unsupported Service problem response.
121
122 =cut
123
124 sub checkoutitem {
125     my $self = shift;
126     my $request = shift;
127
128     return $self->unsupportedservice($request);
129 }
130
131 =head2 lookupuser
132
133 Called to handle the LookupUser service request.  The inherited
134 implementation returns the Unsupported Service problem response.
135
136 =cut
137
138 sub lookupuser {
139     my $self = shift;
140     my $request = shift;
141
142     return $self->unsupportedservice($request);
143 }
144
145 =head2 renewitem
146
147 Called to handle the RenewItem service request.  The inherited
148 implementation returns the Unsupported Service problem response.
149
150 =cut
151
152 sub renewitem {
153     my $self = shift;
154     my $request = shift;
155
156     return $self->unsupportedservice($request);
157 }
158
159 =head2 requestitem
160
161 Called to handle the RequestItem service request.  The inherited
162 implementation returns the Unsupported Service problem response.
163
164 =cut
165
166 sub requestitem {
167     my $self = shift;
168     my $request = shift;
169
170     return $self->unsupportedservice($request);
171 }
172
173 # Other methods, just because.
174
175 =head2 lookupversion
176
177 Called to handle the LookupVersion service request.  The inherited
178 implementation returns the list of supported versions from
179 NCIP::Const.  You probably do not want to reimplement this method in
180 your subclass.
181
182 =cut
183
184 sub lookupversion {
185     my $self = shift;
186     my $request = shift;
187
188     my $response = NCIP::Response->new({type => "LookupVersionResponse"});
189     my $payload = {
190         fromagencyid => $request->{LookupVersion}->{ToAgencyId}->{AgencyId},
191         toagencyid => $request->{LookupVersion}->{FromAgencyId}->{AgencyId},
192         versions => [ NCIP::Const::SUPPORTED_VERSIONS ]
193     };
194     $response->data($payload);
195
196     return $response;
197 }
198
199 =head1 USEFUL METHODS
200
201 These are methods of the base class that you may want to use in your
202 subclass or that are used by NCIPserver or other methods of this base
203 class.  You very likely do not want to override these in your
204 subclass.
205
206 =cut
207
208 =head2 unsupportedservice
209
210 C<my $response = $ils-E<gt>unsupportedservice($request);>
211
212 This method has the same signature as a regular service handler
213 method.  It returns a response containing an Unsupported Service
214 problem.  It is used by NCIP.pm when the ILS cannot handle a message,
215 or your implementation could return this in the case of a
216 service/message you don't actually handle, though you may have the
217 proper function defined.
218
219 =cut
220
221 sub unsupportedservice {
222     my $self = shift;
223     my $request = shift;
224
225     my $service = $self->parse_request_type($request);
226
227     my $response = NCIP::Response->new({type => $service . 'Response'});
228     my $problem = NCIP::Problem->new();
229     $problem->ProblemType('Unsupported Service');
230     $problem->ProblemDetail("$service service is not supported by this implementation.");
231     $problem->ProblemElement("NULL");
232     $problem->ProblemValue("Not Supported");
233     $response->problem($problem);
234
235     return $response;
236 }
237
238 =head2 make_header
239
240 C<$response-E<gt>header($ils-E<gt>make_header($request));>
241
242 All subclasses will possibly want to create a ResponseHeader for the
243 response message.  Since the code for that could be highly redundant
244 if reimplemented by each subclass, the base class supplies an
245 implementation that retrieves the agency information from the
246 InitiationHeader of the request message, swaps the FromAgencyId with
247 the ToAgencyId, and vice versa.  It then returns a NCIP::Header to be
248 used in the NCIP::Response object's header field.
249
250 =cut
251
252 sub make_header {
253     my $self = shift;
254     my $request = shift;
255
256     my $initheader;
257     my $header;
258
259     my $key = $self->parse_request_type($request);
260     $initheader = $request->{$key}->{InitiationHeader}
261         if ($key && $request->{$key}->{InitiationHeader});
262
263     if ($initheader && $initheader->{FromAgencyId}
264             && $initheader->{ToAgencyId}) {
265         $header = NCIP::Header->new({
266             FromAgencyId => $initheader->{ToAgencyId},
267             ToAgencyId => $initheader->{FromAgencyId}
268         });
269     }
270
271     return $header;
272 }
273
274 =head2 parse_request_type
275
276 C<my $type = $ils-E<gt>parse_request_type($request);>
277
278 Given the request hashref object, parse_request_type will return the
279 service being requested in the message.  This method is called by
280 NCIP.pm in order to determine which handler of the ILS object to call.
281 You may find it convenient to use this method in your own handler
282 implementations.  You should not need to override this method in your
283 subclass.
284
285 =cut
286
287 sub parse_request_type {
288     my $self = shift;
289     my $request = shift;
290     my $type;
291
292     for my $key (keys %$request) {
293         if (ref $request->{$key} eq 'HASH') {
294             $type = $key;
295             last;
296         }
297     }
298
299     return $type;
300 }
301
302 =head2 find_user_barcode
303
304 C<my $barcode = $ils-E<gt>find_user_barcode($request);>
305
306 If you have a request type that includes a user barcode identifier
307 value, this routine will find it.
308
309 It will return the barcode in scalar context, or the barcode and the
310 tag of the field where the barcode was found in list context.
311
312 If multiple barcode fields are provided, it returns the first one that
313 it finds. This is not necessarily the first one given in the request
314 message. Maybe we should add a plural form of this method to find all
315 of the user barcodes provided?
316
317 =cut
318
319 sub find_user_barcode {
320     my $self = shift;
321     my $request = shift;
322
323     my $barcode;
324     my $field;
325     my $message = $self->parse_request_type($request);
326
327     # Check for UserId first because it is more common and still valid
328     # in LookupUser.
329     my $authinput = $request->{$message}->{UserId};
330     if ($authinput) {
331         $field = 'UserIdentifierValue';
332         if (ref $authinput ne 'ARRAY') {
333             $authinput = [$authinput];
334         }
335         foreach my $input (@$authinput) {
336             # UserIdentifierType is optional, so we check if it is
337             # there. If it is, we skip this entry unless the
338             # identifier type contains the string barcode
339             if ($input->{UserIdentifierType}) {
340                 next unless ($input->{UserIdentifierType} =~ /barcode/i);
341             }
342             # We take the first field we find, unless the
343             # identifier type says it is not a barcode.
344             $barcode = $input->{$field};
345             last;
346         }
347     } elsif ($message eq 'LookupUser') {
348         $field = 'AuthenticationInputData';
349         $authinput = $request->{$message}->{AuthenticationInput};
350         # Convert to array ref if it isn't already.
351         if (ref $authinput ne 'ARRAY') {
352             $authinput = [$authinput];
353         }
354         foreach my $input (@$authinput) {
355             if ($input->{AuthenticationInputType} =~ /barcode/i) {
356                 $barcode = $input->{$field};
357                 last;
358             }
359         }
360     }
361
362     return (wantarray) ? ($barcode, $field) : $barcode;
363 }
364
365 =head2 find_item_barcode
366
367 C<my $barcode = $ils-E<gt>find_item_barcode($request);>
368
369 If you have a request type that includes an item barcode identifier
370 value, this routine will find it.
371
372 It will return the barcode in scalar context, or the barcode and the
373 tag of the field where the barcode was found in list context.
374
375 If multiple barcode fields are provided, it returns the first one that
376 it finds. This is not necessarily the first one given in the request
377 message. Maybe we should add a plural form of this method to find all
378 of the item barcodes provided?
379
380 =cut
381
382 sub find_item_barcode {
383     my $self = shift;
384     my $request = shift;
385
386     my $barcode;
387     my $field;
388     my $message = $self->parse_request_type($request);
389
390     my $idinput = $request->{$message}->{ItemId};
391     if ($idinput) {
392         $field = 'ItemIdentifierValue';
393         $idinput = [$idinput] unless (ref($idinput) eq 'ARRAY');
394         foreach my $input (@$idinput) {
395             if ($input->{ItemIdentifierType}) {
396                 next unless ($input->{ItemIdentifierType} =~ /barcode/i);
397             }
398             $barcode = $input->{ItemIdentifierValue};
399             last if ($barcode);
400         }
401     }
402
403     return (wantarray) ? ($barcode, $field) : $barcode;
404 }
405
406 1;