From f089d393dc421f484bb806b0c587ffefe0d9020b Mon Sep 17 00:00:00 2001 From: Jesse Weaver Date: Fri, 11 Dec 2015 14:26:20 -0700 Subject: [PATCH] Bug 13937: Add a Z39.50 daemon that can inject item status MARC subfields This creates a new daemon, misc/z3950_responder.pl, which can respond to Z39.50 requests. By default, it just proxies searches to Zebra. If desired, however, it can also add a subfield to the item tags on outgoing records with a textual description of the item's status (checked out, lost, etc.). This is useful for certain ILL systems. These strings can be translated using the 'Z3950_STATUS' authorized value. Test plan: 1) Start the Z39.50 server using `perl misc/z3950_responder.pl`. 2) Connect to the server using `yaz-client 127.0.0.1:9999/biblios`. 3) Run a search, such as `find @attr 1=1016 book`. 4) Fetch the results both one at a time with `show 1` and in a batch using `show 1+5`. 5) Turn on MARCXML using `format xml` and `elements marcxml`, and verify that the records are still correctly fetched. 6) Enable the item status subfield by restarting the server with the option `--add-item-status=k`. 7) Search for and fetch records, and verify that a $k subfield is added to the item tags as appropriate. It should show some combination of "Checked Out", "Lost", "Not For Loan", "Damaged", "Withdrawn", "In Transit", or "On Hold" as appropriate, or "Available". 8) Add an authorized value named "Z3950_STATUS" with any of the keys "AVAILABLE", "CHECKED_OUT", "LOST", "NOT_FOR_LOAN", "DAMAGED", "WITHDRAWN", "IN_TRANSIT" or "ON_HOLD", and verify that their descriptions are used instead of the default values above. Signed-off-by: George Williams Signed-off-by: Stefan Berndtsson Signed-off-by: Martin Renvoize --- C4/Installer/PerlDependencies.pm | 10 + Koha/Logger.pm | 24 +++ Koha/Z3950Responder.pm | 133 +++++++++++++ Koha/Z3950Responder/Session.pm | 330 +++++++++++++++++++++++++++++++ etc/log4perl.conf | 7 + misc/z3950_responder.pl | 153 ++++++++++++++ 6 files changed, 657 insertions(+) create mode 100644 Koha/Z3950Responder.pm create mode 100644 Koha/Z3950Responder/Session.pm create mode 100755 misc/z3950_responder.pl diff --git a/C4/Installer/PerlDependencies.pm b/C4/Installer/PerlDependencies.pm index 3c130d05d6..df1038eb1b 100644 --- a/C4/Installer/PerlDependencies.pm +++ b/C4/Installer/PerlDependencies.pm @@ -908,6 +908,16 @@ our $PERL_DEPS = { required => '1', min_ver => '0.37', }, + 'Path::Tiny' => { + usage => 'core', + required => 1, + min_ver => '0.058', + }, + 'Net::Z3950::SimpleServer' => { + 'usage' => 'Z39.50 responder', + 'required' => '0', + 'min_ver' => '1.15', + }, }; 1; diff --git a/Koha/Logger.pm b/Koha/Logger.pm index ed85c99d72..c58e0bc0a6 100644 --- a/Koha/Logger.pm +++ b/Koha/Logger.pm @@ -181,6 +181,30 @@ sub _recheck_logfile { # recheck saved logfile when logging message return -w $log; } +=head2 debug_to_screen + +Adds a new appender for the given logger that will log all DEBUG-and-higher messages to stderr. +Useful for daemons. + +=cut + +sub debug_to_screen { + my $self = shift; + + return unless ( $self->{logger} ); + + my $appender = Log::Log4perl::Appender->new( + 'Log::Log4perl::Appender::Screen', + stderr => 1, + utf8 => 1, + name => 'debug_to_screen' # We need a specific name to prevent duplicates + ); + + $appender->threshold( $Log::Log4perl::DEBUG ); + $self->{logger}->add_appender( $appender ); + $self->{logger}->level( $Log::Log4perl::DEBUG ); +} + =head1 AUTHOR Kyle M Hall, Ekyle@bywatersolutions.comE diff --git a/Koha/Z3950Responder.pm b/Koha/Z3950Responder.pm new file mode 100644 index 0000000000..cda52ead25 --- /dev/null +++ b/Koha/Z3950Responder.pm @@ -0,0 +1,133 @@ +#!/usr/bin/perl + +package Koha::Z3950Responder; + +# Copyright ByWater Solutions 2016 +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +use Modern::Perl; + +use C4::Biblio qw( GetMarcFromKohaField ); +use C4::Koha qw( GetAuthorisedValues ); + +use Koha; +use Koha::Z3950Responder::Session; + +use Net::Z3950::SimpleServer; + +sub new { + my ( $class, $config ) = @_; + + my ($item_tag, $itemnumber_subfield) = GetMarcFromKohaField( "items.itemnumber", '' ); + + # We hardcode the strings for English so SOMETHING will work if the authorized value doesn't exist. + my $status_strings = { + AVAILABLE => 'Available', + CHECKED_OUT => 'Checked Out', + LOST => 'Lost', + NOT_FOR_LOAN => 'Not for Loan', + DAMAGED => 'Damaged', + WITHDRAWN => 'Withdrawn', + IN_TRANSIT => 'In Transit', + ON_HOLD => 'On Hold', + }; + + foreach my $val ( @{ GetAuthorisedValues( 'Z3950_STATUS' ) } ) { + $status_strings->{ $val->{authorised_value} } = $val->{lib}; + } + + my $self = { + %$config, + item_tag => $item_tag, + itemnumber_subfield => $itemnumber_subfield, + status_strings => $status_strings, + }; + + # Turn off Yaz's built-in logging (can be turned back on if desired). + unshift @{ $self->{yaz_options} }, '-v', 'none'; + + # If requested, turn on debugging. + if ( $self->{debug} ) { + # Turn on single-process mode. + unshift @{ $self->{yaz_options} }, '-S'; + } + + $self->{server} = Net::Z3950::SimpleServer->new( + INIT => sub { $self->init_handler(@_) }, + SEARCH => sub { $self->search_handler(@_) }, + PRESENT => sub { $self->present_handler(@_) }, + FETCH => sub { $self->fetch_handler(@_) }, + CLOSE => sub { $self->close_handler(@_) }, + ); + + return bless( $self, $class ); +} + +sub start { + my ( $self ) = @_; + + $self->{server}->launch_server( 'Koha::Z3950Responder', @{ $self->{yaz_options} } ) +} + +# The rest of these methods are SimpleServer callbacks bound to this Z3950Responder object. It's +# worth noting that these callbacks don't return anything; they both receive and return data in the +# $args hashref. + +sub init_handler { + # Called when the client first connects. + my ( $self, $args ) = @_; + + # This holds all of the per-connection state. + my $session = Koha::Z3950Responder::Session->new({ + server => $self, + peer => $args->{PEER_NAME}, + }); + + $args->{HANDLE} = $session; + + $args->{IMP_NAME} = "Koha"; + $args->{IMP_VER} = Koha::version; +} + +sub search_handler { + # Called when search is first sent. + my ( $self, $args ) = @_; + + $args->{HANDLE}->search_handler($args); +} + +sub present_handler { + # Called when a set of records is requested. + my ( $self, $args ) = @_; + + $args->{HANDLE}->present_handler($args); +} + +sub fetch_handler { + # Called when a given record is requested. + my ( $self, $args ) = @_; + + $args->{HANDLE}->fetch_handler( $args ); +} + +sub close_handler { + my ( $self, $args ) = @_; + + $args->{HANDLE}->close_handler( $args ); +} + +1; diff --git a/Koha/Z3950Responder/Session.pm b/Koha/Z3950Responder/Session.pm new file mode 100644 index 0000000000..ec9eff3cc7 --- /dev/null +++ b/Koha/Z3950Responder/Session.pm @@ -0,0 +1,330 @@ +#!/usr/bin/perl + +package Koha::Z3950Responder::Session; + +# Copyright ByWater Solutions 2016 +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +use Modern::Perl; + +use C4::Circulation qw( GetTransfers ); +use C4::Context; +use C4::Items qw( GetItem ); +use C4::Reserves qw( GetReserveStatus ); +use C4::Search qw(); +use Koha::Logger; + +use ZOOM; + +use constant { + UNIMARC_OID => '1.2.840.10003.5.1', + USMARC_OID => '1.2.840.10003.5.10', + MARCXML_OID => '1.2.840.10003.5.109.10' +}; + +use constant { + ERR_TEMPORARY_ERROR => 2, + ERR_PRESENT_OUT_OF_RANGE => 13, + ERR_RECORD_TOO_LARGE => 16, + ERR_NO_SUCH_RESULTSET => 30, + ERR_SYNTAX_UNSUPPORTED => 230, + ERR_DB_DOES_NOT_EXIST => 235, +}; + +sub new { + my ( $class, $args ) = @_; + + my $self = bless( { + %$args, + logger => Koha::Logger->get({ interface => 'z3950' }), + resultsets => {}, + }, $class ); + + if ( $self->{server}->{debug} ) { + $self->{logger}->debug_to_screen(); + } + + $self->_log_info("connected"); + + return $self; +} + +sub _log_debug { + my ( $self, $msg ) = @_; + $self->{logger}->debug("[$self->{peer}] $msg"); +} + +sub _log_info { + my ( $self, $msg ) = @_; + $self->{logger}->info("[$self->{peer}] $msg"); +} + +sub _log_error { + my ( $self, $msg ) = @_; + $self->{logger}->error("[$self->{peer}] $msg"); +} + +sub _set_error { + my ( $self, $args, $code, $msg ) = @_; + ( $args->{ERR_CODE}, $args->{ERR_STR} ) = ( $code, $msg ); + + $self->_log_error(" returning error $code: $msg"); +} + +sub _set_error_from_zoom { + my ( $self, $args, $exception ) = @_; + + $self->_set_error( $args, ERR_TEMPORARY_ERROR, 'Cannot connect to upstream server' ); + $self->_log_error( + "Zebra upstream error: " . + $exception->message() . " (" . + $exception->code() . ") " . + ( $exception->addinfo() // '' ) . " " . + $exception->diagset() + ); +} + +# This code originally went through C4::Search::getRecords, but had to use so many escape hatches +# that it was easier to directly connect to Zebra. +sub _start_search { + my ( $self, $args, $in_retry ) = @_; + + my $database = $args->{DATABASES}->[0]; + my ( $connection, $results ); + + eval { + $connection = C4::Context->Zconn( + # We're depending on the caller to have done some validation. + $database eq 'biblios' ? 'biblioserver' : 'authorityserver', + 0 # No, no async, doesn't really help much for single-server searching + ); + + $results = $connection->search_pqf( $args->{QUERY} ); + + $self->_log_debug(' retry successful') if ($in_retry); + }; + if ($@) { + die $@ if ( ref($@) ne 'ZOOM::Exception' ); + + if ( $@->diagset() eq 'ZOOM' && $@->code() == 10004 && !$in_retry ) { + $self->_log_debug(' upstream server lost connection, retrying'); + return $self->_start_search( $args, 1 ); + } + + _set_error_from_zoom( $args, $@ ); + $connection = undef; + } + + return ( $connection, $results, $results ? $results->size() : -1 ); +} + +sub _check_fetch { + my ( $self, $resultset, $args, $offset, $num_records ) = @_; + + if ( !defined( $resultset ) ) { + $self->_set_error( $args, ERR_NO_SUCH_RESULTSET, 'No such resultset' ); + return 0; + } + + if ( $offset + $num_records > $resultset->{hits} ) { + $self->_set_error( $args, ERR_PRESENT_OUT_OF_RANGE, 'Fetch request out of range' ); + return 0; + } + + return 1; +} + +sub _fetch_record { + my ( $self, $resultset, $args, $index, $num_to_prefetch ) = @_; + + my $record; + + eval { + if ( !$resultset->{results}->record_immediate( $index ) ) { + my $start = int( $index / $num_to_prefetch ) * $num_to_prefetch; + + if ( $start + $num_to_prefetch >= $resultset->{results}->size() ) { + $num_to_prefetch = $resultset->{results}->size() - $start; + } + + $self->_log_debug(" fetch uncached, fetching $num_to_prefetch records starting at $start"); + + $resultset->{results}->records( $start, $num_to_prefetch, 0 ); + } + + $record = $resultset->{results}->record_immediate( $index )->raw(); + }; + if ($@) { + die $@ if ( ref($@) ne 'ZOOM::Exception' ); + $self->_set_error_from_zoom( $args, $@ ); + return; + } else { + return $record; + } +} + +sub search_handler { + # Called when search is first sent. + my ( $self, $args ) = @_; + + my $database = $args->{DATABASES}->[0]; + + if ( $database !~ /^(biblios|authorities)$/ ) { + $self->_set_error( ERR_DB_DOES_NOT_EXIST, 'No such database' ); + return; + } + + my $query = $args->{QUERY}; + $self->_log_info("received search for '$query', (RS $args->{SETNAME})"); + + my ( $connection, $results, $num_hits ) = $self->_start_search( $args ); + return unless $connection; + + $args->{HITS} = $num_hits; + my $resultset = $self->{resultsets}->{ $args->{SETNAME} } = { + database => $database, + connection => $connection, + results => $results, + query => $args->{QUERY}, + hits => $args->{HITS}, + }; +} + +sub present_handler { + # Called when a set of records is requested. + my ( $self, $args ) = @_; + + $self->_log_debug("received present for $args->{SETNAME}, $args->{START}+$args->{NUMBER}"); + + my $resultset = $self->{resultsets}->{ $args->{SETNAME} }; + # The offset comes across 1-indexed. + my $offset = $args->{START} - 1; + + return unless $self->_check_fetch( $resultset, $args, $offset, $args->{NUMBER} ); + + # Ignore if request is only for one record; our own prefetching will probably do a better job. + $self->_prefetch_records( $resultset, $args, $offset, $args->{NUMBER} ) if ( $args->{NUMBER} > 1 ); +} + +sub fetch_handler { + # Called when a given record is requested. + my ( $self, $args ) = @_; + my $session = $args->{HANDLE}; + my $server = $self->{server}; + + $self->_log_debug("received fetch for $args->{SETNAME}, record $args->{OFFSET}"); + my $form_oid = $args->{REQ_FORM} // ''; + my $composition = $args->{COMP} // ''; + $self->_log_debug(" form OID $form_oid, composition $composition"); + + my $resultset = $session->{resultsets}->{ $args->{SETNAME} }; + # The offset comes across 1-indexed. + my $offset = $args->{OFFSET} - 1; + + return unless $self->_check_fetch( $resultset, $args, $offset, 1 ); + + $args->{LAST} = 1 if ( $offset == $resultset->{hits} - 1 ); + + my $record = $self->_fetch_record( $resultset, $args, $offset, $server->{num_to_prefetch} ); + return unless $record; + + $record = C4::Search::new_record_from_zebra( + $resultset->{database} eq 'biblios' ? 'biblioserver' : 'authorityserver', + $record + ); + + if ( $server->{add_item_status_subfield} ) { + my $tag = $server->{item_tag}; + + foreach my $field ( $record->field($tag) ) { + $self->add_item_status( $field ); + } + } + + if ( $form_oid eq MARCXML_OID && $composition eq 'marcxml' ) { + $args->{RECORD} = $record->as_xml_record(); + } elsif ( ( $form_oid eq USMARC_OID || $form_oid eq UNIMARC_OID ) && ( !$composition || $composition eq 'F' ) ) { + $args->{RECORD} = $record->as_usmarc(); + } else { + $self->_set_error( $args, ERR_SYNTAX_UNSUPPORTED, "Unsupported syntax/composition $form_oid/$composition" ); + return; + } +} + +sub add_item_status { + my ( $self, $field ) = @_; + + my $server = $self->{server}; + + my $itemnumber_subfield = $server->{itemnumber_subfield}; + my $add_subfield = $server->{add_item_status_subfield}; + my $status_strings = $server->{status_strings}; + + my $itemnumber = $field->subfield($itemnumber_subfield); + next unless $itemnumber; + + my $item = GetItem( $itemnumber ); + return unless $item; + + my @statuses; + + if ( $item->{onloan} ) { + push @statuses, $status_strings->{CHECKED_OUT}; + } + + if ( $item->{itemlost} ) { + push @statuses, $status_strings->{LOST}; + } + + if ( $item->{notforloan} ) { + push @statuses, $status_strings->{NOT_FOR_LOAN}; + } + + if ( $item->{damaged} ) { + push @statuses, $status_strings->{DAMAGED}; + } + + if ( $item->{withdrawn} ) { + push @statuses, $status_strings->{WITHDRAWN}; + } + + if ( scalar( GetTransfers( $itemnumber ) ) ) { + push @statuses, $status_strings->{IN_TRANSIT}; + } + + if ( GetReserveStatus( $itemnumber ) ne '' ) { + push @statuses, $status_strings->{ON_HOLD}; + } + + $field->delete_subfield( code => $itemnumber_subfield ); + + if ( $server->{add_status_multi_subfield} ) { + $field->add_subfields( map { ( $add_subfield, $_ ) } ( @statuses ? @statuses : $status_strings->{AVAILABLE} ) ); + } else { + $field->add_subfields( $add_subfield, @statuses ? join( ', ', @statuses ) : $status_strings->{AVAILABLE} ); + } +} + +sub close_handler { + my ( $self, $args ) = @_; + + foreach my $resultset ( values %{ $self->{resultsets} } ) { + $resultset->{results}->destroy(); + } +} + +1; diff --git a/etc/log4perl.conf b/etc/log4perl.conf index efc470746a..48601fb116 100644 --- a/etc/log4perl.conf +++ b/etc/log4perl.conf @@ -11,3 +11,10 @@ log4perl.appender.OPAC.filename=__LOG_DIR__/opac-error.log log4perl.appender.OPAC.mode=append log4perl.appender.OPAC.layout=PatternLayout log4perl.appender.OPAC.layout.ConversionPattern=[%d] [%p] %m %l %n + +log4perl.logger.z3950 = WARN, Z3950 +log4perl.appender.Z3950=Log::Log4perl::Appender::File +log4perl.appender.Z3950.filename=__LOG_DIR__/logs/z3950-error.log +log4perl.appender.Z3950.mode=append +log4perl.appender.Z3950.layout=PatternLayout +log4perl.appender.Z3950.layout.ConversionPattern=[%d] [%p] %m %l %n diff --git a/misc/z3950_responder.pl b/misc/z3950_responder.pl new file mode 100755 index 0000000000..e1056c5a7f --- /dev/null +++ b/misc/z3950_responder.pl @@ -0,0 +1,153 @@ +#!/usr/bin/perl +# +# Copyright ByWater Solutions 2015 +# +# This file is part of Koha. +# +# Koha is free software; you can redistribute it and/or modify it under the +# terms of the GNU General Public License as published by the Free Software +# Foundation; either version 3 of the License, or (at your option) any later +# version. +# +# Koha is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR +# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with Koha; if not, write to the Free Software Foundation, Inc., +# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +use Modern::Perl; + +use Carp; +use Getopt::Long; +use Pod::Usage; + +use C4::Context; +use Koha::Z3950Responder; + +=head1 SYNOPSIS + + z3950_responder.pl [-h|--help] [--man] [-a ] [-v ] [-l ] [-u ] + [-c ] [-t ] [-k ] [-d ] [-p ] + [-C certfile] [-zKiDST1] [-m ] [-w ] [--debug] + [--add-item-status=SUBFIELD] [--prefetch=NUM_RECORDS] + [... ] + +=head1 OPTIONS + +=over 8 + +=item B<--help> + +Prints a brief usage message and exits. + +=item B<--man> + +Displays manual page and exits. + +=item B<--debug> + +Turns on debug logging to the screen, and turns on single-process mode. + +=item B<--add-item-status=SUBFIELD> + +If given, adds item status information to the given subfield. + +=item B<--add-status-multi-subfield> + +With the above, instead of putting multiple item statuses in one subfield, adds a subfield for each +status string. + +=item B<--prefetch=NUM_RECORDS> + +Number of records to prefetch from Zebra. Defaults to 20. + +=back + +=head1 CONFIGURATION + +The item status strings added by B<--add-item-status> can be configured with the B +authorized value, using the following keys: + +=over 4 + +=item AVAILABLE + +=item CHECKED_OUT + +=item LOST + +=item NOT_FOR_LOAN + +=item DAMAGED + +=item WITHDRAWN + +=item IN_TRANSIT + +=item ON_HOLD + +=back + +=cut + +my $add_item_status_subfield; +my $add_status_multi_subfield; +my $debug = 0; +my $help; +my $man; +my $prefetch = 20; +my @yaz_options; + +sub add_yaz_option { + my ( $opt_name, $opt_value ) = @_; + + push @yaz_options, "-$opt_name", "$opt_value"; +} + +GetOptions( + '-h|help' => \$help, + '--man' => \$man, + '--debug' => \$debug, + '--add-item-status=s' => \$add_item_status_subfield, + '--add-status-multi-subfield' => \$add_status_multi_subfield, + '--prefetch=i' => \$prefetch, + # Pass through YAZ options. + 'a=s' => \&add_yaz_option, + 'v=s' => \&add_yaz_option, + 'l=s' => \&add_yaz_option, + 'u=s' => \&add_yaz_option, + 'c=s' => \&add_yaz_option, + 't=s' => \&add_yaz_option, + 'k=s' => \&add_yaz_option, + 'd=s' => \&add_yaz_option, + 'p=s' => \&add_yaz_option, + 'C=s' => \&add_yaz_option, + 'm=s' => \&add_yaz_option, + 'w=s' => \&add_yaz_option, + 'z' => \&add_yaz_option, + 'K' => \&add_yaz_option, + 'i' => \&add_yaz_option, + 'D' => \&add_yaz_option, + 'S' => \&add_yaz_option, + 'T' => \&add_yaz_option, + '1' => \&add_yaz_option +) || pod2usage(2); + +pod2usage(1) if $help; +pod2usage( -verbose => 2 ) if $man; + +# Create and start the server. + +die "This tool only works with Zebra" if C4::Context->preference('SearchEngine') ne 'Zebra'; + +my $z = Koha::Z3950Responder->new( { + add_item_status_subfield => $add_item_status_subfield, + add_status_multi_subfield => $add_status_multi_subfield, + debug => $debug, + num_to_prefetch => $prefetch, + yaz_options => [ @yaz_options, @ARGV ], +} ); + +$z->start(); -- 2.39.5