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();