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