2 # ILS.pm: Test ILS interface module
6 use warnings; use strict;
8 use Sys::Syslog qw(syslog);
9 use Time::HiRes q/time/;
11 use OpenILS::SIP::Item;
12 use OpenILS::SIP::Patron;
13 use OpenILS::SIP::Transaction;
14 use OpenILS::SIP::Transaction::Checkout;
15 use OpenILS::SIP::Transaction::Checkin;
16 use OpenILS::SIP::Transaction::Renew;
17 use OpenILS::SIP::Transaction::RenewAll;
18 use OpenILS::SIP::Transaction::FeePayment;
19 use OpenILS::SIP::Transaction::Hold;
22 use OpenSRF::AppSession;
23 use OpenILS::Utils::Fieldmapper;
24 use OpenSRF::Utils::SettingsClient;
25 use OpenILS::Application::AppUtils;
26 use OpenSRF::Utils qw/:datetime/;
27 use DateTime::Format::ISO8601;
29 use Unicode::Normalize;
31 my $U = 'OpenILS::Application::AppUtils';
36 my $target_encoding; # FIXME: this is configured at the institution level.
38 use Digest::MD5 qw(md5_hex);
40 # Copied from Sip::Constants
42 SIP_DATETIME => "%Y%m%d %H%M%S",
46 my ($class, $institution, $login) = @_;
47 my $type = ref($class) || $class;
50 $self->{login} = $login_account = $login;
52 $config = $institution;
53 syslog("LOG_DEBUG", "OILS: new ILS '%s'", $institution->{id});
54 $self->{institution} = $institution;
56 my $bsconfig = $institution->{implementation_config}->{bootstrap};
57 $target_encoding = $institution->{implementation_config}->{encoding} || 'ascii';
59 syslog('LOG_DEBUG', "OILS: loading bootstrap config: $bsconfig");
61 # ingress will persist throughout
62 OpenSRF::AppSession->ingress('sip2');
64 local $/ = "\n"; # why?
65 OpenSRF::System->bootstrap_client(config_file => $bsconfig);
66 syslog('LOG_DEBUG', "OILS: bootstrap loaded..");
68 $self->{osrf_config} = OpenSRF::Utils::SettingsClient->new;
70 Fieldmapper->import($self->{osrf_config}->config_value('IDL'));
72 bless( $self, $type );
75 $self->login( $login->{id}, $login->{password} );
83 my $ses = $U->simplereq(
85 'open-ils.auth.session.retrieve', $self->{authtoken});
87 return undef if $U->event_code($ses); # auth timed out
88 return $self->{login_session} = $ses;
94 return 1 if $self->fetch_session;
96 syslog('LOG_INFO', "OILS: Logging back after session timeout as user ".$self->{login}->{id});
97 return $self->login( $self->{login}->{id}, $self->{login}->{password} );
101 return $editor = make_editor();
108 return $login_account;
111 sub get_option_value {
112 my($self, $option) = @_;
113 my $ops = $config->{implementation_config}->{options}->{option};
114 $ops = [$ops] unless ref $ops eq 'ARRAY';
115 my @vals = grep { $_->{name} eq $option } @$ops;
116 return @vals ? $vals[0]->{value} : undef;
120 # Creates the global editor object
121 my $cstore_init = 1; # call init on first use
123 OpenILS::Utils::CStoreEditor::init() if $cstore_init;
125 return OpenILS::Utils::CStoreEditor->new;
128 =head2 clean_text(scalar)
130 Evergreen uses the UTF8 encoding for everything from the database up. Perl
131 doesn't know this, however, so we have to convince it to treat our UTF8 strings
132 as UTF8 strings. This may enable OpenNCIP to correctly calculate the checksums
133 for UTF8 text for SIP clients that support such modern options.
135 The target encoding is set in the <encoding> element of the SIPServer.pm
141 my $text = shift || '';
143 # Convert our incoming UTF8 data into Perl's internal string format
145 # Also convert to Normalization Form D, as the ASCII, iso-8859-1,
146 # and latin-1 encodings (at least) require this to substitute
147 # characters rather than simply returning a string truncated
148 # after the first non-ASCII character
149 $text = NFD(decode_utf8($text));
151 if ($target_encoding eq 'ascii') {
153 # Try to maintain a reasonable version of the content by
154 # stripping diacritics from the text, given that the SIP client
155 # wants just plain ASCII. This is the base requirement according
156 # to the SIP2 specification.
158 # Stripping the combining characters converts ""béè♁ts"
159 # into "bee?ts" instead of "b???ts" - better, eh?
163 # Characters that cannot be represented in the target encoding will
164 # generally be replaced with a question mark (?) character.
165 $text = encode($target_encoding, $text);
171 sub shortname_from_id {
172 my $id = shift or return;
173 return $id->shortname if ref $id;
174 return $org_sn_cache{$id} if $org_sn_cache{$id};
175 return $org_sn_cache{$id} = editor()->retrieve_actor_org_unit($id)->shortname;
177 sub patron_barcode_from_id {
178 my $id = shift or return;
179 return editor()->search_actor_card({ usr => $id, active => 't' })->[0]->barcode;
185 my $type = shift || 'dob';
187 return "" unless $date;
189 my $dt = DateTime::Format::ISO8601->new->
190 parse_datetime(OpenSRF::Utils::cleanse_ISO8601($date));
191 my @time = localtime($dt->epoch);
193 my $year = $time[5]+1900;
194 my $mon = $time[4]+1;
197 my $minute = $time[1];
198 my $second = $time[0];
200 $date = sprintf("%04d%02d%02d", $year, $mon, $day);
202 # Due dates need hyphen separators and time of day as well
203 if ($type eq 'due') {
205 my $use_sdf = $class->get_option_value('use_sip_date_format') | '';
207 if ($use_sdf =~ /true/i) {
208 $date = $dt->strftime(SIP_DATETIME);
211 $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d",
212 $year, $mon, $day, $hour, $minute, $second);
216 syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
223 my( $self, $username, $password ) = @_;
224 syslog('LOG_DEBUG', "OILS: Logging in with username $username");
226 my $nonce = rand($$);
227 my $seed = $U->simplereq(
229 'open-ils.auth.authenticate.init', $username, $nonce );
231 my $response = $U->simplereq(
233 'open-ils.auth.authenticate.complete',
235 username => $username,
236 password => md5_hex($seed . md5_hex($password)),
242 if( my $code = $U->event_code($response) ) {
243 my $txt = $response->{textcode};
244 syslog('LOG_WARNING', "OILS: Login failed for $username. $txt:$code");
248 my $key = $response->{payload}->{authtoken};
249 syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
251 $self->{authtoken} = $key;
253 $self->fetch_session; # to cache the login
259 # find_patron($barcode);
260 # find_patron(barcode => $barcode); # same as above
261 # find_patron(usr => $id);
265 my $key = (@_ > 1) ? shift : 'barcode'; # if we have multiple args, the first is the key index (default barcode)
266 my $patron_id = shift;
268 return OpenILS::SIP::Patron->new($key => $patron_id, authtoken => $self->{authtoken}, @_);
274 return OpenILS::SIP::Item->new(@_);
280 return $self->{institution}->{id}; # consider making this return the whole institution
285 return $self->{institution}->{id}; # then use this for just the ID
289 my ($self, $op) = @_;
290 my ($i) = grep { $_->{name} eq $op }
291 @{$config->{implementation_config}->{supports}->{item}};
292 return to_bool($i->{value});
296 my ($self, $id, $whence) = @_;
297 if ($id ne $self->{institution}->{id}) {
298 syslog("LOG_WARNING", "OILS: %s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
299 # Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
306 # If it's defined, and matches a true sort of string, or is
307 # a non-zero number, then it's true.
308 defined($bool) or return; # false
309 ($bool =~ /true|y|yes/i) and return 1; # true
310 return ($bool =~ /^\d+$/ and $bool != 0); # true for non-zero numbers, false otherwise
314 return to_bool($config->{policy}->{checkout});
318 return to_bool($config->{policy}->{checkin});
322 return to_bool($config->{policy}->{renewal});
325 sub status_update_ok {
326 return to_bool($config->{policy}->{status_update});
330 return to_bool($config->{policy}->{offline});
336 ## Checkout(patron_id, item_id, sc_renew, fee_ack):
337 ## patron_id & item_id are the identifiers send by the terminal
338 ## sc_renew is the renewal policy configured on the terminal
339 ## returns a status opject that can be queried for the various bits
340 ## of information that the protocol (SIP or NCIP) needs to generate
342 ## fee_ack is the fee_acknowledged field (BO) sent from the sc
343 ## when doing chargeable loans.
347 my ($self, $patron_id, $item_id, $sc_renew, $fee_ack) = @_;
348 # In order to allow renewals the selfcheck AND the config have to say they are allowed
349 $sc_renew = (chr($sc_renew) eq 'Y' && $self->renew_ok());
351 $self->verify_session;
353 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
355 my $xact = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
356 my $patron = $self->find_patron($patron_id);
357 my $item = $self->find_item($item_id);
359 $xact->patron($patron);
363 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
367 if (!$patron->charge_ok) {
368 $xact->screen_msg("Patron Blocked");
373 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
377 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
379 if ($item->{patron} && ($item->{patron} eq $patron_id)) {
380 $xact->renew_ok(1); # So that accept/reject responses have the correct value later
382 syslog('LOG_INFO', "OILS: OpenILS::Checkout data loaded OK, doing renew...");
384 syslog('LOG_INFO', "OILS: OpenILS::Checkout appears to be renew, but renewal disallowed...");
385 $xact->screen_msg("Renewals not permitted");
387 return $xact; # Don't attempt later
389 } elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
390 # I can't deal with this right now
391 # XXX check in then check out?
392 $xact->screen_msg("Item checked out to another patron");
394 return $xact; # Don't wipe out the screen message later
399 # Check for fee and $fee_ack. If there is a fee, and $fee_ack
400 # is 'Y', we proceed, otherwise we reject the checkout.
401 if ($item->fee > 0.0) {
402 $xact->fee_amount($item->fee);
403 $xact->sip_fee_type($item->sip_fee_type);
404 $xact->sip_currency($item->fee_currency);
405 if ($fee_ack && $fee_ack eq 'Y') {
408 $xact->screen_msg('Fee required');
414 $xact->do_checkout($sc_renew);
415 $xact->desensitize(!$item->magnetic);
419 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
420 "patron %s checkout %s succeeded", $patron_id, $item_id);
422 #editor()->xact_rollback;
423 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
424 "patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
432 my ($self, $item_id, $inst_id, $trans_date, $return_date,
433 $current_loc, $item_props, $cancel) = @_;
435 my $start_time = time();
437 $self->verify_session;
439 syslog('LOG_DEBUG', "OILS: OpenILS::Checkin of item=$item_id (to $inst_id)");
441 my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
442 my $item = OpenILS::SIP::Item->new($item_id);
444 unless ( $xact->item($item) ) {
446 # $circ->alert(1); $circ->alert_type(99);
447 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
448 syslog('LOG_INFO', "OILS: Checkin failed. " . $xact->screen_msg() );
452 $xact->do_checkin( $self, $inst_id, $trans_date, $return_date, $current_loc, $item_props );
455 $xact->patron($self->find_patron(usr => $xact->{circ_user_id}, slim_user => 1)) if $xact->{circ_user_id};
456 delete $item->{patron};
457 delete $item->{due_date};
458 syslog('LOG_INFO', "OILS: Checkin succeeded");
460 syslog('LOG_WARNING', "OILS: Checkin failed");
463 syslog('LOG_INFO', "OILS: SIP Checkin request took %0.3f seconds", (time() - $start_time));
467 ## If the ILS caches patron information, this lets it free it up.
468 ## Also, this could be used for centrally logging session duration.
469 ## We don't do anything with it.
470 sub end_patron_session {
471 my ($self, $patron_id) = @_;
472 return (1, 'Thank you!', '');
477 my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
478 $pay_type, $fee_id, $trans_id, $currency) = @_;
480 $self->verify_session;
482 my $xact = OpenILS::SIP::Transaction::FeePayment->new(authtoken => $self->{authtoken});
483 my $patron = $self->find_patron($patron_id);
486 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
491 $xact->patron($patron);
492 $xact->sip_currency($currency);
493 $xact->fee_amount($fee_amt);
494 $xact->sip_fee_type($fee_type);
495 $xact->transaction_id($trans_id);
496 $xact->fee_id($fee_id);
497 $xact->sip_payment_type($pay_type);
498 # We don't presently use this, but we might in the future.
499 $xact->patron_password($patron_pwd);
501 $xact->do_fee_payment();
507 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
508 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
509 # my ($patron, $item);
514 # $trans = new ILS::Transaction::Hold;
516 # # BEGIN TRANSACTION
517 # $patron = new ILS::Patron $patron_id;
519 # || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
520 # $trans->screen_msg("Invalid Patron.");
525 # $item = new ILS::Item ($item_id || $title_id);
527 # $trans->screen_msg("No such item.");
529 # # END TRANSACTION (conditionally)
531 # } elsif ($item->fee && ($fee_ack ne 'Y')) {
532 # $trans->screen_msg = "Fee required to place hold.";
534 # # END TRANSACTION (conditionally)
539 # item_id => $item->id,
540 # patron_id => $patron->id,
541 # expiration_date => $expiry_date,
542 # pickup_location => $pickup_location,
543 # hold_type => $hold_type,
547 # $trans->patron($patron);
548 # $trans->item($item);
549 # $trans->pickup_location($pickup_location);
551 # push(@{$item->hold_queue}, $hold);
552 # push(@{$patron->{hold_items}}, $hold);
560 # Note: item_id in this context is the hold id
562 my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
564 my $trans = OpenILS::SIP::Transaction::Hold->new(authtoken => $self->{authtoken});
565 my $patron = $self->find_patron($patron_id);
568 $trans->screen_msg("Invalid patron barcode.");
573 if (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
574 $trans->screen_msg('Invalid patron password.');
579 $trans->patron($patron);
580 my $hold = $patron->find_hold_from_copy($item_id);
583 syslog('LOG_WARNING', "OILS: No hold found from copy $item_id");
584 $trans->screen_msg("No such hold.");
589 if ($hold->usr ne $patron->{user}->id) {
590 $trans->screen_msg("No such hold on patron record.");
596 $trans->do_hold_cancel($self);
598 if ($trans->cancel_ok) {
599 $trans->screen_msg("Hold Cancelled.");
601 $trans->screen_msg("Hold was not cancelled.");
604 # if the hold had no current_copy, use the representative
605 # item as the item for the hold. Without this, the SIP
607 $trans->item($self->find_item($item_id)) unless $trans->item;
613 ## The patron and item id's can't be altered, but the
614 ## date, location, and type can.
616 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
617 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
618 # my ($patron, $item);
622 # $trans = new ILS::Transaction::Hold;
624 # # BEGIN TRANSACTION
625 # $patron = new ILS::Patron $patron_id;
627 # $trans->screen_msg("Invalid patron barcode.");
632 # foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
633 # $hold = $patron->{hold_items}[$i];
635 # if ($hold->{item_id} eq $item_id) {
636 # # Found it. So fix it.
637 # $hold->{expiration_date} = $expiry_date if $expiry_date;
638 # $hold->{pickup_location} = $pickup_location if $pickup_location;
639 # $hold->{hold_type} = $hold_type if $hold_type;
642 # $trans->screen_msg("Hold updated.");
643 # $trans->patron($patron);
644 # $trans->item(new ILS::Item $hold->{item_id});
649 # # The same hold structure is linked into both the patron's
650 # # list of hold items and into the queue of outstanding holds
651 # # for the item, so we don't need to search the hold queue for
652 # # the item, since it's already been updated by the patron code.
655 # $trans->screen_msg("No such outstanding hold.");
663 my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
664 $no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
666 $self->verify_session;
668 my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
669 $trans->patron($self->find_patron($patron_id));
670 $trans->item($self->find_item($item_id));
672 if(!$trans->patron) {
673 $trans->screen_msg("Invalid patron barcode.");
678 if(!$trans->patron->renew_ok) {
679 $trans->screen_msg("Renewals not allowed.");
686 $trans->screen_msg("Title ID renewal not supported. Use item barcode.");
688 $trans->screen_msg("Invalid item barcode.");
694 if(!$trans->item->{patron} or
695 $trans->item->{patron} ne $patron_id) {
696 $trans->screen_msg("Item not checked out to " . $trans->patron->name);
701 # Perform the renewal
704 $trans->desensitize(0); # It's already checked out
705 $trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
706 $trans->item->{sip_item_properties} = $item_props if $item_props;
713 my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
715 $self->verify_session;
717 my $trans = OpenILS::SIP::Transaction::RenewAll->new(authtoken => $self->{authtoken});
718 $trans->patron($self->find_patron($patron_id));
720 if(!$trans->patron) {
721 $trans->screen_msg("Invalid patron barcode.");
726 if(!$trans->patron->renew_ok) {
727 $trans->screen_msg("Renewals not allowed.");
732 $trans->do_renew_all($self);
739 # my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
740 # my ($patron, $item_id);
743 # $trans = new ILS::Transaction::RenewAll;
745 # $trans->patron($patron = new ILS::Patron $patron_id);
746 # if (defined $patron) {
747 # syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
748 # $patron->name, $patron->renew_ok);
750 # syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
754 # if (!defined($patron)) {
755 # $trans->screen_msg("Invalid patron barcode.");
757 # } elsif (!$patron->renew_ok) {
758 # $trans->screen_msg("Renewals not allowed.");
760 # } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
761 # $trans->screen_msg("Invalid patron password.");
765 # foreach $item_id (@{$patron->{items}}) {
766 # my $item = new ILS::Item $item_id;
768 # if (!defined($item)) {
769 # syslog("LOG_WARNING",
770 # "renew_all: Invalid item id associated with patron '%s'",
775 # if (@{$item->hold_queue}) {
776 # # Can't renew if there are outstanding holds
777 # push @{$trans->unrenewed}, $item_id;
779 # $item->{due_date} = time + (14*24*60*60); # two weeks hence
780 # push @{$trans->renewed}, $item_id;