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