Open-ILS/src/perlmods/lib/OpenILS/Application/Search/Z3950.pm

   1 package OpenILS::Application::Search::Z3950;
   2 use strict; use warnings;
   3 use base qw/OpenILS::Application/;
   4
   5 use OpenILS::Utils::ZClient;
   6 use MARC::Record;
   7 use MARC::File::XML (BinaryEncoding => 'UTF-8');
   8 use MARC::Charset;
   9 use Unicode::Normalize;
  10 use XML::LibXML;
  11
  12 use OpenILS::Event;
  13 use OpenSRF::EX qw(:try);
  14 use OpenILS::Utils::ModsParser;
  15 use OpenSRF::Utils::SettingsClient;
  16 use OpenILS::Application::AppUtils;
  17 use OpenSRF::Utils::Logger qw/$logger/;
  18 use OpenILS::Utils::CStoreEditor q/:funcs/;
  19
  20 MARC::Charset->assume_unicode(1);
  21 MARC::Charset->ignore_errors(1);
  22
  23 my $output = "usmarc";
  24 my $U = 'OpenILS::Application::AppUtils';
  25
  26 my $sclient;
  27 my %services;
  28 my $default_service;
  29
  30 __PACKAGE__->register_method(
  31     method    => 'apply_credentials',
  32     api_name  => 'open-ils.search.z3950.apply_credentials',
  33     signature => {
  34         desc   => "Apply credentials for a Z39.50 server",
  35         params => [
  36             {desc => 'Authtoken', type => 'string'},
  37             {desc => 'Z39.50 Source (server) name', type => 'string'},
  38             {desc => 'Context org unit', type => 'number'},
  39             {desc => 'Username', type => 'string'},
  40             {desc => 'Password', type => 'string'}
  41         ],
  42         return => {
  43             desc => 'Event; SUCCESS on success, other event type on error'
  44         }
  45     }
  46 );
  47
  48 sub apply_credentials {
  49     my ($self, $client, $auth, $source, $ctx_ou, $username, $password) = @_;
  50
  51     my $e = new_editor(authtoken => $auth, xact => 1);
  52
  53     return $e->die_event unless
  54         $e->checkauth and
  55         $e->allowed('ADMIN_Z3950_SOURCE', $ctx_ou);
  56
  57     $e->json_query({from => [
  58         'config.z3950_source_credentials_apply',
  59         $source, $ctx_ou, $username, $password
  60     ]}) or return $e->die_event;
  61
  62     $e->commit;
  63
  64     return OpenILS::Event->new('SUCCESS');
  65 }
  66
  67
  68
  69 __PACKAGE__->register_method(
  70     method    => 'do_class_search',
  71     api_name  => 'open-ils.search.z3950.search_class',
  72     stream    => 1,
  73     signature => q/
  74         Performs a class based Z search.  The classes available
  75         are defined by the 'attr' fields in the config for the
  76         requested service.
  77         @param auth The login session key
  78         @param shash The search hash : { attr : value, attr2: value, ...}
  79         @param service The service to connect to
  80         @param username The username to use when connecting to the service
  81         @param password The password to use when connecting to the service
  82     /
  83 );
  84
  85 __PACKAGE__->register_method(
  86     method    => 'do_service_search',
  87     api_name  => 'open-ils.search.z3950.search_service',
  88     signature => q/
  89         @param auth The login session key
  90         @param query The Z3950 search string to use
  91         @param service The service to connect to
  92         @param username The username to use when connecting to the service
  93         @param password The password to use when connecting to the service
  94     /
  95 );
  96
  97
  98 __PACKAGE__->register_method(
  99     method    => 'do_service_search',
 100     api_name  => 'open-ils.search.z3950.search_raw',
 101     signature => q/
 102         @param auth The login session key
 103         @param args An object of search params which must include:
 104             host, port, db and query.
 105             optional fields include username and password
 106     /
 107 );
 108
 109
 110 __PACKAGE__->register_method(
 111     method    => "query_services",
 112     api_name  => "open-ils.search.z3950.retrieve_services",
 113     signature => q/
 114         @param auth The login session key
 115         Returns a list of service names that we have config
 116         data for
 117     /
 118 );
 119
 120
 121
 122 # -------------------------------------------------------------------
 123 # What services do we have config info for?
 124 # -------------------------------------------------------------------
 125 sub query_services {
 126     my( $self, $client, $auth ) = @_;
 127     my $e = new_editor(authtoken=>$auth);
 128     return $e->event unless $e->checkauth;
 129     return $e->event unless $e->allowed('REMOTE_Z3950_QUERY');
 130
 131     return fetch_service_defs($e);
 132 }
 133
 134 # -------------------------------------------------------------------
 135 # What services do we have config info for?
 136 # -------------------------------------------------------------------
 137 sub fetch_service_defs {
 138
 139     my $editor_with_authtoken = shift;
 140
 141     my $hash = $sclient->config_value('z3950', 'services');
 142
 143     # overlay config file values with in-db values
 144     my $e = $editor_with_authtoken || new_editor();
 145     if($e->can('search_config_z3950_source')) {
 146
 147         my $sources = $e->search_config_z3950_source(
 148             [ { name => { '!=' => undef } },
 149               { flesh => 1, flesh_fields => { czs => ['attrs'] } } ]
 150         );
 151
 152         for my $s ( @$sources ) {
 153             $$hash{ $s->name } = {
 154                 name => $s->name,
 155                 label => $s->label,
 156                 host => $s->host,
 157                 port => $s->port,
 158                 db => $s->db,
 159                 record_format => $s->record_format,
 160                 transmission_format => $s->transmission_format,
 161                 auth => $s->auth,
 162                 use_perm => ($s->use_perm) ?
 163                     $e->retrieve_permission_perm_list($s->use_perm)->code : ''
 164             };
 165
 166             for my $a ( @{ $s->attrs } ) {
 167                 $$hash{ $a->source }{attrs}{ $a->name } = {
 168                     name => $a->name,
 169                     label => $a->label,
 170                     code => $a->code,
 171                     format => $a->format,
 172                     source => $a->source,
 173                     truncation => $a->truncation,
 174                 };
 175             }
 176         }
 177     }
 178
 179     # Define the set of native catalog services
 180     # XXX There are i18n problems here, but let's get the staff client working first
 181     # XXX Move into the DB?
 182     $hash->{'native-evergreen-catalog'} = {
 183         attrs => {
 184             title => {code => 'title', label => 'Title'},
 185             author => {code => 'author', label => 'Author'},
 186             subject => {code => 'subject', label => 'Subject'},
 187             keyword => {code => 'keyword', label => 'Keyword'},
 188             tcn => {code => 'tcn', label => 'TCN'},
 189             isbn => {code => 'isbn', label => 'ISBN'},
 190             issn => {code => 'issn', label => 'ISSN'},
 191             publisher => {code => 'publisher', label => 'Publisher'},
 192             pubdate => {code => 'pubdate', label => 'Pub Date'},
 193             item_type => {code => 'item_type', label => 'Item Type'},
 194         }
 195     };
 196
 197     # then filter out any services which the requestor lacks the perm for
 198     if ($editor_with_authtoken) {
 199         foreach my $s (keys %{ $hash }) {
 200             if ($$hash{$s}{use_perm}) {
 201                 if ($U->check_perms(
 202                     $e->requestor->id,
 203                     $e->requestor->ws_ou,
 204                     $$hash{$s}{use_perm}
 205                 )) {
 206                     delete $$hash{$s};
 207                 }
 208             };
 209         }
 210     }
 211
 212     %services = %$hash; # cache these internally so we can actually use the db-configured sources
 213     return $hash;
 214 }
 215
 216
 217
 218 # -------------------------------------------------------------------
 219 # Load the pre-defined Z server configs
 220 # -------------------------------------------------------------------
 221 sub child_init {
 222     $sclient = OpenSRF::Utils::SettingsClient->new();
 223     $default_service = $sclient->config_value("z3950", "default" );
 224 }
 225
 226
 227 # -------------------------------------------------------------------
 228 # High-level class based search.
 229 # -------------------------------------------------------------------
 230 sub do_class_search {
 231
 232     fetch_service_defs() unless (scalar(keys(%services)));
 233
 234     my $self = shift;
 235     my $conn = shift;
 236     my $auth = shift;
 237     my $args = shift;
 238
 239     if (!ref($$args{service})) {
 240         $$args{service} = [$$args{service}];
 241         $$args{username} = [$$args{username}];
 242         $$args{password} = [$$args{password}];
 243     }
 244
 245     $$args{async} = 1;
 246
 247     my @connections;
 248     my @results;
 249     my @services;
 250     for (my $i = 0; $i < @{$$args{service}}; $i++) {
 251         my %tmp_args = %$args;
 252         $tmp_args{service} = $$args{service}[$i];
 253         $tmp_args{username} = $$args{username}[$i];
 254         $tmp_args{password} = $$args{password}[$i];
 255
 256         $logger->debug("z3950: service: $tmp_args{service}, async: $tmp_args{async}");
 257
 258         if ($tmp_args{service} eq 'native-evergreen-catalog') {
 259             my $method = $self->method_lookup('open-ils.search.biblio.zstyle.staff');
 260             $conn->respond(
 261                 $self->method_lookup('open-ils.search.biblio.zstyle.staff')->run($auth, \%tmp_args)
 262             );
 263
 264         } else {
 265
 266             $tmp_args{query} = compile_query('and', $tmp_args{service}, $tmp_args{search});
 267
 268             my $res = do_service_search( $self, $conn, $auth, \%tmp_args );
 269
 270             if ($U->event_code($res)) {
 271                 $conn->respond($res) if $U->event_code($res);
 272
 273             } else {
 274                 push @services, $tmp_args{service};
 275                 push @results, $res->{result};
 276                 push @connections, $res->{connection};
 277             }
 278         }
 279
 280         $logger->debug("z3950: Result object: $results[$i], Connection object: $connections[$i]");
 281     }
 282
 283     $logger->debug("z3950: Connections created");
 284
 285     return undef unless (@connections);
 286     my @records;
 287
 288     # local catalog search is not processed with other z39 results;
 289     $$args{service} = [grep {$_ ne 'native-evergreen-catalog'} @{$$args{service}}];
 290
 291     @connections = grep {defined $_} @connections;
 292     return undef unless @connections;
 293
 294     while ((my $index = OpenILS::Utils::ZClient::event( \@connections )) != 0) {
 295         my $ev = $connections[$index - 1]->last_event();
 296         $logger->debug("z3950: Received event $ev");
 297         if ($ev == OpenILS::Utils::ZClient::EVENT_END()) {
 298             my $munged = process_results( $results[$index - 1], $$args{limit}, $$args{offset}, $$args{service}[$index -1] );
 299             $$munged{service} = $$args{service}[$index - 1];
 300             $conn->respond($munged);
 301         }
 302     }
 303
 304     $logger->debug("z3950: Search Complete");
 305     return undef;
 306 }
 307
 308
 309 # -------------------------------------------------------------------
 310 # This handles the host settings, but expects a fully formed z query
 311 # -------------------------------------------------------------------
 312 sub do_service_search {
 313
 314     fetch_service_defs() unless (scalar(keys(%services)));
 315
 316     my $self = shift;
 317     my $conn = shift;
 318     my $auth = shift;
 319     my $args = shift;
 320
 321     my $info = $services{$$args{service}};
 322
 323     $$args{host} = $$info{host};
 324     $$args{port} = $$info{port};
 325     $$args{db} = $$info{db};
 326     $logger->debug("z3950: do_search...");
 327
 328     return do_search( $self, $conn, $auth, $args );
 329 }
 330
 331
 332
 333 # -------------------------------------------------------------------
 334 # This is the low level search method.  All config and query
 335 # data must be provided to this method
 336 # -------------------------------------------------------------------
 337 sub do_search {
 338
 339     fetch_service_defs() unless (scalar(keys(%services)));
 340
 341     my $self = shift;
 342     my $conn = shift;
 343     my $auth = shift;
 344     my $args = shift;
 345
 346     my $host = $$args{host} or return undef;
 347     my $port = $$args{port} or return undef;
 348     my $db = $$args{db} or return undef;
 349     my $query = $$args{query} or return undef;
 350     my $async = $$args{async} || 0;
 351
 352     my $limit = $$args{limit} || 10;
 353     my $offset = $$args{offset} || 0;
 354
 355     my $editor = new_editor(authtoken => $auth);
 356     return $editor->event unless
 357         $editor->checkauth and
 358         $editor->allowed('REMOTE_Z3950_QUERY', $editor->requestor->ws_ou);
 359
 360     my $creds = $editor->json_query({from => [
 361         'config.z3950_source_credentials_lookup',
 362         $$args{service}, $editor->requestor->ws_ou
 363     ]})->[0] || {};
 364
 365     # use the caller-provided username/password if offered.
 366     # otherwise, use the stored credentials.
 367     my $username = $$args{username} || $creds->{username} || "";
 368     my $password = $$args{password} || $creds->{password} || "";
 369
 370     my $tformat = $services{$args->{service}}->{transmission_format} || $output;
 371
 372     $logger->info("z3950: connecting to server $host:$port:$db as $username");
 373
 374     my $connection = OpenILS::Utils::ZClient->new(
 375         $host, $port,
 376         databaseName => $db,
 377         user => $username,
 378         password => $password,
 379         async => $async,
 380         preferredRecordSyntax => $tformat,
 381     );
 382
 383     if( ! $connection ) {
 384         $logger->error("z3950: Unable to connect to Z server: ".
 385             "$host:$port:$db:$username:$password");
 386         return OpenILS::Event->new('Z3950_LOGIN_FAILED') unless $connection;
 387     }
 388
 389     my $start = time;
 390     my $results;
 391     my $err;
 392
 393     $logger->info("z3950: query => $query");
 394
 395     try {
 396         $results = $connection->search_pqf( $query );
 397     } catch Error with { $err = shift; };
 398
 399     return OpenILS::Event->new(
 400         'Z3950_BAD_QUERY', payload => $query, debug => "$err") if $err;
 401
 402     return OpenILS::Event->new('Z3950_SEARCH_FAILED',
 403         debug => $connection->errcode." => ".$connection->errmsg." : query = $query") unless $results;
 404
 405     $logger->info("z3950: search [$query] took ".(time - $start)." seconds");
 406
 407     return {result => $results, connection => $connection} if ($async);
 408
 409     my $munged = process_results($results, $limit, $offset, $$args{service});
 410     $munged->{query} = $query;
 411
 412     return $munged;
 413 }
 414
 415
 416 # -------------------------------------------------------------------
 417 # Takes a result batch and returns the hitcount and a list of xml
 418 # and mvr objects
 419 # -------------------------------------------------------------------
 420 sub process_results {
 421
 422     fetch_service_defs() unless (scalar(keys(%services)));
 423
 424     my $results = shift;
 425     my $limit = shift || 10;
 426     my $offset = shift || 0;
 427     my $service = shift;
 428
 429     my $rformat = $services{$service}->{record_format};
 430     my $tformat = $services{$service}->{transmission_format} || $output;
 431
 432     $results->option(elementSetName => $rformat);
 433     $results->option(preferredRecordSyntax => $tformat);
 434     $logger->info("z3950: using record format '$rformat' and transmission format '$tformat'");
 435
 436     my @records;
 437     my $res = {};
 438     my $count = $$res{count} = $results->size;
 439
 440     $logger->info("z3950: search returned $count hits");
 441
 442     my $tend = $limit + $offset;
 443
 444     my $end = ($tend <= $count) ? $tend : $count;
 445
 446     for($offset..$end - 1) {
 447
 448         my $err;
 449         my $mods;
 450         my $marc;
 451         my $marcs;
 452         my $marcxml;
 453
 454         $logger->info("z3950: fetching record $_");
 455
 456         try {
 457
 458             my $rec = $results->record($_);
 459
 460             if ($tformat eq 'usmarc') {
 461                 $marc = MARC::Record->new_from_usmarc($rec->raw());
 462             } elsif ($tformat eq 'xml') {
 463                 $marc = MARC::Record->new_from_xml($rec->raw());
 464             } else {
 465                 die "Unsupported record transmission format $tformat"
 466             }
 467
 468             $marcs = $U->entityize($marc->as_xml_record);
 469             $marcs = $U->strip_ctrl_chars($marcs);
 470             my $doc = XML::LibXML->new->parse_string($marcs);
 471             $marcxml = $U->entityize($doc->documentElement->toString);
 472             $marcxml = $U->strip_ctrl_chars($marcxml);
 473
 474             my $u = OpenILS::Utils::ModsParser->new();
 475             $u->start_mods_batch( $marcxml );
 476             $mods = $u->finish_mods_batch();
 477
 478
 479         } catch Error with { $err = shift; };
 480
 481         push @records, { 'mvr' => $mods, 'marcxml' => $marcxml } unless $err;
 482         $logger->error("z3950: bad XML : $err") if $err;
 483
 484         if( $err ) {
 485             warn "\n\n$marcs\n\n";
 486         }
 487     }
 488
 489     $res->{records} = \@records;
 490     return $res;
 491 }
 492
 493
 494
 495 # -------------------------------------------------------------------
 496 # Compiles the class based search query
 497 # -------------------------------------------------------------------
 498 sub compile_query {
 499
 500     fetch_service_defs() unless (scalar(keys(%services)));
 501
 502     my $separator = shift;
 503     my $service = shift;
 504     my $hash = shift;
 505
 506     my $count = scalar(keys %$hash);
 507
 508     my $str = "";
 509     $str .= "\@$separator " for (1..$count-1);
 510
 511     # -------------------------------------------------------------------
 512     # "code" is the bib-1 "use attribute", "format" is the bib-1
 513     # "structure attribute"
 514     # -------------------------------------------------------------------
 515     for( keys %$hash ) {
 516         next unless ( exists $services{$service}->{attrs}->{$_} );
 517         $str .= '@attr 1=' . $services{$service}->{attrs}->{$_}->{code} . # add the use attribute
 518             ' @attr 4=' . $services{$service}->{attrs}->{$_}->{format}; # add the structure attribute
 519         if (exists $services{$service}->{attrs}->{$_}->{truncation}
 520                 && $services{$service}->{attrs}->{$_}->{truncation} >= 0) {
 521             $str .= ' @attr 5=' . $services{$service}->{attrs}->{$_}->{truncation};
 522         }
 523         $str .= " \"" . $$hash{$_} . "\" "; # add the search term
 524     }
 525     return $str;
 526 }
 527
 528 1;
 529 # vim:et:ts=4:sw=4: