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