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::FeePayment;
20 use OpenILS::Utils::Fieldmapper;
21 use OpenSRF::Utils::SettingsClient;
22 use OpenILS::Application::AppUtils;
23 use OpenSRF::Utils qw/:datetime/;
24 use DateTime::Format::ISO8601;
26 use Unicode::Normalize;
27 my $U = 'OpenILS::Application::AppUtils';
31 my $target_encoding; # FIXME: this is configured at the institution level.
33 use Digest::MD5 qw(md5_hex);
36 my ($class, $institution, $login) = @_;
37 my $type = ref($class) || $class;
40 $self->{login} = $login;
42 $config = $institution;
43 syslog("LOG_DEBUG", "OILS: new ILS '%s'", $institution->{id});
44 $self->{institution} = $institution;
46 my $bsconfig = $institution->{implementation_config}->{bootstrap};
47 $target_encoding = $institution->{implementation_config}->{encoding} || 'ascii';
49 syslog('LOG_DEBUG', "OILS: loading bootstrap config: $bsconfig");
51 local $/ = "\n"; # why?
52 OpenSRF::System->bootstrap_client(config_file => $bsconfig);
53 syslog('LOG_DEBUG', "OILS: bootstrap loaded..");
55 $self->{osrf_config} = OpenSRF::Utils::SettingsClient->new;
57 Fieldmapper->import($self->{osrf_config}->config_value('IDL'));
59 bless( $self, $type );
62 $self->login( $login->{id}, $login->{password} );
70 my $ses = $U->simplereq(
72 'open-ils.auth.session.retrieve', $self->{authtoken});
74 return undef if $U->event_code($ses); # auth timed out
75 return $self->{login_session} = $ses;
81 return 1 if $self->fetch_session;
83 syslog('LOG_INFO', "OILS: Logging back after session timeout as user ".$self->{login}->{id});
84 return $self->login( $self->{login}->{id}, $self->{login}->{password} );
88 return $editor = make_editor();
95 sub get_option_value {
96 my($self, $option) = @_;
97 my $ops = $config->{implementation_config}->{options}->{option};
98 $ops = [$ops] unless ref $ops eq 'ARRAY';
99 my @vals = grep { $_->{name} eq $option } @$ops;
100 return @vals ? $vals[0]->{value} : undef;
104 # Creates the global editor object
105 my $cstore_init = 1; # call init on first use
107 OpenILS::Utils::CStoreEditor::init() if $cstore_init;
109 return OpenILS::Utils::CStoreEditor->new;
112 =head2 clean_text(scalar)
114 Evergreen uses the UTF8 encoding for everything from the database up. Perl
115 doesn't know this, however, so we have to convince it to treat our UTF8 strings
116 as UTF8 strings. This may enable OpenNCIP to correctly calculate the checksums
117 for UTF8 text for SIP clients that support such modern options.
119 The target encoding is set in the <encoding> element of the SIPServer.pm
125 my $text = shift || '';
127 # Convert our incoming UTF8 data into Perl's internal string format
129 # Also convert to Normalization Form D, as the ASCII, iso-8859-1,
130 # and latin-1 encodings (at least) require this to substitute
131 # characters rather than simply returning a string truncated
132 # after the first non-ASCII character
133 $text = NFD(decode_utf8($text));
135 if ($target_encoding eq 'ascii') {
137 # Try to maintain a reasonable version of the content by
138 # stripping diacritics from the text, given that the SIP client
139 # wants just plain ASCII. This is the base requirement according
140 # to the SIP2 specification.
142 # Stripping the combining characters converts ""béè♁ts"
143 # into "bee?ts" instead of "b???ts" - better, eh?
147 # Characters that cannot be represented in the target encoding will
148 # generally be replaced with a question mark (?) character.
149 $text = encode($target_encoding, $text);
155 sub shortname_from_id {
156 my $id = shift or return;
157 return $id->shortname if ref $id;
158 return $org_sn_cache{$id} if $org_sn_cache{$id};
159 return $org_sn_cache{$id} = editor()->retrieve_actor_org_unit($id)->shortname;
161 sub patron_barcode_from_id {
162 my $id = shift or return;
163 return editor()->search_actor_card({ usr => $id, active => 't' })->[0]->barcode;
169 my $type = shift || 'dob';
171 return "" unless $date;
173 $date = DateTime::Format::ISO8601->new->
174 parse_datetime(OpenSRF::Utils::cleanse_ISO8601($date));
175 my @time = localtime($date->epoch);
177 my $year = $time[5]+1900;
178 my $mon = $time[4]+1;
181 my $minute = $time[1];
182 my $second = $time[0];
184 $date = sprintf("%04d%02d%02d", $year, $mon, $day);
186 # Due dates need hyphen separators and time of day as well
187 if ($type eq 'due') {
188 $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year, $mon, $day, $hour, $minute, $second);
191 syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
198 my( $self, $username, $password ) = @_;
199 syslog('LOG_DEBUG', "OILS: Logging in with username $username");
201 my $seed = $U->simplereq(
203 'open-ils.auth.authenticate.init', $username );
205 my $response = $U->simplereq(
207 'open-ils.auth.authenticate.complete',
209 username => $username,
210 password => md5_hex($seed . md5_hex($password)),
215 if( my $code = $U->event_code($response) ) {
216 my $txt = $response->{textcode};
217 syslog('LOG_WARNING', "OILS: Login failed for $username. $txt:$code");
221 my $key = $response->{payload}->{authtoken};
222 syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
224 $self->fetch_session; # to cache the login
226 return $self->{authtoken} = $key;
232 return OpenILS::SIP::Patron->new(@_);
238 return OpenILS::SIP::Item->new(@_);
244 return $self->{institution}->{id}; # consider making this return the whole institution
249 return $self->{institution}->{id}; # then use this for just the ID
253 my ($self, $op) = @_;
254 my ($i) = grep { $_->{name} eq $op }
255 @{$config->{implementation_config}->{supports}->{item}};
256 return to_bool($i->{value});
260 my ($self, $id, $whence) = @_;
261 if ($id ne $self->{institution}->{id}) {
262 syslog("LOG_WARNING", "OILS: %s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
263 # Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
270 # If it's defined, and matches a true sort of string, or is
271 # a non-zero number, then it's true.
272 defined($bool) or return; # false
273 ($bool =~ /true|y|yes/i) and return 1; # true
274 return ($bool =~ /^\d+$/ and $bool != 0); # true for non-zero numbers, false otherwise
278 return to_bool($config->{policy}->{checkout});
282 return to_bool($config->{policy}->{checkin});
286 return to_bool($config->{policy}->{renewal});
289 sub status_update_ok {
290 return to_bool($config->{policy}->{status_update});
294 return to_bool($config->{policy}->{offline});
300 ## Checkout(patron_id, item_id, sc_renew, fee_ack):
301 ## patron_id & item_id are the identifiers send by the terminal
302 ## sc_renew is the renewal policy configured on the terminal
303 ## returns a status opject that can be queried for the various bits
304 ## of information that the protocol (SIP or NCIP) needs to generate
306 ## fee_ack is the fee_acknowledged field (BO) sent from the sc
307 ## when doing chargeable loans.
311 my ($self, $patron_id, $item_id, $sc_renew, $fee_ack) = @_;
312 # In order to allow renewals the selfcheck AND the config have to say they are allowed
313 $sc_renew = (chr($sc_renew) eq 'Y' && $self->renew_ok());
315 $self->verify_session;
317 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
319 my $xact = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
320 my $patron = $self->find_patron($patron_id);
321 my $item = $self->find_item($item_id);
323 $xact->patron($patron);
327 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
331 if (!$patron->charge_ok) {
332 $xact->screen_msg("Patron Blocked");
337 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
341 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
343 if ($item->{patron} && ($item->{patron} eq $patron_id)) {
344 $xact->renew_ok(1); # So that accept/reject responses have the correct value later
346 syslog('LOG_INFO', "OILS: OpenILS::Checkout data loaded OK, doing renew...");
348 syslog('LOG_INFO', "OILS: OpenILS::Checkout appears to be renew, but renewal disallowed...");
349 $xact->screen_msg("Renewals not permitted");
351 return $xact; # Don't attempt later
353 } elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
354 # I can't deal with this right now
355 # XXX check in then check out?
356 $xact->screen_msg("Item checked out to another patron");
358 return $xact; # Don't wipe out the screen message later
363 # Check for fee and $fee_ack. If there is a fee, and $fee_ack
364 # is 'Y', we proceed, otherwise we reject the checkout.
365 if ($item->fee > 0.0) {
366 $xact->fee_amount($item->fee);
367 $xact->sip_fee_type($item->sip_fee_type);
368 $xact->sip_currency($item->fee_currency);
369 if ($fee_ack && $fee_ack eq 'Y') {
372 $xact->screen_msg('Fee required');
378 $xact->do_checkout($sc_renew);
379 $xact->desensitize(!$item->magnetic);
383 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
384 "patron %s checkout %s succeeded", $patron_id, $item_id);
386 #editor()->xact_rollback;
387 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
388 "patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
396 my ($self, $item_id, $inst_id, $trans_date, $return_date,
397 $current_loc, $item_props, $cancel) = @_;
399 my $start_time = time();
401 $self->verify_session;
403 syslog('LOG_DEBUG', "OILS: OpenILS::Checkin of item=$item_id (to $inst_id)");
405 my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
406 my $item = OpenILS::SIP::Item->new($item_id);
408 unless ( $xact->item($item) ) {
410 # $circ->alert(1); $circ->alert_type(99);
411 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
412 syslog('LOG_INFO', "OILS: Checkin failed. " . $xact->screen_msg() );
416 $xact->do_checkin( $self, $inst_id, $trans_date, $return_date, $current_loc, $item_props );
419 $xact->patron($self->find_patron(usr => $xact->{circ_user_id}, slim_user => 1)) if $xact->{circ_user_id};
420 delete $item->{patron};
421 delete $item->{due_date};
422 syslog('LOG_INFO', "OILS: Checkin succeeded");
424 syslog('LOG_WARNING', "OILS: Checkin failed");
427 syslog('LOG_INFO', "OILS: SIP Checkin request took %0.3f seconds", (time() - $start_time));
431 ## If the ILS caches patron information, this lets it free it up.
432 ## Also, this could be used for centrally logging session duration.
433 ## We don't do anything with it.
434 sub end_patron_session {
435 my ($self, $patron_id) = @_;
436 return (1, 'Thank you!', '');
441 my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
442 $pay_type, $fee_id, $trans_id, $currency) = @_;
444 $self->verify_session;
446 my $xact = OpenILS::SIP::Transaction::FeePayment->new(authtoken => $self->{authtoken});
447 my $patron = $self->find_patron($patron_id);
450 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
455 $xact->patron($patron);
456 $xact->sip_currency($currency);
457 $xact->fee_amount($fee_amt);
458 $xact->sip_fee_type($fee_type);
459 $xact->transaction_id($trans_id);
460 $xact->fee_id($fee_id);
461 # We don't presently use these, but we might in the future.
462 $xact->patron_password($patron_pwd);
463 $xact->sip_payment_type($pay_type);
465 $xact->do_fee_payment();
471 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
472 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
473 # my ($patron, $item);
478 # $trans = new ILS::Transaction::Hold;
480 # # BEGIN TRANSACTION
481 # $patron = new ILS::Patron $patron_id;
483 # || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
484 # $trans->screen_msg("Invalid Patron.");
489 # $item = new ILS::Item ($item_id || $title_id);
491 # $trans->screen_msg("No such item.");
493 # # END TRANSACTION (conditionally)
495 # } elsif ($item->fee && ($fee_ack ne 'Y')) {
496 # $trans->screen_msg = "Fee required to place hold.";
498 # # END TRANSACTION (conditionally)
503 # item_id => $item->id,
504 # patron_id => $patron->id,
505 # expiration_date => $expiry_date,
506 # pickup_location => $pickup_location,
507 # hold_type => $hold_type,
511 # $trans->patron($patron);
512 # $trans->item($item);
513 # $trans->pickup_location($pickup_location);
515 # push(@{$item->hold_queue}, $hold);
516 # push(@{$patron->{hold_items}}, $hold);
524 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
525 # my ($patron, $item, $hold);
528 # $trans = new ILS::Transaction::Hold;
530 # # BEGIN TRANSACTION
531 # $patron = new ILS::Patron $patron_id;
533 # $trans->screen_msg("Invalid patron barcode.");
536 # } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
537 # $trans->screen_msg('Invalid patron password.');
542 # $item = new ILS::Item ($item_id || $title_id);
544 # $trans->screen_msg("No such item.");
546 # # END TRANSACTION (conditionally)
550 # # Remove the hold from the patron's record first
551 # $trans->ok($patron->drop_hold($item_id));
554 # # We didn't find it on the patron record
555 # $trans->screen_msg("No such hold on patron record.");
557 # # END TRANSACTION (conditionally)
561 # # Now, remove it from the item record. If it was on the patron
562 # # record but not on the item record, we'll treat that as success.
563 # foreach my $i (0 .. scalar @{$item->hold_queue}) {
564 # $hold = $item->hold_queue->[$i];
566 # if ($hold->{patron_id} eq $patron->id) {
567 # # found it: delete it.
568 # splice @{$item->hold_queue}, $i, 1;
573 # $trans->screen_msg("Hold Cancelled.");
574 # $trans->patron($patron);
575 # $trans->item($item);
581 ## The patron and item id's can't be altered, but the
582 ## date, location, and type can.
584 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
585 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
586 # my ($patron, $item);
590 # $trans = new ILS::Transaction::Hold;
592 # # BEGIN TRANSACTION
593 # $patron = new ILS::Patron $patron_id;
595 # $trans->screen_msg("Invalid patron barcode.");
600 # foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
601 # $hold = $patron->{hold_items}[$i];
603 # if ($hold->{item_id} eq $item_id) {
604 # # Found it. So fix it.
605 # $hold->{expiration_date} = $expiry_date if $expiry_date;
606 # $hold->{pickup_location} = $pickup_location if $pickup_location;
607 # $hold->{hold_type} = $hold_type if $hold_type;
610 # $trans->screen_msg("Hold updated.");
611 # $trans->patron($patron);
612 # $trans->item(new ILS::Item $hold->{item_id});
617 # # The same hold structure is linked into both the patron's
618 # # list of hold items and into the queue of outstanding holds
619 # # for the item, so we don't need to search the hold queue for
620 # # the item, since it's already been updated by the patron code.
623 # $trans->screen_msg("No such outstanding hold.");
631 my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
632 $no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
634 $self->verify_session;
636 my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
637 $trans->patron($self->find_patron($patron_id));
638 $trans->item($self->find_item($item_id));
640 if(!$trans->patron) {
641 $trans->screen_msg("Invalid patron barcode.");
646 if(!$trans->patron->renew_ok) {
647 $trans->screen_msg("Renewals not allowed.");
654 $trans->screen_msg("Title ID renewal not supported. Use item barcode.");
656 $trans->screen_msg("Invalid item barcode.");
662 if(!$trans->item->{patron} or
663 $trans->item->{patron} ne $patron_id) {
664 $trans->screen_msg("Item not checked out to " . $trans->patron->name);
669 # Perform the renewal
672 $trans->desensitize(0); # It's already checked out
673 $trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
674 $trans->item->{sip_item_properties} = $item_props if $item_props;
685 # my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
686 # my ($patron, $item_id);
689 # $trans = new ILS::Transaction::RenewAll;
691 # $trans->patron($patron = new ILS::Patron $patron_id);
692 # if (defined $patron) {
693 # syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
694 # $patron->name, $patron->renew_ok);
696 # syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
700 # if (!defined($patron)) {
701 # $trans->screen_msg("Invalid patron barcode.");
703 # } elsif (!$patron->renew_ok) {
704 # $trans->screen_msg("Renewals not allowed.");
706 # } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
707 # $trans->screen_msg("Invalid patron password.");
711 # foreach $item_id (@{$patron->{items}}) {
712 # my $item = new ILS::Item $item_id;
714 # if (!defined($item)) {
715 # syslog("LOG_WARNING",
716 # "renew_all: Invalid item id associated with patron '%s'",
721 # if (@{$item->hold_queue}) {
722 # # Can't renew if there are outstanding holds
723 # push @{$trans->unrenewed}, $item_id;
725 # $item->{due_date} = time + (14*24*60*60); # two weeks hence
726 # push @{$trans->renewed}, $item_id;