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 OpenSRF::AppSession;
21 use OpenILS::Utils::Fieldmapper;
22 use OpenSRF::Utils::SettingsClient;
23 use OpenILS::Application::AppUtils;
24 use OpenSRF::Utils qw/:datetime/;
25 use DateTime::Format::ISO8601;
27 use Unicode::Normalize;
28 use Sip::Constants qw(SIP_DATETIME);
30 my $U = 'OpenILS::Application::AppUtils';
35 my $target_encoding; # FIXME: this is configured at the institution level.
37 use Digest::MD5 qw(md5_hex);
40 my ($class, $institution, $login) = @_;
41 my $type = ref($class) || $class;
44 $self->{login} = $login_account = $login;
46 $config = $institution;
47 syslog("LOG_DEBUG", "OILS: new ILS '%s'", $institution->{id});
48 $self->{institution} = $institution;
50 my $bsconfig = $institution->{implementation_config}->{bootstrap};
51 $target_encoding = $institution->{implementation_config}->{encoding} || 'ascii';
53 syslog('LOG_DEBUG', "OILS: loading bootstrap config: $bsconfig");
55 # ingress will persist throughout
56 OpenSRF::AppSession->ingress('sip2');
58 local $/ = "\n"; # why?
59 OpenSRF::System->bootstrap_client(config_file => $bsconfig);
60 syslog('LOG_DEBUG', "OILS: bootstrap loaded..");
62 $self->{osrf_config} = OpenSRF::Utils::SettingsClient->new;
64 Fieldmapper->import($self->{osrf_config}->config_value('IDL'));
66 bless( $self, $type );
69 $self->login( $login->{id}, $login->{password} );
77 my $ses = $U->simplereq(
79 'open-ils.auth.session.retrieve', $self->{authtoken});
81 return undef if $U->event_code($ses); # auth timed out
82 return $self->{login_session} = $ses;
88 return 1 if $self->fetch_session;
90 syslog('LOG_INFO', "OILS: Logging back after session timeout as user ".$self->{login}->{id});
91 return $self->login( $self->{login}->{id}, $self->{login}->{password} );
95 return $editor = make_editor();
102 return $login_account;
105 sub get_option_value {
106 my($self, $option) = @_;
107 my $ops = $config->{implementation_config}->{options}->{option};
108 $ops = [$ops] unless ref $ops eq 'ARRAY';
109 my @vals = grep { $_->{name} eq $option } @$ops;
110 return @vals ? $vals[0]->{value} : undef;
114 # Creates the global editor object
115 my $cstore_init = 1; # call init on first use
117 OpenILS::Utils::CStoreEditor::init() if $cstore_init;
119 return OpenILS::Utils::CStoreEditor->new;
122 =head2 clean_text(scalar)
124 Evergreen uses the UTF8 encoding for everything from the database up. Perl
125 doesn't know this, however, so we have to convince it to treat our UTF8 strings
126 as UTF8 strings. This may enable OpenNCIP to correctly calculate the checksums
127 for UTF8 text for SIP clients that support such modern options.
129 The target encoding is set in the <encoding> element of the SIPServer.pm
135 my $text = shift || '';
137 # Convert our incoming UTF8 data into Perl's internal string format
139 # Also convert to Normalization Form D, as the ASCII, iso-8859-1,
140 # and latin-1 encodings (at least) require this to substitute
141 # characters rather than simply returning a string truncated
142 # after the first non-ASCII character
143 $text = NFD(decode_utf8($text));
145 if ($target_encoding eq 'ascii') {
147 # Try to maintain a reasonable version of the content by
148 # stripping diacritics from the text, given that the SIP client
149 # wants just plain ASCII. This is the base requirement according
150 # to the SIP2 specification.
152 # Stripping the combining characters converts ""béè♁ts"
153 # into "bee?ts" instead of "b???ts" - better, eh?
157 # Characters that cannot be represented in the target encoding will
158 # generally be replaced with a question mark (?) character.
159 $text = encode($target_encoding, $text);
165 sub shortname_from_id {
166 my $id = shift or return;
167 return $id->shortname if ref $id;
168 return $org_sn_cache{$id} if $org_sn_cache{$id};
169 return $org_sn_cache{$id} = editor()->retrieve_actor_org_unit($id)->shortname;
171 sub patron_barcode_from_id {
172 my $id = shift or return;
173 return editor()->search_actor_card({ usr => $id, active => 't' })->[0]->barcode;
179 my $type = shift || 'dob';
181 return "" unless $date;
183 my $dt = DateTime::Format::ISO8601->new->
184 parse_datetime(OpenSRF::Utils::cleanse_ISO8601($date));
185 my @time = localtime($dt->epoch);
187 my $year = $time[5]+1900;
188 my $mon = $time[4]+1;
191 my $minute = $time[1];
192 my $second = $time[0];
194 $date = sprintf("%04d%02d%02d", $year, $mon, $day);
196 # Due dates need hyphen separators and time of day as well
197 if ($type eq 'due') {
199 my $use_sdf = $class->get_option_value('use_sip_date_format') | '';
201 if ($use_sdf =~ /true/i) {
202 $date = $dt->strftime(SIP_DATETIME);
205 $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d",
206 $year, $mon, $day, $hour, $minute, $second);
210 syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
217 my( $self, $username, $password ) = @_;
218 syslog('LOG_DEBUG', "OILS: Logging in with username $username");
220 my $seed = $U->simplereq(
222 'open-ils.auth.authenticate.init', $username );
224 my $response = $U->simplereq(
226 'open-ils.auth.authenticate.complete',
228 username => $username,
229 password => md5_hex($seed . md5_hex($password)),
234 if( my $code = $U->event_code($response) ) {
235 my $txt = $response->{textcode};
236 syslog('LOG_WARNING', "OILS: Login failed for $username. $txt:$code");
240 my $key = $response->{payload}->{authtoken};
241 syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
243 $self->fetch_session; # to cache the login
245 return $self->{authtoken} = $key;
249 # find_patron($barcode);
250 # find_patron(barcode => $barcode); # same as above
251 # find_patron(usr => $id);
255 my $key = (@_ > 1) ? shift : 'barcode'; # if we have multiple args, the first is the key index (default barcode)
256 my $patron_id = shift;
258 return OpenILS::SIP::Patron->new($key => $patron_id, authtoken => $self->{authtoken}, @_);
264 return OpenILS::SIP::Item->new(@_);
270 return $self->{institution}->{id}; # consider making this return the whole institution
275 return $self->{institution}->{id}; # then use this for just the ID
279 my ($self, $op) = @_;
280 my ($i) = grep { $_->{name} eq $op }
281 @{$config->{implementation_config}->{supports}->{item}};
282 return to_bool($i->{value});
286 my ($self, $id, $whence) = @_;
287 if ($id ne $self->{institution}->{id}) {
288 syslog("LOG_WARNING", "OILS: %s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
289 # Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
296 # If it's defined, and matches a true sort of string, or is
297 # a non-zero number, then it's true.
298 defined($bool) or return; # false
299 ($bool =~ /true|y|yes/i) and return 1; # true
300 return ($bool =~ /^\d+$/ and $bool != 0); # true for non-zero numbers, false otherwise
304 return to_bool($config->{policy}->{checkout});
308 return to_bool($config->{policy}->{checkin});
312 return to_bool($config->{policy}->{renewal});
315 sub status_update_ok {
316 return to_bool($config->{policy}->{status_update});
320 return to_bool($config->{policy}->{offline});
326 ## Checkout(patron_id, item_id, sc_renew, fee_ack):
327 ## patron_id & item_id are the identifiers send by the terminal
328 ## sc_renew is the renewal policy configured on the terminal
329 ## returns a status opject that can be queried for the various bits
330 ## of information that the protocol (SIP or NCIP) needs to generate
332 ## fee_ack is the fee_acknowledged field (BO) sent from the sc
333 ## when doing chargeable loans.
337 my ($self, $patron_id, $item_id, $sc_renew, $fee_ack) = @_;
338 # In order to allow renewals the selfcheck AND the config have to say they are allowed
339 $sc_renew = (chr($sc_renew) eq 'Y' && $self->renew_ok());
341 $self->verify_session;
343 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
345 my $xact = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
346 my $patron = $self->find_patron($patron_id);
347 my $item = $self->find_item($item_id);
349 $xact->patron($patron);
353 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
357 if (!$patron->charge_ok) {
358 $xact->screen_msg("Patron Blocked");
363 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
367 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
369 if ($item->{patron} && ($item->{patron} eq $patron_id)) {
370 $xact->renew_ok(1); # So that accept/reject responses have the correct value later
372 syslog('LOG_INFO', "OILS: OpenILS::Checkout data loaded OK, doing renew...");
374 syslog('LOG_INFO', "OILS: OpenILS::Checkout appears to be renew, but renewal disallowed...");
375 $xact->screen_msg("Renewals not permitted");
377 return $xact; # Don't attempt later
379 } elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
380 # I can't deal with this right now
381 # XXX check in then check out?
382 $xact->screen_msg("Item checked out to another patron");
384 return $xact; # Don't wipe out the screen message later
389 # Check for fee and $fee_ack. If there is a fee, and $fee_ack
390 # is 'Y', we proceed, otherwise we reject the checkout.
391 if ($item->fee > 0.0) {
392 $xact->fee_amount($item->fee);
393 $xact->sip_fee_type($item->sip_fee_type);
394 $xact->sip_currency($item->fee_currency);
395 if ($fee_ack && $fee_ack eq 'Y') {
398 $xact->screen_msg('Fee required');
404 $xact->do_checkout($sc_renew);
405 $xact->desensitize(!$item->magnetic);
409 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
410 "patron %s checkout %s succeeded", $patron_id, $item_id);
412 #editor()->xact_rollback;
413 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
414 "patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
422 my ($self, $item_id, $inst_id, $trans_date, $return_date,
423 $current_loc, $item_props, $cancel) = @_;
425 my $start_time = time();
427 $self->verify_session;
429 syslog('LOG_DEBUG', "OILS: OpenILS::Checkin of item=$item_id (to $inst_id)");
431 my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
432 my $item = OpenILS::SIP::Item->new($item_id);
434 unless ( $xact->item($item) ) {
436 # $circ->alert(1); $circ->alert_type(99);
437 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
438 syslog('LOG_INFO', "OILS: Checkin failed. " . $xact->screen_msg() );
442 $xact->do_checkin( $self, $inst_id, $trans_date, $return_date, $current_loc, $item_props );
445 $xact->patron($self->find_patron(usr => $xact->{circ_user_id}, slim_user => 1)) if $xact->{circ_user_id};
446 delete $item->{patron};
447 delete $item->{due_date};
448 syslog('LOG_INFO', "OILS: Checkin succeeded");
450 syslog('LOG_WARNING', "OILS: Checkin failed");
453 syslog('LOG_INFO', "OILS: SIP Checkin request took %0.3f seconds", (time() - $start_time));
457 ## If the ILS caches patron information, this lets it free it up.
458 ## Also, this could be used for centrally logging session duration.
459 ## We don't do anything with it.
460 sub end_patron_session {
461 my ($self, $patron_id) = @_;
462 return (1, 'Thank you!', '');
467 my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
468 $pay_type, $fee_id, $trans_id, $currency) = @_;
470 $self->verify_session;
472 my $xact = OpenILS::SIP::Transaction::FeePayment->new(authtoken => $self->{authtoken});
473 my $patron = $self->find_patron($patron_id);
476 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
481 $xact->patron($patron);
482 $xact->sip_currency($currency);
483 $xact->fee_amount($fee_amt);
484 $xact->sip_fee_type($fee_type);
485 $xact->transaction_id($trans_id);
486 $xact->fee_id($fee_id);
487 $xact->sip_payment_type($pay_type);
488 # We don't presently use this, but we might in the future.
489 $xact->patron_password($patron_pwd);
491 $xact->do_fee_payment();
497 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
498 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
499 # my ($patron, $item);
504 # $trans = new ILS::Transaction::Hold;
506 # # BEGIN TRANSACTION
507 # $patron = new ILS::Patron $patron_id;
509 # || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
510 # $trans->screen_msg("Invalid Patron.");
515 # $item = new ILS::Item ($item_id || $title_id);
517 # $trans->screen_msg("No such item.");
519 # # END TRANSACTION (conditionally)
521 # } elsif ($item->fee && ($fee_ack ne 'Y')) {
522 # $trans->screen_msg = "Fee required to place hold.";
524 # # END TRANSACTION (conditionally)
529 # item_id => $item->id,
530 # patron_id => $patron->id,
531 # expiration_date => $expiry_date,
532 # pickup_location => $pickup_location,
533 # hold_type => $hold_type,
537 # $trans->patron($patron);
538 # $trans->item($item);
539 # $trans->pickup_location($pickup_location);
541 # push(@{$item->hold_queue}, $hold);
542 # push(@{$patron->{hold_items}}, $hold);
550 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
551 # my ($patron, $item, $hold);
554 # $trans = new ILS::Transaction::Hold;
556 # # BEGIN TRANSACTION
557 # $patron = new ILS::Patron $patron_id;
559 # $trans->screen_msg("Invalid patron barcode.");
562 # } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
563 # $trans->screen_msg('Invalid patron password.');
568 # $item = new ILS::Item ($item_id || $title_id);
570 # $trans->screen_msg("No such item.");
572 # # END TRANSACTION (conditionally)
576 # # Remove the hold from the patron's record first
577 # $trans->ok($patron->drop_hold($item_id));
580 # # We didn't find it on the patron record
581 # $trans->screen_msg("No such hold on patron record.");
583 # # END TRANSACTION (conditionally)
587 # # Now, remove it from the item record. If it was on the patron
588 # # record but not on the item record, we'll treat that as success.
589 # foreach my $i (0 .. scalar @{$item->hold_queue}) {
590 # $hold = $item->hold_queue->[$i];
592 # if ($hold->{patron_id} eq $patron->id) {
593 # # found it: delete it.
594 # splice @{$item->hold_queue}, $i, 1;
599 # $trans->screen_msg("Hold Cancelled.");
600 # $trans->patron($patron);
601 # $trans->item($item);
607 ## The patron and item id's can't be altered, but the
608 ## date, location, and type can.
610 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
611 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
612 # my ($patron, $item);
616 # $trans = new ILS::Transaction::Hold;
618 # # BEGIN TRANSACTION
619 # $patron = new ILS::Patron $patron_id;
621 # $trans->screen_msg("Invalid patron barcode.");
626 # foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
627 # $hold = $patron->{hold_items}[$i];
629 # if ($hold->{item_id} eq $item_id) {
630 # # Found it. So fix it.
631 # $hold->{expiration_date} = $expiry_date if $expiry_date;
632 # $hold->{pickup_location} = $pickup_location if $pickup_location;
633 # $hold->{hold_type} = $hold_type if $hold_type;
636 # $trans->screen_msg("Hold updated.");
637 # $trans->patron($patron);
638 # $trans->item(new ILS::Item $hold->{item_id});
643 # # The same hold structure is linked into both the patron's
644 # # list of hold items and into the queue of outstanding holds
645 # # for the item, so we don't need to search the hold queue for
646 # # the item, since it's already been updated by the patron code.
649 # $trans->screen_msg("No such outstanding hold.");
657 my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
658 $no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
660 $self->verify_session;
662 my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
663 $trans->patron($self->find_patron($patron_id));
664 $trans->item($self->find_item($item_id));
666 if(!$trans->patron) {
667 $trans->screen_msg("Invalid patron barcode.");
672 if(!$trans->patron->renew_ok) {
673 $trans->screen_msg("Renewals not allowed.");
680 $trans->screen_msg("Title ID renewal not supported. Use item barcode.");
682 $trans->screen_msg("Invalid item barcode.");
688 if(!$trans->item->{patron} or
689 $trans->item->{patron} ne $patron_id) {
690 $trans->screen_msg("Item not checked out to " . $trans->patron->name);
695 # Perform the renewal
698 $trans->desensitize(0); # It's already checked out
699 $trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
700 $trans->item->{sip_item_properties} = $item_props if $item_props;
711 # my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
712 # my ($patron, $item_id);
715 # $trans = new ILS::Transaction::RenewAll;
717 # $trans->patron($patron = new ILS::Patron $patron_id);
718 # if (defined $patron) {
719 # syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
720 # $patron->name, $patron->renew_ok);
722 # syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
726 # if (!defined($patron)) {
727 # $trans->screen_msg("Invalid patron barcode.");
729 # } elsif (!$patron->renew_ok) {
730 # $trans->screen_msg("Renewals not allowed.");
732 # } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
733 # $trans->screen_msg("Invalid patron password.");
737 # foreach $item_id (@{$patron->{items}}) {
738 # my $item = new ILS::Item $item_id;
740 # if (!defined($item)) {
741 # syslog("LOG_WARNING",
742 # "renew_all: Invalid item id associated with patron '%s'",
747 # if (@{$item->hold_queue}) {
748 # # Can't renew if there are outstanding holds
749 # push @{$trans->unrenewed}, $item_id;
751 # $item->{due_date} = time + (14*24*60*60); # two weeks hence
752 # push @{$trans->renewed}, $item_id;