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 my $U = 'OpenILS::Application::AppUtils';
33 my $target_encoding; # FIXME: this is configured at the institution level.
35 use Digest::MD5 qw(md5_hex);
38 my ($class, $institution, $login) = @_;
39 my $type = ref($class) || $class;
42 $self->{login} = $login_account = $login;
44 $config = $institution;
45 syslog("LOG_DEBUG", "OILS: new ILS '%s'", $institution->{id});
46 $self->{institution} = $institution;
48 my $bsconfig = $institution->{implementation_config}->{bootstrap};
49 $target_encoding = $institution->{implementation_config}->{encoding} || 'ascii';
51 syslog('LOG_DEBUG', "OILS: loading bootstrap config: $bsconfig");
53 # ingress will persist throughout
54 OpenSRF::AppSession->ingress('sip2');
56 local $/ = "\n"; # why?
57 OpenSRF::System->bootstrap_client(config_file => $bsconfig);
58 syslog('LOG_DEBUG', "OILS: bootstrap loaded..");
60 $self->{osrf_config} = OpenSRF::Utils::SettingsClient->new;
62 Fieldmapper->import($self->{osrf_config}->config_value('IDL'));
64 bless( $self, $type );
67 $self->login( $login->{id}, $login->{password} );
75 my $ses = $U->simplereq(
77 'open-ils.auth.session.retrieve', $self->{authtoken});
79 return undef if $U->event_code($ses); # auth timed out
80 return $self->{login_session} = $ses;
86 return 1 if $self->fetch_session;
88 syslog('LOG_INFO', "OILS: Logging back after session timeout as user ".$self->{login}->{id});
89 return $self->login( $self->{login}->{id}, $self->{login}->{password} );
93 return $editor = make_editor();
100 return $login_account;
103 sub get_option_value {
104 my($self, $option) = @_;
105 my $ops = $config->{implementation_config}->{options}->{option};
106 $ops = [$ops] unless ref $ops eq 'ARRAY';
107 my @vals = grep { $_->{name} eq $option } @$ops;
108 return @vals ? $vals[0]->{value} : undef;
112 # Creates the global editor object
113 my $cstore_init = 1; # call init on first use
115 OpenILS::Utils::CStoreEditor::init() if $cstore_init;
117 return OpenILS::Utils::CStoreEditor->new;
120 =head2 clean_text(scalar)
122 Evergreen uses the UTF8 encoding for everything from the database up. Perl
123 doesn't know this, however, so we have to convince it to treat our UTF8 strings
124 as UTF8 strings. This may enable OpenNCIP to correctly calculate the checksums
125 for UTF8 text for SIP clients that support such modern options.
127 The target encoding is set in the <encoding> element of the SIPServer.pm
133 my $text = shift || '';
135 # Convert our incoming UTF8 data into Perl's internal string format
137 # Also convert to Normalization Form D, as the ASCII, iso-8859-1,
138 # and latin-1 encodings (at least) require this to substitute
139 # characters rather than simply returning a string truncated
140 # after the first non-ASCII character
141 $text = NFD(decode_utf8($text));
143 if ($target_encoding eq 'ascii') {
145 # Try to maintain a reasonable version of the content by
146 # stripping diacritics from the text, given that the SIP client
147 # wants just plain ASCII. This is the base requirement according
148 # to the SIP2 specification.
150 # Stripping the combining characters converts ""béè♁ts"
151 # into "bee?ts" instead of "b???ts" - better, eh?
155 # Characters that cannot be represented in the target encoding will
156 # generally be replaced with a question mark (?) character.
157 $text = encode($target_encoding, $text);
163 sub shortname_from_id {
164 my $id = shift or return;
165 return $id->shortname if ref $id;
166 return $org_sn_cache{$id} if $org_sn_cache{$id};
167 return $org_sn_cache{$id} = editor()->retrieve_actor_org_unit($id)->shortname;
169 sub patron_barcode_from_id {
170 my $id = shift or return;
171 return editor()->search_actor_card({ usr => $id, active => 't' })->[0]->barcode;
177 my $type = shift || 'dob';
179 return "" unless $date;
181 $date = DateTime::Format::ISO8601->new->
182 parse_datetime(OpenSRF::Utils::cleanse_ISO8601($date));
183 my @time = localtime($date->epoch);
185 my $year = $time[5]+1900;
186 my $mon = $time[4]+1;
189 my $minute = $time[1];
190 my $second = $time[0];
192 $date = sprintf("%04d%02d%02d", $year, $mon, $day);
194 # Due dates need hyphen separators and time of day as well
195 if ($type eq 'due') {
196 $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year, $mon, $day, $hour, $minute, $second);
199 syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
206 my( $self, $username, $password ) = @_;
207 syslog('LOG_DEBUG', "OILS: Logging in with username $username");
209 my $seed = $U->simplereq(
211 'open-ils.auth.authenticate.init', $username );
213 my $response = $U->simplereq(
215 'open-ils.auth.authenticate.complete',
217 username => $username,
218 password => md5_hex($seed . md5_hex($password)),
223 if( my $code = $U->event_code($response) ) {
224 my $txt = $response->{textcode};
225 syslog('LOG_WARNING', "OILS: Login failed for $username. $txt:$code");
229 my $key = $response->{payload}->{authtoken};
230 syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
232 $self->fetch_session; # to cache the login
234 return $self->{authtoken} = $key;
238 # find_patron($barcode);
239 # find_patron(barcode => $barcode); # same as above
240 # find_patron(usr => $id);
244 my $key = (@_ > 1) ? shift : 'barcode'; # if we have multiple args, the first is the key index (default barcode)
245 my $patron_id = shift;
247 return OpenILS::SIP::Patron->new($key => $patron_id, authtoken => $self->{authtoken}, @_);
253 return OpenILS::SIP::Item->new(@_);
259 return $self->{institution}->{id}; # consider making this return the whole institution
264 return $self->{institution}->{id}; # then use this for just the ID
268 my ($self, $op) = @_;
269 my ($i) = grep { $_->{name} eq $op }
270 @{$config->{implementation_config}->{supports}->{item}};
271 return to_bool($i->{value});
275 my ($self, $id, $whence) = @_;
276 if ($id ne $self->{institution}->{id}) {
277 syslog("LOG_WARNING", "OILS: %s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
278 # Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
285 # If it's defined, and matches a true sort of string, or is
286 # a non-zero number, then it's true.
287 defined($bool) or return; # false
288 ($bool =~ /true|y|yes/i) and return 1; # true
289 return ($bool =~ /^\d+$/ and $bool != 0); # true for non-zero numbers, false otherwise
293 return to_bool($config->{policy}->{checkout});
297 return to_bool($config->{policy}->{checkin});
301 return to_bool($config->{policy}->{renewal});
304 sub status_update_ok {
305 return to_bool($config->{policy}->{status_update});
309 return to_bool($config->{policy}->{offline});
315 ## Checkout(patron_id, item_id, sc_renew, fee_ack):
316 ## patron_id & item_id are the identifiers send by the terminal
317 ## sc_renew is the renewal policy configured on the terminal
318 ## returns a status opject that can be queried for the various bits
319 ## of information that the protocol (SIP or NCIP) needs to generate
321 ## fee_ack is the fee_acknowledged field (BO) sent from the sc
322 ## when doing chargeable loans.
326 my ($self, $patron_id, $item_id, $sc_renew, $fee_ack) = @_;
327 # In order to allow renewals the selfcheck AND the config have to say they are allowed
328 $sc_renew = (chr($sc_renew) eq 'Y' && $self->renew_ok());
330 $self->verify_session;
332 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
334 my $xact = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
335 my $patron = $self->find_patron($patron_id);
336 my $item = $self->find_item($item_id);
338 $xact->patron($patron);
342 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
346 if (!$patron->charge_ok) {
347 $xact->screen_msg("Patron Blocked");
352 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
356 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
358 if ($item->{patron} && ($item->{patron} eq $patron_id)) {
359 $xact->renew_ok(1); # So that accept/reject responses have the correct value later
361 syslog('LOG_INFO', "OILS: OpenILS::Checkout data loaded OK, doing renew...");
363 syslog('LOG_INFO', "OILS: OpenILS::Checkout appears to be renew, but renewal disallowed...");
364 $xact->screen_msg("Renewals not permitted");
366 return $xact; # Don't attempt later
368 } elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
369 # I can't deal with this right now
370 # XXX check in then check out?
371 $xact->screen_msg("Item checked out to another patron");
373 return $xact; # Don't wipe out the screen message later
378 # Check for fee and $fee_ack. If there is a fee, and $fee_ack
379 # is 'Y', we proceed, otherwise we reject the checkout.
380 if ($item->fee > 0.0) {
381 $xact->fee_amount($item->fee);
382 $xact->sip_fee_type($item->sip_fee_type);
383 $xact->sip_currency($item->fee_currency);
384 if ($fee_ack && $fee_ack eq 'Y') {
387 $xact->screen_msg('Fee required');
393 $xact->do_checkout($sc_renew);
394 $xact->desensitize(!$item->magnetic);
398 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
399 "patron %s checkout %s succeeded", $patron_id, $item_id);
401 #editor()->xact_rollback;
402 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
403 "patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
411 my ($self, $item_id, $inst_id, $trans_date, $return_date,
412 $current_loc, $item_props, $cancel) = @_;
414 my $start_time = time();
416 $self->verify_session;
418 syslog('LOG_DEBUG', "OILS: OpenILS::Checkin of item=$item_id (to $inst_id)");
420 my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
421 my $item = OpenILS::SIP::Item->new($item_id);
423 unless ( $xact->item($item) ) {
425 # $circ->alert(1); $circ->alert_type(99);
426 $xact->screen_msg("Invalid Item Barcode: '$item_id'");
427 syslog('LOG_INFO', "OILS: Checkin failed. " . $xact->screen_msg() );
431 $xact->do_checkin( $self, $inst_id, $trans_date, $return_date, $current_loc, $item_props );
434 $xact->patron($self->find_patron(usr => $xact->{circ_user_id}, slim_user => 1)) if $xact->{circ_user_id};
435 delete $item->{patron};
436 delete $item->{due_date};
437 syslog('LOG_INFO', "OILS: Checkin succeeded");
439 syslog('LOG_WARNING', "OILS: Checkin failed");
442 syslog('LOG_INFO', "OILS: SIP Checkin request took %0.3f seconds", (time() - $start_time));
446 ## If the ILS caches patron information, this lets it free it up.
447 ## Also, this could be used for centrally logging session duration.
448 ## We don't do anything with it.
449 sub end_patron_session {
450 my ($self, $patron_id) = @_;
451 return (1, 'Thank you!', '');
456 my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
457 $pay_type, $fee_id, $trans_id, $currency) = @_;
459 $self->verify_session;
461 my $xact = OpenILS::SIP::Transaction::FeePayment->new(authtoken => $self->{authtoken});
462 my $patron = $self->find_patron($patron_id);
465 $xact->screen_msg("Invalid Patron Barcode '$patron_id'");
470 $xact->patron($patron);
471 $xact->sip_currency($currency);
472 $xact->fee_amount($fee_amt);
473 $xact->sip_fee_type($fee_type);
474 $xact->transaction_id($trans_id);
475 $xact->fee_id($fee_id);
476 $xact->sip_payment_type($pay_type);
477 # We don't presently use this, but we might in the future.
478 $xact->patron_password($patron_pwd);
480 $xact->do_fee_payment();
486 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
487 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
488 # my ($patron, $item);
493 # $trans = new ILS::Transaction::Hold;
495 # # BEGIN TRANSACTION
496 # $patron = new ILS::Patron $patron_id;
498 # || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
499 # $trans->screen_msg("Invalid Patron.");
504 # $item = new ILS::Item ($item_id || $title_id);
506 # $trans->screen_msg("No such item.");
508 # # END TRANSACTION (conditionally)
510 # } elsif ($item->fee && ($fee_ack ne 'Y')) {
511 # $trans->screen_msg = "Fee required to place hold.";
513 # # END TRANSACTION (conditionally)
518 # item_id => $item->id,
519 # patron_id => $patron->id,
520 # expiration_date => $expiry_date,
521 # pickup_location => $pickup_location,
522 # hold_type => $hold_type,
526 # $trans->patron($patron);
527 # $trans->item($item);
528 # $trans->pickup_location($pickup_location);
530 # push(@{$item->hold_queue}, $hold);
531 # push(@{$patron->{hold_items}}, $hold);
539 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
540 # my ($patron, $item, $hold);
543 # $trans = new ILS::Transaction::Hold;
545 # # BEGIN TRANSACTION
546 # $patron = new ILS::Patron $patron_id;
548 # $trans->screen_msg("Invalid patron barcode.");
551 # } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
552 # $trans->screen_msg('Invalid patron password.');
557 # $item = new ILS::Item ($item_id || $title_id);
559 # $trans->screen_msg("No such item.");
561 # # END TRANSACTION (conditionally)
565 # # Remove the hold from the patron's record first
566 # $trans->ok($patron->drop_hold($item_id));
569 # # We didn't find it on the patron record
570 # $trans->screen_msg("No such hold on patron record.");
572 # # END TRANSACTION (conditionally)
576 # # Now, remove it from the item record. If it was on the patron
577 # # record but not on the item record, we'll treat that as success.
578 # foreach my $i (0 .. scalar @{$item->hold_queue}) {
579 # $hold = $item->hold_queue->[$i];
581 # if ($hold->{patron_id} eq $patron->id) {
582 # # found it: delete it.
583 # splice @{$item->hold_queue}, $i, 1;
588 # $trans->screen_msg("Hold Cancelled.");
589 # $trans->patron($patron);
590 # $trans->item($item);
596 ## The patron and item id's can't be altered, but the
597 ## date, location, and type can.
599 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
600 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
601 # my ($patron, $item);
605 # $trans = new ILS::Transaction::Hold;
607 # # BEGIN TRANSACTION
608 # $patron = new ILS::Patron $patron_id;
610 # $trans->screen_msg("Invalid patron barcode.");
615 # foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
616 # $hold = $patron->{hold_items}[$i];
618 # if ($hold->{item_id} eq $item_id) {
619 # # Found it. So fix it.
620 # $hold->{expiration_date} = $expiry_date if $expiry_date;
621 # $hold->{pickup_location} = $pickup_location if $pickup_location;
622 # $hold->{hold_type} = $hold_type if $hold_type;
625 # $trans->screen_msg("Hold updated.");
626 # $trans->patron($patron);
627 # $trans->item(new ILS::Item $hold->{item_id});
632 # # The same hold structure is linked into both the patron's
633 # # list of hold items and into the queue of outstanding holds
634 # # for the item, so we don't need to search the hold queue for
635 # # the item, since it's already been updated by the patron code.
638 # $trans->screen_msg("No such outstanding hold.");
646 my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
647 $no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
649 $self->verify_session;
651 my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
652 $trans->patron($self->find_patron($patron_id));
653 $trans->item($self->find_item($item_id));
655 if(!$trans->patron) {
656 $trans->screen_msg("Invalid patron barcode.");
661 if(!$trans->patron->renew_ok) {
662 $trans->screen_msg("Renewals not allowed.");
669 $trans->screen_msg("Title ID renewal not supported. Use item barcode.");
671 $trans->screen_msg("Invalid item barcode.");
677 if(!$trans->item->{patron} or
678 $trans->item->{patron} ne $patron_id) {
679 $trans->screen_msg("Item not checked out to " . $trans->patron->name);
684 # Perform the renewal
687 $trans->desensitize(0); # It's already checked out
688 $trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
689 $trans->item->{sip_item_properties} = $item_props if $item_props;
700 # my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
701 # my ($patron, $item_id);
704 # $trans = new ILS::Transaction::RenewAll;
706 # $trans->patron($patron = new ILS::Patron $patron_id);
707 # if (defined $patron) {
708 # syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
709 # $patron->name, $patron->renew_ok);
711 # syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
715 # if (!defined($patron)) {
716 # $trans->screen_msg("Invalid patron barcode.");
718 # } elsif (!$patron->renew_ok) {
719 # $trans->screen_msg("Renewals not allowed.");
721 # } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
722 # $trans->screen_msg("Invalid patron password.");
726 # foreach $item_id (@{$patron->{items}}) {
727 # my $item = new ILS::Item $item_id;
729 # if (!defined($item)) {
730 # syslog("LOG_WARNING",
731 # "renew_all: Invalid item id associated with patron '%s'",
736 # if (@{$item->hold_queue}) {
737 # # Can't renew if there are outstanding holds
738 # push @{$trans->unrenewed}, $item_id;
740 # $item->{due_date} = time + (14*24*60*60); # two weeks hence
741 # push @{$trans->renewed}, $item_id;