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 format_date {
 135         my $class = shift;
 136         my $date = shift;
 137         my $type = shift || 'dob';
 138
 139         return "" unless $date;
 140
 141         $date = DateTime::Format::ISO8601->new->
 142                 parse_datetime(OpenSRF::Utils::cleanse_ISO8601($date));
 143         my @time = localtime($date->epoch);
 144
 145         my $year   = $time[5]+1900;
 146         my $mon    = $time[4]+1;
 147         my $day    = $time[3];
 148         my $hour   = $time[2];
 149         my $minute = $time[1];
 150         my $second = $time[0];
 151
 152         $date = sprintf("%04d%02d%02d", $year, $mon, $day);
 153
 154         # Due dates need hyphen separators and time of day as well
 155         if ($type eq 'due') {
 156                 $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year, $mon, $day, $hour, $minute, $second);
 157         }
 158
 159         syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
 160         return $date;
 161 }
 162
 163
 164
 165 sub login {
 166         my( $self, $username, $password ) = @_;
 167         syslog('LOG_DEBUG', "OILS: Logging in with username $username");
 168
 169         my $seed = $U->simplereq(
 170                 'open-ils.auth',
 171                 'open-ils.auth.authenticate.init', $username );
 172
 173         my $response = $U->simplereq(
 174                 'open-ils.auth',
 175                 'open-ils.auth.authenticate.complete',
 176                 {
 177                         username => $username,
 178                         password => md5_hex($seed . md5_hex($password)),
 179                         type     => 'opac',
 180                 }
 181         );
 182
 183         if( my $code = $U->event_code($response) ) {
 184                 my $txt = $response->{textcode};
 185                 syslog('LOG_WARNING', "OILS: Login failed for $username.  $txt:$code");
 186                 return undef;
 187         }
 188
 189         my $key = $response->{payload}->{authtoken};
 190         syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
 191         return $self->{authtoken} = $key;
 192 }
 193
 194
 195 sub find_patron {
 196         my $self = shift;
 197         return OpenILS::SIP::Patron->new(@_);
 198 }
 199
 200
 201 sub find_item {
 202         my $self = shift;
 203         return OpenILS::SIP::Item->new(@_);
 204 }
 205
 206
 207 sub institution {
 208     my $self = shift;
 209     return $self->{institution}->{id};  # consider making this return the whole institution
 210 }
 211
 212 sub institution_id {
 213     my $self = shift;
 214     return $self->{institution}->{id};  # then use this for just the ID
 215 }
 216
 217 sub supports {
 218         my ($self, $op) = @_;
 219         my ($i) = grep { $_->{name} eq $op }
 220                 @{$config->{implementation_config}->{supports}->{item}};
 221         return to_bool($i->{value});
 222 }
 223
 224 sub check_inst_id {
 225     my ($self, $id, $whence) = @_;
 226     if ($id ne $self->{institution}->{id}) {
 227         syslog("LOG_WARNING", "OILS: %s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
 228         # Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
 229     }
 230 }
 231
 232
 233 sub to_bool {
 234     my $bool = shift;
 235     # If it's defined, and matches a true sort of string, or is
 236     # a non-zero number, then it's true.
 237     defined($bool) or return;                   # false
 238     ($bool =~ /true|y|yes/i) and return 1;      # true
 239     return ($bool =~ /^\d+$/ and $bool != 0);   # true for non-zero numbers, false otherwise
 240 }
 241
 242 sub checkout_ok {
 243         return to_bool($config->{policy}->{checkout});
 244 }
 245
 246 sub checkin_ok {
 247         return to_bool($config->{policy}->{checkin});
 248 }
 249
 250 sub renew_ok {
 251         return to_bool($config->{policy}->{renew});
 252 }
 253
 254 sub status_update_ok {
 255         return to_bool($config->{policy}->{status_update});
 256 }
 257
 258 sub offline_ok {
 259         return to_bool($config->{policy}->{offline});
 260 }
 261
 262
 263
 264 ##
 265 ## Checkout(patron_id, item_id, sc_renew):
 266 ##    patron_id & item_id are the identifiers send by the terminal
 267 ##    sc_renew is the renewal policy configured on the terminal
 268 ## returns a status opject that can be queried for the various bits
 269 ## of information that the protocol (SIP or NCIP) needs to generate
 270 ## the response.
 271 ##
 272
 273 sub checkout {
 274         my ($self, $patron_id, $item_id, $sc_renew) = @_;
 275         $sc_renew = 0;
 276
 277         $self->verify_session;
 278
 279         syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
 280
 281     my $xact   = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
 282     my $patron = $self->find_patron($patron_id);
 283     my $item   = $self->find_item($item_id);
 284
 285         $xact->patron($patron);
 286         $xact->item($item);
 287
 288         if (!$patron) {
 289                 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
 290                 return $xact;
 291         }
 292
 293         if (!$patron->charge_ok) {
 294                 $xact->screen_msg("Patron Blocked");
 295                 return $xact;
 296         }
 297
 298         if( !$item ) {
 299                 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
 300                 return $xact;
 301         }
 302
 303         syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
 304
 305         if ($item->{patron} && ($item->{patron} eq $patron_id)) {
 306                 syslog('LOG_INFO', "OILS: OpenILS::Checkout data loaded OK, doing renew...");
 307                 $sc_renew = 1;
 308         } elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
 309                 # I can't deal with this right now
 310                 # XXX check in then check out?
 311                 $xact->screen_msg("Item checked out to another patron");
 312                 $xact->ok(0);
 313         }
 314
 315         $xact->do_checkout($sc_renew);
 316         $xact->desensitize(!$item->magnetic);
 317
 318         if( $xact->ok ) {
 319                 #editor()->commit;
 320                 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
 321                         "patron %s checkout %s succeeded", $patron_id, $item_id);
 322         } else {
 323                 #editor()->xact_rollback;
 324                 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
 325                         "patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
 326         }
 327
 328         return $xact;
 329 }
 330
 331
 332 sub checkin {
 333         my ($self, $item_id, $trans_date, $return_date,
 334         $current_loc, $item_props, $cancel) = @_;
 335
 336         $self->verify_session;
 337
 338         syslog('LOG_DEBUG', "OILS: OpenILS::Checkin on item=$item_id");
 339
 340     my $patron;
 341     my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
 342     my $item = $self->find_item($item_id);
 343
 344         $xact->item($item);
 345
 346         if(!$xact->item) {
 347                 $xact->screen_msg("Invalid item barcode: $item_id");
 348                 $xact->ok(0);
 349                 return $xact;
 350         }
 351
 352         $xact->do_checkin( $trans_date, $return_date, $current_loc, $item_props );
 353
 354         if ($xact->ok) {
 355         $xact->patron($patron = $self->find_patron($item->{patron}));
 356         delete $item->{patron};
 357         delete $item->{due_date};
 358         syslog('LOG_INFO', "OILS: Checkin succeeded");
 359         #editor()->commit;
 360     } else {
 361         #editor()->xact_rollback;
 362         syslog('LOG_WARNING', "OILS: Checkin failed");
 363     }
 364
 365         return $xact;
 366 }
 367
 368 ## If the ILS caches patron information, this lets it free it up.
 369 ## Also, this could be used for centrally logging session duration.
 370 ## We don't do anything with it.
 371 sub end_patron_session {
 372     my ($self, $patron_id) = @_;
 373     return (1, 'Thank you!', '');
 374 }
 375
 376
 377 #sub pay_fee {
 378 #    my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
 379 #       $pay_type, $fee_id, $trans_id, $currency) = @_;
 380 #    my $trans;
 381 #    my $patron;
 382 #
 383 #    $trans = new ILS::Transaction::FeePayment;
 384 #
 385 #    $patron = new ILS::Patron $patron_id;
 386 #
 387 #    $trans->transaction_id($trans_id);
 388 #    $trans->patron($patron);
 389 #    $trans->ok(1);
 390 #
 391 #    return $trans;
 392 #}
 393 #
 394 #sub add_hold {
 395 #    my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
 396 #       $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
 397 #    my ($patron, $item);
 398 #    my $hold;
 399 #    my $trans;
 400 #
 401 #
 402 #    $trans = new ILS::Transaction::Hold;
 403 #
 404 #    # BEGIN TRANSACTION
 405 #    $patron = new ILS::Patron $patron_id;
 406 #    if (!$patron
 407 #       || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
 408 #       $trans->screen_msg("Invalid Patron.");
 409 #
 410 #       return $trans;
 411 #    }
 412 #
 413 #    $item = new ILS::Item ($item_id || $title_id);
 414 #    if (!$item) {
 415 #       $trans->screen_msg("No such item.");
 416 #
 417 #       # END TRANSACTION (conditionally)
 418 #       return $trans;
 419 #    } elsif ($item->fee && ($fee_ack ne 'Y')) {
 420 #       $trans->screen_msg = "Fee required to place hold.";
 421 #
 422 #       # END TRANSACTION (conditionally)
 423 #       return $trans;
 424 #    }
 425 #
 426 #    $hold = {
 427 #       item_id         => $item->id,
 428 #       patron_id       => $patron->id,
 429 #       expiration_date => $expiry_date,
 430 #       pickup_location => $pickup_location,
 431 #       hold_type       => $hold_type,
 432 #    };
 433 #
 434 #    $trans->ok(1);
 435 #    $trans->patron($patron);
 436 #    $trans->item($item);
 437 #    $trans->pickup_location($pickup_location);
 438 #
 439 #    push(@{$item->hold_queue}, $hold);
 440 #    push(@{$patron->{hold_items}}, $hold);
 441 #
 442 #
 443 #    # END TRANSACTION
 444 #    return $trans;
 445 #}
 446 #
 447 #sub cancel_hold {
 448 #    my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
 449 #    my ($patron, $item, $hold);
 450 #    my $trans;
 451 #
 452 #    $trans = new ILS::Transaction::Hold;
 453 #
 454 #    # BEGIN TRANSACTION
 455 #    $patron = new ILS::Patron $patron_id;
 456 #    if (!$patron) {
 457 #       $trans->screen_msg("Invalid patron barcode.");
 458 #
 459 #       return $trans;
 460 #    } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
 461 #       $trans->screen_msg('Invalid patron password.');
 462 #
 463 #       return $trans;
 464 #    }
 465 #
 466 #    $item = new ILS::Item ($item_id || $title_id);
 467 #    if (!$item) {
 468 #       $trans->screen_msg("No such item.");
 469 #
 470 #       # END TRANSACTION (conditionally)
 471 #       return $trans;
 472 #    }
 473 #
 474 #    # Remove the hold from the patron's record first
 475 #    $trans->ok($patron->drop_hold($item_id));
 476 #
 477 #    if (!$trans->ok) {
 478 #       # We didn't find it on the patron record
 479 #       $trans->screen_msg("No such hold on patron record.");
 480 #
 481 #       # END TRANSACTION (conditionally)
 482 #       return $trans;
 483 #    }
 484 #
 485 #    # Now, remove it from the item record.  If it was on the patron
 486 #    # record but not on the item record, we'll treat that as success.
 487 #    foreach my $i (0 .. scalar @{$item->hold_queue}) {
 488 #       $hold = $item->hold_queue->[$i];
 489 #
 490 #       if ($hold->{patron_id} eq $patron->id) {
 491 #           # found it: delete it.
 492 #           splice @{$item->hold_queue}, $i, 1;
 493 #           last;
 494 #       }
 495 #    }
 496 #
 497 #    $trans->screen_msg("Hold Cancelled.");
 498 #    $trans->patron($patron);
 499 #    $trans->item($item);
 500 #
 501 #    return $trans;
 502 #}
 503 #
 504 #
 505 ## The patron and item id's can't be altered, but the
 506 ## date, location, and type can.
 507 #sub alter_hold {
 508 #    my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
 509 #       $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
 510 #    my ($patron, $item);
 511 #    my $hold;
 512 #    my $trans;
 513 #
 514 #    $trans = new ILS::Transaction::Hold;
 515 #
 516 #    # BEGIN TRANSACTION
 517 #    $patron = new ILS::Patron $patron_id;
 518 #    if (!$patron) {
 519 #       $trans->screen_msg("Invalid patron barcode.");
 520 #
 521 #       return $trans;
 522 #    }
 523 #
 524 #    foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
 525 #       $hold = $patron->{hold_items}[$i];
 526 #
 527 #       if ($hold->{item_id} eq $item_id) {
 528 #           # Found it.  So fix it.
 529 #           $hold->{expiration_date} = $expiry_date if $expiry_date;
 530 #           $hold->{pickup_location} = $pickup_location if $pickup_location;
 531 #           $hold->{hold_type} = $hold_type if $hold_type;
 532 #
 533 #           $trans->ok(1);
 534 #           $trans->screen_msg("Hold updated.");
 535 #           $trans->patron($patron);
 536 #           $trans->item(new ILS::Item $hold->{item_id});
 537 #           last;
 538 #       }
 539 #    }
 540 #
 541 #    # The same hold structure is linked into both the patron's
 542 #    # list of hold items and into the queue of outstanding holds
 543 #    # for the item, so we don't need to search the hold queue for
 544 #    # the item, since it's already been updated by the patron code.
 545 #
 546 #    if (!$trans->ok) {
 547 #       $trans->screen_msg("No such outstanding hold.");
 548 #    }
 549 #
 550 #    return $trans;
 551 #}
 552
 553
 554 sub renew {
 555         my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
 556                 $no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
 557
 558         $self->verify_session;
 559
 560         my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
 561         $trans->patron($self->find_patron($patron_id));
 562         $trans->item($self->find_item($item_id));
 563
 564         if(!$trans->patron) {
 565                 $trans->screen_msg("Invalid patron barcode.");
 566                 $trans->ok(0);
 567                 return $trans;
 568         }
 569
 570         if(!$trans->patron->renew_ok) {
 571                 $trans->screen_msg("Renewals not allowed.");
 572                 $trans->ok(0);
 573                 return $trans;
 574         }
 575
 576         if(!$trans->item) {
 577                 if( $title_id ) {
 578                         $trans->screen_msg("Item Id renewal not supported.");
 579                 } else {
 580                         $trans->screen_msg("Invalid item barcode.");
 581                 }
 582                 $trans->ok(0);
 583                 return $trans;
 584         }
 585
 586         if(!$trans->item->{patron} or
 587                         $trans->item->{patron} ne $patron_id) {
 588                 $trans->screen_msg("Item not checked out to " . $trans->patron->name);
 589                 $trans->ok(0);
 590                 return $trans;
 591         }
 592
 593         # Perform the renewal
 594         $trans->do_renew();
 595
 596         $trans->desensitize(0); # It's already checked out
 597         $trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
 598         $trans->item->{sip_item_properties} = $item_props if $item_props;
 599
 600         return $trans;
 601 }
 602
 603
 604
 605
 606
 607 #
 608 #sub renew_all {
 609 #    my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
 610 #    my ($patron, $item_id);
 611 #    my $trans;
 612 #
 613 #    $trans = new ILS::Transaction::RenewAll;
 614 #
 615 #    $trans->patron($patron = new ILS::Patron $patron_id);
 616 #    if (defined $patron) {
 617 #       syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
 618 #              $patron->name, $patron->renew_ok);
 619 #    } else {
 620 #       syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
 621 #              $patron_id);
 622 #    }
 623 #
 624 #    if (!defined($patron)) {
 625 #       $trans->screen_msg("Invalid patron barcode.");
 626 #       return $trans;
 627 #    } elsif (!$patron->renew_ok) {
 628 #       $trans->screen_msg("Renewals not allowed.");
 629 #       return $trans;
 630 #    } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
 631 #       $trans->screen_msg("Invalid patron password.");
 632 #       return $trans;
 633 #    }
 634 #
 635 #    foreach $item_id (@{$patron->{items}}) {
 636 #       my $item = new ILS::Item $item_id;
 637 #
 638 #       if (!defined($item)) {
 639 #           syslog("LOG_WARNING",
 640 #                  "renew_all: Invalid item id associated with patron '%s'",
 641 #                  $patron->id);
 642 #           next;
 643 #       }
 644 #
 645 #       if (@{$item->hold_queue}) {
 646 #           # Can't renew if there are outstanding holds
 647 #           push @{$trans->unrenewed}, $item_id;
 648 #       } else {
 649 #           $item->{due_date} = time + (14*24*60*60); # two weeks hence
 650 #           push @{$trans->renewed}, $item_id;
 651 #       }
 652 #    }
 653 #
 654 #    $trans->ok(1);
 655 #
 656 #    return $trans;
 657 #}
 658
 659 1;