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 # For find_bibliographic_ids:
  27 use NCIP::Item::BibliographicItemId;
  28 use NCIP::Item::BibliographicRecordId;
  29
  30 =head1 NAME
  31
  32 NCIP::ILS - A base class for NIPServer ILS drivers.
  33
  34 =head1 SYNOPSIS
  35
  36     use NCIP::ILS;
  37
  38     $ils = NCIP::ILS->new(name => $config->{NCIP.ils.value});
  39
  40 =head1 DESCRIPTION
  41
  42 NCIP::ILS is meant as a base class and test implementation of the ILS
  43 specific drivers of NCIPServer.  If you wish to implement a driver for
  44 your specific ILS, then it is recommended you subclass this module and
  45 reimplement the methods as necessary.
  46
  47 =cut
  48
  49 sub new {
  50     my $invocant = shift;
  51     my $class = ref $invocant || $invocant;
  52     my $self = bless {@_}, $class;
  53     return $self;
  54 }
  55
  56 =head1 HANDLER METHODS
  57
  58 When NCIPServer receives an incoming message, it translates the
  59 requested service into lower case and then checks if the ILS has a
  60 method by that name.  If it does that method is called with a single
  61 argument consisting of the XML request converted to a hash ref via
  62 XML::LibXML::Simple.  If the ILS does not support that service, then
  63 the unsupportedservice method of the ILS is called and the resulting
  64 problem response returned to the client.
  65
  66 All handler methods must return a NCIP::Response object.
  67
  68 The handler methods provided in this base class implementation are
  69 those that were required for the initial implemenation of NCIPServer
  70 to be used with a particular initiator software.  You may add any
  71 additional handlers to your implementation as required without needing
  72 to alter this base class.
  73
  74 =cut
  75
  76 # Methods required for SHAREit:
  77
  78 =head2 acceptitem
  79
  80 Called to handle the AcceptItem service request.  The inherited
  81 implementation returns the Unsupported Service problem response.
  82
  83 =cut
  84
  85 sub acceptitem {
  86     my $self = shift;
  87     my $request = shift;
  88
  89     return $self->unsupportedservice($request);
  90 }
  91
  92 =head2 cancelrequestitem
  93
  94 Called to handle the CancelRequestItem service request.  The inherited
  95 implementation returns the Unsupported Service problem response.
  96
  97 =cut
  98
  99 sub cancelrequestitem {
 100     my $self = shift;
 101     my $request = shift;
 102
 103     return $self->unsupportedservice($request);
 104 }
 105
 106 =head2 checkinitem
 107
 108 Called to handle the CheckInItem service request.  The inherited
 109 implementation returns the Unsupported Service problem response.
 110
 111 =cut
 112
 113 sub checkinitem {
 114     my $self = shift;
 115     my $request = shift;
 116
 117     return $self->unsupportedservice($request);
 118 }
 119
 120 =head2 checkoutitem
 121
 122 Called to handle the CheckOutItem service request.  The inherited
 123 implementation returns the Unsupported Service problem response.
 124
 125 =cut
 126
 127 sub checkoutitem {
 128     my $self = shift;
 129     my $request = shift;
 130
 131     return $self->unsupportedservice($request);
 132 }
 133
 134 =head2 lookupuser
 135
 136 Called to handle the LookupUser service request.  The inherited
 137 implementation returns the Unsupported Service problem response.
 138
 139 =cut
 140
 141 sub lookupuser {
 142     my $self = shift;
 143     my $request = shift;
 144
 145     return $self->unsupportedservice($request);
 146 }
 147
 148 =head2 renewitem
 149
 150 Called to handle the RenewItem service request.  The inherited
 151 implementation returns the Unsupported Service problem response.
 152
 153 =cut
 154
 155 sub renewitem {
 156     my $self = shift;
 157     my $request = shift;
 158
 159     return $self->unsupportedservice($request);
 160 }
 161
 162 =head2 requestitem
 163
 164 Called to handle the RequestItem service request.  The inherited
 165 implementation returns the Unsupported Service problem response.
 166
 167 =cut
 168
 169 sub requestitem {
 170     my $self = shift;
 171     my $request = shift;
 172
 173     return $self->unsupportedservice($request);
 174 }
 175
 176 # Other methods, just because.
 177
 178 =head2 lookupversion
 179
 180 Called to handle the LookupVersion service request.  The inherited
 181 implementation returns the list of supported versions from
 182 NCIP::Const.  You probably do not want to reimplement this method in
 183 your subclass.
 184
 185 =cut
 186
 187 sub lookupversion {
 188     my $self = shift;
 189     my $request = shift;
 190
 191     my $response = NCIP::Response->new({type => "LookupVersionResponse"});
 192     my $payload = {
 193         fromagencyid => $request->{LookupVersion}->{ToAgencyId}->{AgencyId},
 194         toagencyid => $request->{LookupVersion}->{FromAgencyId}->{AgencyId},
 195         versions => [ NCIP::Const::SUPPORTED_VERSIONS ]
 196     };
 197     $response->data($payload);
 198
 199     return $response;
 200 }
 201
 202 =head1 USEFUL METHODS
 203
 204 These are methods of the base class that you may want to use in your
 205 subclass or that are used by NCIPserver or other methods of this base
 206 class.  You very likely do not want to override these in your
 207 subclass.
 208
 209 =cut
 210
 211 =head2 unsupportedservice
 212
 213     $response = $ils->unsupportedservice($request);
 214
 215 This method has the same signature as a regular service handler
 216 method.  It returns a response containing an Unsupported Service
 217 problem.  It is used by NCIP.pm when the ILS cannot handle a message,
 218 or your implementation could return this in the case of a
 219 service/message you don't actually handle, though you may have the
 220 proper function defined.
 221
 222 =cut
 223
 224 sub unsupportedservice {
 225     my $self = shift;
 226     my $request = shift;
 227
 228     my $service = $self->parse_request_type($request);
 229
 230     my $response = NCIP::Response->new({type => $service . 'Response'});
 231     my $problem = NCIP::Problem->new();
 232     $problem->ProblemType('Unsupported Service');
 233     $problem->ProblemDetail("$service service is not supported by this implementation.");
 234     $problem->ProblemElement("NULL");
 235     $problem->ProblemValue("Not Supported");
 236     $response->problem($problem);
 237
 238     return $response;
 239 }
 240
 241 =head2 make_header
 242
 243     $response->header($ils->make_header($request));
 244
 245 All subclasses will possibly want to create a ResponseHeader for the
 246 response message.  Since the code for that could be highly redundant
 247 if reimplemented by each subclass, the base class supplies an
 248 implementation that retrieves the agency information from the
 249 InitiationHeader of the request message, swaps the FromAgencyId with
 250 the ToAgencyId, and vice versa.  It then returns a NCIP::Header to be
 251 used in the NCIP::Response object's header field.
 252
 253 =cut
 254
 255 sub make_header {
 256     my $self = shift;
 257     my $request = shift;
 258
 259     my $initheader;
 260     my $header;
 261
 262     my $key = $self->parse_request_type($request);
 263     $initheader = $request->{$key}->{InitiationHeader}
 264         if ($key && $request->{$key}->{InitiationHeader});
 265
 266     if ($initheader && $initheader->{FromAgencyId}
 267             && $initheader->{ToAgencyId}) {
 268         $header = NCIP::Header->new({
 269             FromAgencyId => $initheader->{ToAgencyId},
 270             ToAgencyId => $initheader->{FromAgencyId}
 271         });
 272     }
 273
 274     return $header;
 275 }
 276
 277 =head2 parse_request_type
 278
 279     $type = $ils->parse_request_type($request);
 280
 281 Given the request hashref object, parse_request_type will return the
 282 service being requested in the message.  This method is called by
 283 NCIP.pm in order to determine which handler of the ILS object to call.
 284 You may find it convenient to use this method in your own handler
 285 implementations.  You should not need to override this method in your
 286 subclass.
 287
 288 =cut
 289
 290 sub parse_request_type {
 291     my $self = shift;
 292     my $request = shift;
 293     my $type;
 294
 295     for my $key (keys %$request) {
 296         if (ref $request->{$key} eq 'HASH') {
 297             $type = $key;
 298             last;
 299         }
 300     }
 301
 302     return $type;
 303 }
 304
 305 =head2 find_user_barcode
 306
 307     $barcode = $ils->find_user_barcode($request);
 308     ($barcode, $field) = $ils->find_user_barcode($request);
 309
 310 If you have a request type that includes a user barcode identifier
 311 value, this routine will find it.
 312
 313 It will return the barcode in scalar context, or the barcode and the
 314 tag of the field where the barcode was found in list context.
 315
 316 If multiple barcode fields are provided, it returns the first one that
 317 it finds. This is not necessarily the first one given in the request
 318 message. Maybe we should add a plural form of this method to find all
 319 of the user barcodes provided?
 320
 321 =cut
 322
 323 sub find_user_barcode {
 324     my $self = shift;
 325     my $request = shift;
 326
 327     my $barcode;
 328     my $field;
 329     my $message = $self->parse_request_type($request);
 330
 331     # Check for UserId first because it is valid in all messages.
 332     my $authinput = $request->{$message}->{UserId};
 333     if ($authinput) {
 334         $field = 'UserIdentifierValue';
 335         $barcode = $authinput->{$field};
 336     } elsif (grep {$_ eq $message} NCIP::Const::AUTHENTICATIONINPUT_MESSAGES) {
 337         $field = 'AuthenticationInputData';
 338         $authinput = $request->{$message}->{AuthenticationInput};
 339         # Convert to array ref if it isn't already.
 340         if (ref $authinput ne 'ARRAY') {
 341             $authinput = [$authinput];
 342         }
 343         foreach my $input (@$authinput) {
 344             if ($input->{AuthenticationInputType} =~ /barcode/i) {
 345                 $barcode = $input->{$field};
 346                 last;
 347             }
 348         }
 349     }
 350
 351     return (wantarray) ? ($barcode, $field) : $barcode;
 352 }
 353
 354 =head2 find_item_barcode
 355
 356     $barcode = $ils->find_item_barcode($request);
 357     ($barcode, $field) = $ils->find_item_barcode($request);
 358
 359 If you have a request type that includes an item barcode identifier
 360 value, this routine will find it.
 361
 362 It will return the barcode in scalar context, or the barcode and the
 363 tag of the field where the barcode was found in list context.
 364
 365 If multiple barcode fields are provided, it returns the first one that
 366 it finds. This is not necessarily the first one given in the request
 367 message. Maybe we should add a plural form of this method to find all
 368 of the item barcodes provided?
 369
 370 =cut
 371
 372 sub find_item_barcode {
 373     my $self = shift;
 374     my $request = shift;
 375
 376     my $barcode;
 377     my $field;
 378     my $message = $self->parse_request_type($request);
 379
 380     my $idinput = $request->{$message}->{ItemId};
 381     if ($idinput) {
 382         $field = 'ItemIdentifierValue';
 383         $idinput = [$idinput] unless (ref($idinput) eq 'ARRAY');
 384         foreach my $input (@$idinput) {
 385             if ($input->{ItemIdentifierType}) {
 386                 next unless ($input->{ItemIdentifierType} =~ /barcode/i);
 387             }
 388             $barcode = $input->{ItemIdentifierValue};
 389             last if ($barcode);
 390         }
 391     }
 392
 393     return (wantarray) ? ($barcode, $field) : $barcode;
 394 }
 395
 396 =head2 find_bibliographic_ids
 397
 398     $biblio_ids = $ils->find_bibliographic_ids($request);
 399     @biblio_ids = $ils->find_bibliographic_ids($request);
 400
 401 Finds the BibliograpicId tags in the request message and returns a
 402 list of NCIP::Item::BibliographicItemId or
 403 NCIP::Item::BibliographicRecordId depending upon which are found in
 404 the request, either or both could be present. If no BibliographicId is
 405 found, then it returns an empty list.
 406
 407 In array context, it returns an array, in scalar context, an array
 408 ref.
 409
 410 =cut
 411
 412 sub find_bibliographic_ids {
 413     my $self = shift;
 414     my $request = shift;
 415     my $idcode = shift;
 416
 417     # Our return variable, so set this if we find any ids.
 418     my @ids = ();
 419
 420     my $message = $self->parse_request_type($request);
 421
 422     # Find the BibliographicId in the xml.
 423     my $idxml;
 424     if ($request->{$message}->{ItemOptionalFields}->{BibligraphicDescription}) {
 425         $idxml = $request->{$message}->{ItemOptionalFields}->{BibligraphicDescription}->{BibliographicId};
 426     } elsif ($request->{$message}->{BibliographicDescription}) {
 427         $idxml = $request->{$message}->{BibliographicDescription}->{BibliographicId};
 428     } else {
 429         $idxml = $request->{$message}->{BibliographicId};
 430     }
 431     if ($idxml) {
 432         $idxml = [$idxml] unless (ref($idxml) eq 'ARRAY');
 433         foreach my $entry (@$idxml) {
 434             my $id;
 435             if ($entry->{BibliographicRecordId}) {
 436                 my ($identifier, $agencyid, $code);
 437                 $identifier = $entry->{BibliographicRecordId}->{BibliographicRecordIdentifier};
 438                 $code = $entry->{BibliographicRecordId}->{BibliographicRecordIdentifierCode};
 439                 $agencyid = $entry->{BibliographicRecordId}->{AgencyId};
 440                 $id = NCIP::Item::BibliographicRecordId->new(
 441                     {
 442                         BibliographicRecordIdentifier => $identifier,
 443                         BibliographicRecordIdentifierCode => $code,
 444                         AgencyId => $agencyid
 445                     }
 446                 );
 447             } else {
 448                 my ($identifier, $code);
 449                 $identifier = $entry->{BibliographicItemId}->{BibliographicItemIdentifier};
 450                 $code = $entry->{BibliographicItemId}->{BibliographicItemIdentifierCode};
 451                 $id = NCIP::Item::BibliographicItemId->new(
 452                     {
 453                         BibliographicItemIdentifier => $identifier,
 454                         BibliographicItemIdentifierCode => $code
 455                     }
 456                 );
 457             }
 458             push(@ids, $id);
 459         }
 460     }
 461
 462     return (wantarray) @ids : [@ids];
 463 }
 464
 465 1;