Open-ILS/src/perlmods/OpenILS/SIP.pm

   1 #
   2 # ILS.pm: Test ILS interface module
   3 #
   4
   5 package OpenILS::SIP;
   6 use warnings; use strict;
   7
   8 use Sys::Syslog qw(syslog);
   9
  10 use OpenILS::SIP::Item;
  11 use OpenILS::SIP::Patron;
  12 use OpenILS::SIP::Transaction;
  13 use OpenILS::SIP::Transaction::Checkout;
  14 use OpenILS::SIP::Transaction::Checkin;
  15 use OpenILS::SIP::Transaction::Renew;
  16
  17 use OpenSRF::System;
  18 use OpenILS::Utils::Fieldmapper;
  19 use OpenSRF::Utils::SettingsClient;
  20 use OpenILS::Application::AppUtils;
  21 use OpenSRF::Utils qw/:datetime/;
  22 use DateTime::Format::ISO8601;
  23 use Encode;
  24 use Unicode::Normalize;
  25 my $U = 'OpenILS::Application::AppUtils';
  26
  27 my $editor;
  28 my $config;
  29 my $target_encoding;    # FIXME: this is configured at the institution level.
  30
  31 use Digest::MD5 qw(md5_hex);
  32
  33 sub new {
  34         my ($class, $institution, $login) = @_;
  35         my $type = ref($class) || $class;
  36         my $self = {};
  37
  38         $self->{login} = $login;
  39
  40         $config = $institution;
  41         syslog("LOG_DEBUG", "OILS: new ILS '%s'", $institution->{id});
  42         $self->{institution} = $institution;
  43
  44         my $bsconfig     = $institution->{implementation_config}->{bootstrap};
  45         $target_encoding = $institution->{implementation_config}->{encoding} || 'ascii';
  46
  47         syslog('LOG_DEBUG', "OILS: loading bootstrap config: $bsconfig");
  48
  49         local $/ = "\n";    # why?
  50         OpenSRF::System->bootstrap_client(config_file => $bsconfig);
  51         syslog('LOG_DEBUG', "OILS: bootstrap loaded..");
  52
  53         $self->{osrf_config} = OpenSRF::Utils::SettingsClient->new;
  54
  55         Fieldmapper->import($self->{osrf_config}->config_value('IDL'));
  56
  57         bless( $self, $type );
  58
  59         return undef unless
  60                 $self->login( $login->{id}, $login->{password} );
  61
  62         return $self;
  63 }
  64
  65 sub verify_session {
  66         my $self = shift;
  67         my $ses = $U->simplereq(
  68                 'open-ils.auth',
  69                 'open-ils.auth.session.retrieve',  $self->{authtoken} );
  70         return 1 unless $U->event_code($ses);
  71         syslog('LOG_INFO', "OILS: Logging back after session timeout as user ".$self->{login}->{id});
  72         return $self->login( $self->{login}->{id}, $self->{login}->{password} );
  73 }
  74
  75 sub editor {
  76         return $editor = make_editor();
  77 }
  78
  79 sub config {
  80         return $config;
  81 }
  82
  83
  84 # Creates the global editor object
  85 my $cstore_init = 1; # call init on first use
  86 sub make_editor {
  87     OpenILS::Utils::CStoreEditor::init() if $cstore_init;
  88     $cstore_init = 0;
  89         return OpenILS::Utils::CStoreEditor->new;
  90 }
  91
  92 =head2 clean_text(scalar)
  93
  94 Evergreen uses the UTF8 encoding for everything from the database up. Perl
  95 doesn't know this, however, so we have to convince it to treat our UTF8 strings
  96 as UTF8 strings. This may enable OpenNCIP to correctly calculate the checksums
  97 for UTF8 text for SIP clients that support such modern options.
  98
  99 The target encoding is set in the <encoding> element of the SIPServer.pm
 100 configuration file.
 101
 102 =cut
 103
 104 sub clean_text {
 105     my $text = shift || '';
 106
 107     # Convert our incoming UTF8 data into Perl's internal string format
 108
 109     # Also convert to Normalization Form D, as the ASCII, iso-8859-1,
 110     # and latin-1 encodings (at least) require this to substitute
 111     # characters rather than simply returning a string truncated
 112     # after the first non-ASCII character
 113     $text = NFD(decode_utf8($text));
 114
 115     if ($target_encoding eq 'ascii') {
 116
 117         # Try to maintain a reasonable version of the content by
 118         # stripping diacritics from the text, given that the SIP client
 119         # wants just plain ASCII. This is the base requirement according
 120         # to the SIP2 specification.
 121
 122         # Stripping the combining characters converts ""béè♁ts"
 123         # into "bee?ts" instead of "b???ts" - better, eh?
 124         $text =~ s/\pM+//og;
 125     }
 126
 127     # Characters that cannot be represented in the target encoding will
 128     # generally be replaced with a question mark (?) character.
 129     $text = encode($target_encoding, $text);
 130
 131     return $text;
 132 }
 133
 134 sub shortname_from_id {
 135     my $id = shift or return;
 136     return editor()->search_actor_org_unit({id => $id})->[0]->shortname;
 137 }
 138 sub patron_barcode_from_id {
 139     my $id = shift or return;
 140     return editor()->search_actor_card({ usr => $id, active => 't' })->[0]->barcode;
 141 }
 142
 143 sub format_date {
 144         my $class = shift;
 145         my $date = shift;
 146         my $type = shift || 'dob';
 147
 148         return "" unless $date;
 149
 150         $date = DateTime::Format::ISO8601->new->
 151                 parse_datetime(OpenSRF::Utils::cleanse_ISO8601($date));
 152         my @time = localtime($date->epoch);
 153
 154         my $year   = $time[5]+1900;
 155         my $mon    = $time[4]+1;
 156         my $day    = $time[3];
 157         my $hour   = $time[2];
 158         my $minute = $time[1];
 159         my $second = $time[0];
 160
 161         $date = sprintf("%04d%02d%02d", $year, $mon, $day);
 162
 163         # Due dates need hyphen separators and time of day as well
 164         if ($type eq 'due') {
 165                 $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year, $mon, $day, $hour, $minute, $second);
 166         }
 167
 168         syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
 169         return $date;
 170 }
 171
 172
 173
 174 sub login {
 175         my( $self, $username, $password ) = @_;
 176         syslog('LOG_DEBUG', "OILS: Logging in with username $username");
 177
 178         my $seed = $U->simplereq(
 179                 'open-ils.auth',
 180                 'open-ils.auth.authenticate.init', $username );
 181
 182         my $response = $U->simplereq(
 183                 'open-ils.auth',
 184                 'open-ils.auth.authenticate.complete',
 185                 {
 186                         username => $username,
 187                         password => md5_hex($seed . md5_hex($password)),
 188                         type     => 'opac',
 189                 }
 190         );
 191
 192         if( my $code = $U->event_code($response) ) {
 193                 my $txt = $response->{textcode};
 194                 syslog('LOG_WARNING', "OILS: Login failed for $username.  $txt:$code");
 195                 return undef;
 196         }
 197
 198         my $key = $response->{payload}->{authtoken};
 199         syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
 200         return $self->{authtoken} = $key;
 201 }
 202
 203
 204 sub find_patron {
 205         my $self = shift;
 206         return OpenILS::SIP::Patron->new(@_);
 207 }
 208
 209
 210 sub find_item {
 211         my $self = shift;
 212         return OpenILS::SIP::Item->new(@_);
 213 }
 214
 215
 216 sub institution {
 217     my $self = shift;
 218     return $self->{institution}->{id};  # consider making this return the whole institution
 219 }
 220
 221 sub institution_id {
 222     my $self = shift;
 223     return $self->{institution}->{id};  # then use this for just the ID
 224 }
 225
 226 sub supports {
 227         my ($self, $op) = @_;
 228         my ($i) = grep { $_->{name} eq $op }
 229                 @{$config->{implementation_config}->{supports}->{item}};
 230         return to_bool($i->{value});
 231 }
 232
 233 sub check_inst_id {
 234     my ($self, $id, $whence) = @_;
 235     if ($id ne $self->{institution}->{id}) {
 236         syslog("LOG_WARNING", "OILS: %s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
 237         # Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
 238     }
 239 }
 240
 241
 242 sub to_bool {
 243     my $bool = shift;
 244     # If it's defined, and matches a true sort of string, or is
 245     # a non-zero number, then it's true.
 246     defined($bool) or return;                   # false
 247     ($bool =~ /true|y|yes/i) and return 1;      # true
 248     return ($bool =~ /^\d+$/ and $bool != 0);   # true for non-zero numbers, false otherwise
 249 }
 250
 251 sub checkout_ok {
 252         return to_bool($config->{policy}->{checkout});
 253 }
 254
 255 sub checkin_ok {
 256         return to_bool($config->{policy}->{checkin});
 257 }
 258
 259 sub renew_ok {
 260         return to_bool($config->{policy}->{renew});
 261 }
 262
 263 sub status_update_ok {
 264         return to_bool($config->{policy}->{status_update});
 265 }
 266
 267 sub offline_ok {
 268         return to_bool($config->{policy}->{offline});
 269 }
 270
 271
 272
 273 ##
 274 ## Checkout(patron_id, item_id, sc_renew):
 275 ##    patron_id & item_id are the identifiers send by the terminal
 276 ##    sc_renew is the renewal policy configured on the terminal
 277 ## returns a status opject that can be queried for the various bits
 278 ## of information that the protocol (SIP or NCIP) needs to generate
 279 ## the response.
 280 ##
 281
 282 sub checkout {
 283         my ($self, $patron_id, $item_id, $sc_renew) = @_;
 284         $sc_renew = 0;
 285
 286         $self->verify_session;
 287
 288         syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
 289
 290     my $xact   = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
 291     my $patron = $self->find_patron($patron_id);
 292     my $item   = $self->find_item($item_id);
 293
 294         $xact->patron($patron);
 295         $xact->item($item);
 296
 297         if (!$patron) {
 298                 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
 299                 return $xact;
 300         }
 301
 302         if (!$patron->charge_ok) {
 303                 $xact->screen_msg("Patron Blocked");
 304                 return $xact;
 305         }
 306
 307         if( !$item ) {
 308                 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
 309                 return $xact;
 310         }
 311
 312         syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
 313
 314         if ($item->{patron} && ($item->{patron} eq $patron_id)) {
 315                 syslog('LOG_INFO', "OILS: OpenILS::Checkout data loaded OK, doing renew...");
 316                 $sc_renew = 1;
 317         } elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
 318                 # I can't deal with this right now
 319                 # XXX check in then check out?
 320                 $xact->screen_msg("Item checked out to another patron");
 321                 $xact->ok(0);
 322         }
 323
 324         $xact->do_checkout($sc_renew);
 325         $xact->desensitize(!$item->magnetic);
 326
 327         if( $xact->ok ) {
 328                 #editor()->commit;
 329                 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
 330                         "patron %s checkout %s succeeded", $patron_id, $item_id);
 331         } else {
 332                 #editor()->xact_rollback;
 333                 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
 334                         "patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
 335         }
 336
 337         return $xact;
 338 }
 339
 340
 341 sub checkin {
 342         my ($self, $item_id, $inst_id, $trans_date, $return_date,
 343         $current_loc, $item_props, $cancel) = @_;
 344
 345         $self->verify_session;
 346
 347         syslog('LOG_DEBUG', "OILS: OpenILS::Checkin of item=$item_id (to $inst_id)");
 348
 349     my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
 350     my $item = OpenILS::SIP::Item->new($item_id);
 351
 352     unless ( $xact->item($item) ) {
 353         $xact->ok(0);
 354         # $circ->alert(1); $circ->alert_type(99);
 355         $xact->screen_msg("Invalid Item Barcode: '$item_id'");
 356         syslog('LOG_INFO', "OILS: Checkin failed.  " . $xact->screen_msg() );
 357         return $xact;
 358     }
 359
 360         $xact->do_checkin( $inst_id, $trans_date, $return_date, $current_loc, $item_props );
 361
 362         if ($xact->ok) {
 363         $xact->patron($self->find_patron($item->{patron}));
 364         delete $item->{patron};
 365         delete $item->{due_date};
 366         syslog('LOG_INFO', "OILS: Checkin succeeded");
 367         #editor()->commit;
 368     } else {
 369         #editor()->xact_rollback;
 370         syslog('LOG_WARNING', "OILS: Checkin failed");
 371     }
 372
 373         return $xact;
 374 }
 375
 376 ## If the ILS caches patron information, this lets it free it up.
 377 ## Also, this could be used for centrally logging session duration.
 378 ## We don't do anything with it.
 379 sub end_patron_session {
 380     my ($self, $patron_id) = @_;
 381     return (1, 'Thank you!', '');
 382 }
 383
 384
 385 #sub pay_fee {
 386 #    my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
 387 #       $pay_type, $fee_id, $trans_id, $currency) = @_;
 388 #    my $trans;
 389 #    my $patron;
 390 #
 391 #    $trans = new ILS::Transaction::FeePayment;
 392 #
 393 #    $patron = new ILS::Patron $patron_id;
 394 #
 395 #    $trans->transaction_id($trans_id);
 396 #    $trans->patron($patron);
 397 #    $trans->ok(1);
 398 #
 399 #    return $trans;
 400 #}
 401 #
 402 #sub add_hold {
 403 #    my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
 404 #       $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
 405 #    my ($patron, $item);
 406 #    my $hold;
 407 #    my $trans;
 408 #
 409 #
 410 #    $trans = new ILS::Transaction::Hold;
 411 #
 412 #    # BEGIN TRANSACTION
 413 #    $patron = new ILS::Patron $patron_id;
 414 #    if (!$patron
 415 #       || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
 416 #       $trans->screen_msg("Invalid Patron.");
 417 #
 418 #       return $trans;
 419 #    }
 420 #
 421 #    $item = new ILS::Item ($item_id || $title_id);
 422 #    if (!$item) {
 423 #       $trans->screen_msg("No such item.");
 424 #
 425 #       # END TRANSACTION (conditionally)
 426 #       return $trans;
 427 #    } elsif ($item->fee && ($fee_ack ne 'Y')) {
 428 #       $trans->screen_msg = "Fee required to place hold.";
 429 #
 430 #       # END TRANSACTION (conditionally)
 431 #       return $trans;
 432 #    }
 433 #
 434 #    $hold = {
 435 #       item_id         => $item->id,
 436 #       patron_id       => $patron->id,
 437 #       expiration_date => $expiry_date,
 438 #       pickup_location => $pickup_location,
 439 #       hold_type       => $hold_type,
 440 #    };
 441 #
 442 #    $trans->ok(1);
 443 #    $trans->patron($patron);
 444 #    $trans->item($item);
 445 #    $trans->pickup_location($pickup_location);
 446 #
 447 #    push(@{$item->hold_queue}, $hold);
 448 #    push(@{$patron->{hold_items}}, $hold);
 449 #
 450 #
 451 #    # END TRANSACTION
 452 #    return $trans;
 453 #}
 454 #
 455 #sub cancel_hold {
 456 #    my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
 457 #    my ($patron, $item, $hold);
 458 #    my $trans;
 459 #
 460 #    $trans = new ILS::Transaction::Hold;
 461 #
 462 #    # BEGIN TRANSACTION
 463 #    $patron = new ILS::Patron $patron_id;
 464 #    if (!$patron) {
 465 #       $trans->screen_msg("Invalid patron barcode.");
 466 #
 467 #       return $trans;
 468 #    } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
 469 #       $trans->screen_msg('Invalid patron password.');
 470 #
 471 #       return $trans;
 472 #    }
 473 #
 474 #    $item = new ILS::Item ($item_id || $title_id);
 475 #    if (!$item) {
 476 #       $trans->screen_msg("No such item.");
 477 #
 478 #       # END TRANSACTION (conditionally)
 479 #       return $trans;
 480 #    }
 481 #
 482 #    # Remove the hold from the patron's record first
 483 #    $trans->ok($patron->drop_hold($item_id));
 484 #
 485 #    if (!$trans->ok) {
 486 #       # We didn't find it on the patron record
 487 #       $trans->screen_msg("No such hold on patron record.");
 488 #
 489 #       # END TRANSACTION (conditionally)
 490 #       return $trans;
 491 #    }
 492 #
 493 #    # Now, remove it from the item record.  If it was on the patron
 494 #    # record but not on the item record, we'll treat that as success.
 495 #    foreach my $i (0 .. scalar @{$item->hold_queue}) {
 496 #       $hold = $item->hold_queue->[$i];
 497 #
 498 #       if ($hold->{patron_id} eq $patron->id) {
 499 #           # found it: delete it.
 500 #           splice @{$item->hold_queue}, $i, 1;
 501 #           last;
 502 #       }
 503 #    }
 504 #
 505 #    $trans->screen_msg("Hold Cancelled.");
 506 #    $trans->patron($patron);
 507 #    $trans->item($item);
 508 #
 509 #    return $trans;
 510 #}
 511 #
 512 #
 513 ## The patron and item id's can't be altered, but the
 514 ## date, location, and type can.
 515 #sub alter_hold {
 516 #    my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
 517 #       $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
 518 #    my ($patron, $item);
 519 #    my $hold;
 520 #    my $trans;
 521 #
 522 #    $trans = new ILS::Transaction::Hold;
 523 #
 524 #    # BEGIN TRANSACTION
 525 #    $patron = new ILS::Patron $patron_id;
 526 #    if (!$patron) {
 527 #       $trans->screen_msg("Invalid patron barcode.");
 528 #
 529 #       return $trans;
 530 #    }
 531 #
 532 #    foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
 533 #       $hold = $patron->{hold_items}[$i];
 534 #
 535 #       if ($hold->{item_id} eq $item_id) {
 536 #           # Found it.  So fix it.
 537 #           $hold->{expiration_date} = $expiry_date if $expiry_date;
 538 #           $hold->{pickup_location} = $pickup_location if $pickup_location;
 539 #           $hold->{hold_type} = $hold_type if $hold_type;
 540 #
 541 #           $trans->ok(1);
 542 #           $trans->screen_msg("Hold updated.");
 543 #           $trans->patron($patron);
 544 #           $trans->item(new ILS::Item $hold->{item_id});
 545 #           last;
 546 #       }
 547 #    }
 548 #
 549 #    # The same hold structure is linked into both the patron's
 550 #    # list of hold items and into the queue of outstanding holds
 551 #    # for the item, so we don't need to search the hold queue for
 552 #    # the item, since it's already been updated by the patron code.
 553 #
 554 #    if (!$trans->ok) {
 555 #       $trans->screen_msg("No such outstanding hold.");
 556 #    }
 557 #
 558 #    return $trans;
 559 #}
 560
 561
 562 sub renew {
 563         my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
 564                 $no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
 565
 566         $self->verify_session;
 567
 568         my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
 569         $trans->patron($self->find_patron($patron_id));
 570         $trans->item($self->find_item($item_id));
 571
 572         if(!$trans->patron) {
 573                 $trans->screen_msg("Invalid patron barcode.");
 574                 $trans->ok(0);
 575                 return $trans;
 576         }
 577
 578         if(!$trans->patron->renew_ok) {
 579                 $trans->screen_msg("Renewals not allowed.");
 580                 $trans->ok(0);
 581                 return $trans;
 582         }
 583
 584         if(!$trans->item) {
 585                 if( $title_id ) {
 586                         $trans->screen_msg("Title ID renewal not supported.  Use item barcode.");
 587                 } else {
 588                         $trans->screen_msg("Invalid item barcode.");
 589                 }
 590                 $trans->ok(0);
 591                 return $trans;
 592         }
 593
 594         if(!$trans->item->{patron} or
 595                         $trans->item->{patron} ne $patron_id) {
 596                 $trans->screen_msg("Item not checked out to " . $trans->patron->name);
 597                 $trans->ok(0);
 598                 return $trans;
 599         }
 600
 601         # Perform the renewal
 602         $trans->do_renew();
 603
 604         $trans->desensitize(0); # It's already checked out
 605         $trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
 606         $trans->item->{sip_item_properties} = $item_props if $item_props;
 607
 608         return $trans;
 609 }
 610
 611
 612
 613
 614
 615 #
 616 #sub renew_all {
 617 #    my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
 618 #    my ($patron, $item_id);
 619 #    my $trans;
 620 #
 621 #    $trans = new ILS::Transaction::RenewAll;
 622 #
 623 #    $trans->patron($patron = new ILS::Patron $patron_id);
 624 #    if (defined $patron) {
 625 #       syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
 626 #              $patron->name, $patron->renew_ok);
 627 #    } else {
 628 #       syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
 629 #              $patron_id);
 630 #    }
 631 #
 632 #    if (!defined($patron)) {
 633 #       $trans->screen_msg("Invalid patron barcode.");
 634 #       return $trans;
 635 #    } elsif (!$patron->renew_ok) {
 636 #       $trans->screen_msg("Renewals not allowed.");
 637 #       return $trans;
 638 #    } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
 639 #       $trans->screen_msg("Invalid patron password.");
 640 #       return $trans;
 641 #    }
 642 #
 643 #    foreach $item_id (@{$patron->{items}}) {
 644 #       my $item = new ILS::Item $item_id;
 645 #
 646 #       if (!defined($item)) {
 647 #           syslog("LOG_WARNING",
 648 #                  "renew_all: Invalid item id associated with patron '%s'",
 649 #                  $patron->id);
 650 #           next;
 651 #       }
 652 #
 653 #       if (@{$item->hold_queue}) {
 654 #           # Can't renew if there are outstanding holds
 655 #           push @{$trans->unrenewed}, $item_id;
 656 #       } else {
 657 #           $item->{due_date} = time + (14*24*60*60); # two weeks hence
 658 #           push @{$trans->renewed}, $item_id;
 659 #       }
 660 #    }
 661 #
 662 #    $trans->ok(1);
 663 #
 664 #    return $trans;
 665 #}
 666
 667 1;