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     return unless($message);
 327
 328     # Check for UserId first because it is more common and still valid
 329     # in LookupUser.
 330     my $authinput = $request->{$message}->{UserId};
 331     if ($authinput) {
 332         $field = 'UserIdentifierValue';
 333         if (ref $authinput ne 'ARRAY') {
 334             $authinput = [$authinput];
 335         }
 336         foreach my $input (@$authinput) {
 337             # UserIdentifierType is optional, so we check if it is
 338             # there. If it is, we skip this entry unless the
 339             # identifier type contains the string barcode
 340             if ($input->{UserIdentifierType}) {
 341                 next unless ($input->{UserIdentifierType} =~ /barcode/i);
 342             }
 343             # We take the first field we find, unless the
 344             # identifier type says it is not a barcode.
 345             $barcode = $input->{$field};
 346             last;
 347         }
 348     } elsif ($message eq 'LookupUser') {
 349         $field = 'AuthenticationInputData';
 350         $authinput = $request->{$message}->{AuthenticationInput};
 351         # Convert to array ref if it isn't already.
 352         if (ref $authinput ne 'ARRAY') {
 353             $authinput = [$authinput];
 354         }
 355         foreach my $input (@$authinput) {
 356             if ($input->{AuthenticationInputType} =~ /barcode/i) {
 357                 $barcode = $input->{$field};
 358                 last;
 359             }
 360         }
 361     }
 362
 363     return (wantarray) ? ($barcode, $field) : $barcode;
 364 }
 365
 366 1;