Koha/Z3950Responder/Session.pm

   1 #!/usr/bin/perl
   2
   3 package Koha::Z3950Responder::Session;
   4
   5 # Copyright ByWater Solutions 2016
   6 #
   7 # This file is part of Koha.
   8 #
   9 # Koha is free software; you can redistribute it and/or modify it
  10 # under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 3 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # Koha is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  21
  22 use Modern::Perl;
  23
  24 use C4::Circulation qw( GetTransfers );
  25 use C4::Context;
  26 use C4::Reserves qw( GetReserveStatus );
  27 use C4::Search qw();
  28
  29 use Koha::Items;
  30 use Koha::Logger;
  31
  32 =head1 NAME
  33
  34 Koha::Z3950Responder::Session
  35
  36 =head1 SYNOPSIS
  37
  38 An abstract class where backend-specific session modules are derived from.
  39 Z3950Responder creates one of the child classes depending on the SearchEngine
  40 preference.
  41
  42 =head1 DESCRIPTION
  43
  44 This class contains common functions for handling searching for and fetching
  45 of records. It can optionally add item status information to the returned
  46 records. The backend-specific abstract methods need to be implemented in a
  47 child class.
  48
  49 =head2 CONSTANTS
  50
  51 OIDs and diagnostic codes used in Z39.50
  52
  53 =cut
  54
  55 use constant {
  56     UNIMARC_OID => '1.2.840.10003.5.1',
  57     USMARC_OID => '1.2.840.10003.5.10',
  58     MARCXML_OID => '1.2.840.10003.5.109.10'
  59 };
  60
  61 use constant {
  62     ERR_TEMPORARY_ERROR => 2,
  63     ERR_PRESENT_OUT_OF_RANGE => 13,
  64     ERR_RECORD_TOO_LARGE => 16,
  65     ERR_NO_SUCH_RESULTSET => 30,
  66     ERR_SEARCH_FAILED => 125,
  67     ERR_SYNTAX_UNSUPPORTED => 239,
  68     ERR_DB_DOES_NOT_EXIST => 235,
  69 };
  70
  71 =head1 FUNCTIONS
  72
  73 =head2 INSTANCE METHODS
  74
  75 =head3 new
  76
  77     my $session = $self->new({
  78         server => $z3950responder,
  79         peer => 'PEER NAME'
  80     });
  81
  82 Instantiate a Session
  83
  84 =cut
  85
  86 sub new {
  87     my ( $class, $args ) = @_;
  88
  89     my $self = bless( {
  90         %$args,
  91         logger => Koha::Logger->get({ interface => 'z3950' }),
  92         resultsets => {},
  93     }, $class );
  94
  95     if ( $self->{server}->{debug} ) {
  96         $self->{logger}->debug_to_screen();
  97     }
  98
  99     $self->log_info('connected');
 100
 101     return $self;
 102 }
 103
 104 =head3 search_handler
 105
 106     Callback that is called when a new search is performed
 107
 108 Calls C<start_search> for backend-specific retrieval logic
 109
 110 =cut
 111
 112 sub search_handler {
 113     my ( $self, $args ) = @_;
 114
 115     my $database = $args->{DATABASES}->[0];
 116
 117     if ( $database ne $Koha::SearchEngine::BIBLIOS_INDEX && $database ne $Koha::SearchEngine::AUTHORITIES_INDEX ) {
 118         $self->set_error( $args, $self->ERR_DB_DOES_NOT_EXIST, 'No such database' );
 119         return;
 120     }
 121
 122     my $query = $args->{QUERY};
 123     $self->log_info("received search for '$query', (RS $args->{SETNAME})");
 124
 125     my ($resultset, $hits) = $self->start_search( $args, $self->{server}->{num_to_prefetch} );
 126     return unless $resultset;
 127
 128     $args->{HITS} = $hits;
 129     $self->{resultsets}->{ $args->{SETNAME} } = $resultset;
 130 }
 131
 132 =head3 fetch_handler
 133
 134     Callback that is called when records are requested
 135
 136 Calls C<fetch_record> for backend-specific retrieval logic
 137
 138 =cut
 139
 140 sub fetch_handler {
 141     my ( $self, $args ) = @_;
 142
 143     $self->log_debug("received fetch for RS $args->{SETNAME}, record $args->{OFFSET}");
 144
 145     my $server = $self->{server};
 146
 147     my $form_oid = $args->{REQ_FORM} // '';
 148     my $composition = $args->{COMP} // '';
 149     $self->log_debug("    form OID '$form_oid', composition '$composition'");
 150
 151     my $resultset = $self->{resultsets}->{ $args->{SETNAME} };
 152     # The offset comes across 1-indexed.
 153     my $offset = $args->{OFFSET} - 1;
 154
 155     return unless $self->check_fetch( $resultset, $args, $offset, 1 );
 156
 157     $args->{LAST} = 1 if ( $offset == $resultset->{hits} - 1 );
 158
 159     my $record = $self->fetch_record( $resultset, $args, $offset, $server->{num_to_prefetch} );
 160     return unless $record;
 161
 162     # Note that new_record_from_zebra is badly named and works also with Elasticsearch
 163     $record = C4::Search::new_record_from_zebra(
 164         $resultset->{database} eq 'biblios' ? 'biblioserver' : 'authorityserver',
 165         $record
 166     );
 167
 168     if ( $server->{add_item_status_subfield} ) {
 169         my $tag = $server->{item_tag};
 170
 171         foreach my $field ( $record->field($tag) ) {
 172             $self->add_item_status( $field );
 173         }
 174     }
 175
 176     if ( $form_oid eq $self->MARCXML_OID && $composition eq 'marcxml' ) {
 177         $args->{RECORD} = $record->as_xml_record();
 178     } elsif ( ( $form_oid eq $self->USMARC_OID || $form_oid eq $self->UNIMARC_OID ) && ( !$composition || $composition eq 'F' ) ) {
 179         $args->{RECORD} = $record->as_usmarc();
 180     } else {
 181         $self->set_error( $args, $self->ERR_SYNTAX_UNSUPPORTED, "Unsupported syntax/composition $form_oid/$composition" );
 182         return;
 183     }
 184 }
 185
 186 =head3 close_handler
 187
 188 Callback that is called when a session is terminated
 189
 190 =cut
 191
 192 sub close_handler {
 193     my ( $self, $args ) = @_;
 194
 195     # Override in a child class to add functionality
 196 }
 197
 198 =head3 start_search
 199
 200     my ($resultset, $hits) = $self->_start_search( $args, $self->{server}->{num_to_prefetch} );
 201
 202 A backend-specific method for starting a new search
 203
 204 =cut
 205
 206 sub start_search {
 207     die('Abstract method');
 208 }
 209
 210 =head3 check_fetch
 211
 212     $self->check_fetch($resultset, $args, $offset, $num_records);
 213
 214 Check that the fetch request parameters are within bounds of the result set.
 215
 216 =cut
 217
 218 sub check_fetch {
 219     my ( $self, $resultset, $args, $offset, $num_records ) = @_;
 220
 221     if ( !defined( $resultset ) ) {
 222         $self->set_error( $args, ERR_NO_SUCH_RESULTSET, 'No such resultset' );
 223         return 0;
 224     }
 225
 226     if ( $offset < 0 || $offset + $num_records > $resultset->{hits} )  {
 227         $self->set_error( $args, ERR_PRESENT_OUT_OF_RANGE, 'Present request out of range' );
 228         return 0;
 229     }
 230
 231     return 1;
 232 }
 233
 234 =head3 fetch_record
 235
 236     my $record = $self->_fetch_record( $resultset, $args, $offset, $server->{num_to_prefetch} );
 237
 238 A backend-specific method for fetching a record
 239
 240 =cut
 241
 242 sub fetch_record {
 243     die('Abstract method');
 244 }
 245
 246 =head3 add_item_status
 247
 248     $self->add_item_status( $field );
 249
 250 Add item status to the given field
 251
 252 =cut
 253
 254 sub add_item_status {
 255     my ( $self, $field ) = @_;
 256
 257     my $server = $self->{server};
 258
 259     my $itemnumber_subfield = $server->{itemnumber_subfield};
 260     my $add_subfield = $server->{add_item_status_subfield};
 261     my $status_strings = $server->{status_strings};
 262
 263     my $itemnumber = $field->subfield($itemnumber_subfield);
 264     next unless $itemnumber;
 265
 266     my $item = Koha::Items->find( $itemnumber );
 267     return unless $item;
 268
 269     my @statuses;
 270
 271     if ( $item->onloan() ) {
 272         push @statuses, $status_strings->{CHECKED_OUT};
 273     }
 274
 275     if ( $item->itemlost() ) {
 276         push @statuses, $status_strings->{LOST};
 277     }
 278
 279     if ( $item->notforloan() ) {
 280         push @statuses, $status_strings->{NOT_FOR_LOAN};
 281     }
 282
 283     if ( $item->damaged() ) {
 284         push @statuses, $status_strings->{DAMAGED};
 285     }
 286
 287     if ( $item->withdrawn() ) {
 288         push @statuses, $status_strings->{WITHDRAWN};
 289     }
 290
 291     if ( scalar( GetTransfers( $itemnumber ) ) ) {
 292         push @statuses, $status_strings->{IN_TRANSIT};
 293     }
 294
 295     if ( GetReserveStatus( $itemnumber ) ne '' ) {
 296         push @statuses, $status_strings->{ON_HOLD};
 297     }
 298
 299     $field->delete_subfield( code => $itemnumber_subfield );
 300
 301     if ( $server->{add_status_multi_subfield} ) {
 302         $field->add_subfields( map { ( $add_subfield, $_ ) } ( @statuses ? @statuses : $status_strings->{AVAILABLE} ) );
 303     } else {
 304         $field->add_subfields( $add_subfield, @statuses ? join( ', ', @statuses ) : $status_strings->{AVAILABLE} );
 305     }
 306 }
 307
 308
 309 =head3 log_debug
 310
 311     $self->log_debug('Message');
 312
 313 Output a debug message
 314
 315 =cut
 316
 317 sub log_debug {
 318     my ( $self, $msg ) = @_;
 319     $self->{logger}->debug("[$self->{peer}] $msg");
 320 }
 321
 322 =head3 log_info
 323
 324     $self->log_info('Message');
 325
 326 Output an info message
 327
 328 =cut
 329
 330 sub log_info {
 331     my ( $self, $msg ) = @_;
 332     $self->{logger}->info("[$self->{peer}] $msg");
 333 }
 334
 335 =head3 log_error
 336
 337     $self->log_error('Message');
 338
 339 Output an error message
 340
 341 =cut
 342
 343 sub log_error {
 344     my ( $self, $msg ) = @_;
 345     $self->{logger}->error("[$self->{peer}] $msg");
 346 }
 347
 348 =head3 set_error
 349
 350     $self->set_error($args, $self->ERR_SEARCH_FAILED, 'Backend connection failed' );
 351
 352 Set and log an error code and diagnostic message to be returned to the client
 353
 354 =cut
 355
 356 sub set_error {
 357     my ( $self, $args, $code, $msg ) = @_;
 358
 359     ( $args->{ERR_CODE}, $args->{ERR_STR} ) = ( $code, $msg );
 360
 361     $self->log_error("    returning error $code: $msg");
 362 }
 363
 364 1;