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

   1 package OpenILS::Application::Acq::Search;
   2 use base "OpenILS::Application";
   3
   4 use strict;
   5 use warnings;
   6
   7 use OpenSRF::AppSession;
   8 use OpenSRF::Utils::Logger qw/:logger/;
   9 use OpenILS::Event;
  10 use OpenILS::Utils::CStoreEditor q/:funcs/;
  11 use OpenILS::Utils::Fieldmapper;
  12 use OpenILS::Application::Acq::Lineitem;
  13 use OpenILS::Application::Acq::Financials;
  14 use OpenILS::Application::Acq::Picklist;
  15 use OpenILS::Application::Acq::Invoice;
  16 use OpenILS::Application::Acq::Order;
  17
  18 my %RETRIEVERS = (
  19     "lineitem" =>
  20         \&{"OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl"},
  21     "picklist" =>
  22         \&{"OpenILS::Application::Acq::Picklist::retrieve_picklist_impl"},
  23     "purchase_order" => \&{
  24         "OpenILS::Application::Acq::Financials::retrieve_purchase_order_impl"
  25     },
  26     "invoice" => \&{
  27         "OpenILS::Application::Acq::Invoice::fetch_invoice_impl"
  28     },
  29 );
  30
  31 sub F { $Fieldmapper::fieldmap->{"Fieldmapper::" . $_[0]}; }
  32
  33 # This subroutine returns 1 if the argument is a) a scalar OR
  34 # b) an array of ONLY scalars. Otherwise it returns 0.
  35 sub check_1d_max {
  36     my ($o) = @_;
  37     return 1 unless ref $o;
  38     if (ref($o) eq "ARRAY") {
  39         foreach (@$o) { return 0 if ref $_; }
  40         return 1;
  41     }
  42     0;
  43 }
  44
  45 # Returns 1 if and only if argument is an array of exactly two scalars.
  46 sub could_be_range {
  47     my ($o) = @_;
  48     if (ref $o eq "ARRAY") {
  49         return 1 if (scalar(@$o) == 2 && (!ref $o->[0] && !ref $o->[1]));
  50     }
  51     0;
  52 }
  53
  54 sub castdate {
  55     my ($value, $gte, $lte) = @_;
  56
  57     my $op = "=";
  58     $op = ">=" if $gte;
  59     $op = "<=" if $lte;
  60
  61     +{$op => {"transform" => "date", "value" => $value}};
  62 }
  63
  64 sub prepare_acqlia_search_and {
  65     my ($acqlia) = @_;
  66
  67     my @phrases = ();
  68     foreach my $unit (@{$acqlia}) {
  69         my $subquery = {
  70             "select" => {"acqlia" => ["id"]},
  71             "from" => "acqlia",
  72             "where" => {"-and" => [{"lineitem" => {"=" => {"+jub" => "id"}}}]}
  73         };
  74
  75         # castdate not supported for acqlia fields: they're all type text
  76         my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
  77         my $point = $subquery->{"where"}->{"-and"};
  78         my $term_clause;
  79
  80         push @$point, {"definition" => $k};
  81
  82         if ($fuzzy and not ref $v) {
  83             push @$point, {"attr_value" => {"ilike" => "%" . $v . "%"}};
  84         } elsif ($between and could_be_range($v)) {
  85             push @$point, {"attr_value" => {"between" => $v}};
  86         } elsif (check_1d_max($v)) {
  87             push @$point, {"attr_value" => $v};
  88         } else {
  89             next;
  90         }
  91
  92         my $operator = $not ? "-not-exists" : "-exists";
  93         push @phrases, {$operator => $subquery};
  94     }
  95     @phrases;
  96 }
  97
  98 sub prepare_acqlia_search_or {
  99     my ($acqlia) = @_;
 100
 101     my $point = [];
 102     my $result = {"+acqlia" => {"-or" => $point}};
 103
 104     foreach my $unit (@$acqlia) {
 105         # castdate not supported for acqlia fields: they're all type text
 106         my ($k, $v, $fuzzy, $between, $not) = breakdown_term($unit);
 107         my $term_clause;
 108         if ($fuzzy and not ref $v) {
 109             $term_clause = {
 110                 "-and" => {
 111                     "definition" => $k,
 112                     "attr_value" => {"ilike" => "%" . $v . "%"}
 113                 }
 114             };
 115         } elsif ($between and could_be_range($v)) {
 116             $term_clause = {
 117                 "-and" => {
 118                     "definition" => $k, "attr_value" => {"between" => $v}
 119                 }
 120             };
 121         } elsif (check_1d_max($v)) {
 122             $term_clause = {
 123                 "-and" => {"definition" => $k, "attr_value" => $v}
 124             };
 125         } else {
 126             next;
 127         }
 128
 129         push @$point, $not ? {"-not" => $term_clause} : $term_clause;
 130     }
 131     $result;
 132 }
 133
 134 sub breakdown_term {
 135     my ($term) = @_;
 136
 137     my $key = (grep { !/^__/ } keys %$term)[0];
 138     (
 139         $key, $term->{$key},
 140         $term->{"__fuzzy"} ? 1 : 0,
 141         $term->{"__between"} ? 1 : 0,
 142         $term->{"__not"} ? 1 : 0,
 143         $term->{"__castdate"} ? 1 : 0,
 144         $term->{"__gte"} ? 1 : 0,
 145         $term->{"__lte"} ? 1 : 0
 146     );
 147 }
 148
 149 sub get_fm_links_by_hint {
 150     my ($hint) = @_;
 151     foreach my $field (values %{$Fieldmapper::fieldmap}) {
 152         return $field->{"links"} if $field->{"hint"} eq $hint;
 153     }
 154     undef;
 155 }
 156
 157 sub gen_au_term {
 158     my ($value, $n) = @_;
 159     my $lc_value = {
 160         "=" => { transform => "lowercase", value => lc($value) }
 161     };
 162
 163     +{
 164         "-or" => [
 165             {"+au$n" => {"usrname" => $value}},
 166             {"+au$n" => {"first_given_name" => $lc_value}},
 167             {"+au$n" => {"second_given_name" => $lc_value}},
 168             {"+au$n" => {"family_name" => $lc_value}},
 169             {"+ac$n" => {"barcode" => $value}}
 170         ]
 171     };
 172 }
 173
 174 # go through the terms hash, find keys that correspond to fields links
 175 # to actor.usr, and rewrite the search as one that searches not by
 176 # actor.usr.id but by any of these user properties: card barcode, username,
 177 # given names and family name.
 178 sub prepare_au_terms {
 179     my ($terms, $join_num) = @_;
 180
 181     my @joins = ();
 182     my $nots = 0;
 183     $join_num ||= 0;
 184
 185     foreach my $conj (qw/-and -or/) {
 186         next unless exists $terms->{$conj};
 187
 188         my @new_outer_terms = ();
 189         HINT_UNIT: foreach my $hint_unit (@{$terms->{$conj}}) {
 190             my $hint = (keys %$hint_unit)[0];
 191             (my $plain_hint = $hint) =~ y/+//d;
 192             if ($hint eq "-not") {
 193                 $hint_unit = $hint_unit->{$hint};
 194                 $nots++;
 195                 redo HINT_UNIT;
 196             }
 197
 198             if (my $links = get_fm_links_by_hint($plain_hint) and
 199                 $plain_hint ne "acqlia") {
 200                 my @new_terms = ();
 201                 my ($attr, $value) = breakdown_term($hint_unit->{$hint});
 202                 if ($links->{$attr} and
 203                     $links->{$attr}->{"class"} eq "au") {
 204                     push @joins, [$plain_hint, $attr, $join_num];
 205                     my $au_term = gen_au_term($value, $join_num);
 206                     if ($nots > 0) {
 207                         $au_term = {"-not" => $au_term};
 208                         $nots--;
 209                     }
 210                     push @new_outer_terms, $au_term;
 211                     $join_num++;
 212                     delete $hint_unit->{$hint};
 213                 }
 214             }
 215             if ($nots > 0) {
 216                 $hint_unit = {"-not" => $hint_unit};
 217                 $nots--;
 218             }
 219             push @new_outer_terms, $hint_unit if scalar keys %$hint_unit;
 220         }
 221         $terms->{$conj} = [ @new_outer_terms ];
 222     }
 223     @joins;
 224 }
 225
 226 sub prepare_terms {
 227     my ($terms, $is_and) = @_;
 228
 229     my $conj = $is_and ? "-and" : "-or";
 230     my $outer_clause = {};
 231
 232     foreach my $class (qw/acqpo acqpl acqinv jub/) {
 233         next if not exists $terms->{$class};
 234
 235         $outer_clause->{$conj} = [] unless $outer_clause->{$conj};
 236         foreach my $unit (@{$terms->{$class}}) {
 237             my ($k, $v, $fuzzy, $between, $not, $castdate, $gte, $lte) =
 238                 breakdown_term($unit);
 239
 240             my $term_clause;
 241             if ($fuzzy and not ref $v) {
 242                 $term_clause = {$k => {"ilike" => "%" . $v . "%"}};
 243             } elsif ($between and could_be_range($v)) {
 244                 $term_clause = {$k => {"between" => $v}};
 245             } elsif (check_1d_max($v)) {
 246                 $v = castdate($v, $gte, $lte) if $castdate;
 247                 $term_clause = {$k => $v};
 248             } else {
 249                 next;
 250             }
 251
 252             my $clause = {"+" . $class => $term_clause};
 253             $clause = {"-not" => $clause} if $not;
 254             push @{$outer_clause->{$conj}}, $clause;
 255         }
 256     }
 257
 258     if ($terms->{"acqlia"}) {
 259         push @{$outer_clause->{$conj}},
 260             $is_and ? prepare_acqlia_search_and($terms->{"acqlia"}) :
 261                 prepare_acqlia_search_or($terms->{"acqlia"});
 262     }
 263
 264     return undef unless scalar keys %$outer_clause;
 265     $outer_clause;
 266 }
 267
 268 sub add_au_joins {
 269     my $graft_map = shift;
 270     my $core_hint = shift;
 271
 272     my $n = 0;
 273     foreach my $join (@_) {
 274         my ($hint, $attr, $num) = @$join;
 275         my $start = $graft_map->{$hint};
 276         my $clause = {
 277             "class" => "au",
 278             "type" => "left",
 279             "field" => "id",
 280             "fkey" => $attr,
 281             "join" => {
 282                 "ac$num" => {
 283                     "class" => "ac",
 284                     "type" => "left",
 285                     "field" => "id",
 286                     "fkey" => "card"
 287                 }
 288             }
 289         };
 290
 291         if ($hint eq $core_hint) {
 292             $start->{"au$num"} = $clause;
 293         } else {
 294             $start->{"join"} ||= {};
 295             $start->{"join"}->{"au$num"} = $clause;
 296         }
 297
 298         $n++;
 299     }
 300     $n;
 301 }
 302
 303 sub build_from_clause_and_joins {
 304     my ($query, $core, $and_terms, $or_terms) = @_;
 305
 306     my %graft_map = ();
 307
 308     $graft_map{$core} = $query->{from}{$core} = {};
 309
 310     my $join_type = keys(%$or_terms) ? "left" : "inner";
 311
 312     my @classes = grep { $core ne $_ } (keys(%$and_terms), keys(%$or_terms));
 313     my %classes_uniq = map { $_ => 1 } @classes;
 314     @classes = keys(%classes_uniq);
 315
 316     my $acqlia_join = sub {
 317         return {"type" => "left", "field" => "lineitem", "fkey" => "id"};
 318     };
 319
 320     foreach my $class (@classes) {
 321         if ($class eq 'acqlia') {
 322             if ($core eq 'acqinv') {
 323                 $graft_map{acqlia} =
 324                     $query->{from}{$core}{acqmapinv}{join}{jub}{join}{acqlia} =
 325                     $acqlia_join->();
 326             } elsif ($core eq 'jub') {
 327                 $graft_map{acqlia} =
 328                     $query->{from}{$core}{acqlia} =
 329                     $acqlia_join->();
 330             } else {
 331                 $graft_map{acqlia} =
 332                     $query->{from}{$core}{jub}{join}{acqlia} =
 333                     $acqlia_join->();
 334             }
 335         } elsif ($class eq 'acqinv' or $core eq 'acqinv') {
 336             $graft_map{$class} =
 337                 $query->{from}{$core}{acqmapinv}{join}{$class} ||= {};
 338             $graft_map{$class}{type} = $join_type;
 339         } else {
 340             $graft_map{$class} = $query->{from}{$core}{$class} ||= {};
 341             $graft_map{$class}{type} = $join_type;
 342         }
 343     }
 344
 345     return \%graft_map;
 346 }
 347
 348 __PACKAGE__->register_method(
 349     method    => "unified_search",
 350     api_name  => "open-ils.acq.lineitem.unified_search",
 351     stream    => 1,
 352     signature => {
 353         desc   => q/Returns lineitems based on flexible search terms./,
 354         params => [
 355             {desc => "Authentication token", type => "string"},
 356             {desc => "Field/value pairs for AND'ing", type => "object"},
 357             {desc => "Field/value pairs for OR'ing", type => "object"},
 358             {desc => "Conjunction between AND pairs and OR pairs " .
 359                 "(can be 'and' or 'or')", type => "string"},
 360             {desc => "Retrieval options (clear_marc, flesh_notes, etc) " .
 361                 "- XXX detail all the options",
 362                 type => "object"}
 363         ],
 364         return => {desc => "A stream of LIs on success, Event on failure"}
 365     }
 366 );
 367
 368 __PACKAGE__->register_method(
 369     method    => "unified_search",
 370     api_name  => "open-ils.acq.purchase_order.unified_search",
 371     stream    => 1,
 372     signature => {
 373         desc   => q/Returns purchase orders based on flexible search terms.
 374             See open-ils.acq.lineitem.unified_search/,
 375         return => {desc => "A stream of POs on success, Event on failure"}
 376     }
 377 );
 378
 379 __PACKAGE__->register_method(
 380     method    => "unified_search",
 381     api_name  => "open-ils.acq.picklist.unified_search",
 382     stream    => 1,
 383     signature => {
 384         desc   => q/Returns pick lists based on flexible search terms.
 385             See open-ils.acq.lineitem.unified_search/,
 386         return => {desc => "A stream of PLs on success, Event on failure"}
 387     }
 388 );
 389
 390 __PACKAGE__->register_method(
 391     method    => "unified_search",
 392     api_name  => "open-ils.acq.invoice.unified_search",
 393     stream    => 1,
 394     signature => {
 395         desc   => q/Returns invoices lists based on flexible search terms.
 396             See open-ils.acq.lineitem.unified_search/,
 397         return => {desc => "A stream of invoices on success, Event on failure"}
 398     }
 399 );
 400
 401 sub unified_search {
 402     my ($self, $conn, $auth, $and_terms, $or_terms, $conj, $options) = @_;
 403     $options ||= {};
 404
 405     my $e = new_editor("authtoken" => $auth);
 406     return $e->die_event unless $e->checkauth;
 407
 408     # What kind of object are we returning? Important: (\w+) had better be
 409     # a legit acq classname particle, so don't register any crazy api_names.
 410     my $ret_type = ($self->api_name =~ /cq.(\w+).un/)[0];
 411     my $retriever = $RETRIEVERS{$ret_type};
 412     my $hint = F("acq::$ret_type")->{"hint"};
 413
 414     my $select_clause = {
 415         $hint => [{"column" => "id", "transform" => "distinct"}]
 416     };
 417
 418     if ($options->{"order_by"}) {
 419         # What's the point of this block?  When using ORDER BY in conjuction
 420         # with SELECT DISTINCT, the fields present in ORDER BY have to also
 421         # be in the SELECT clause.  This will take _one_ such field and add
 422         # it to the SELECT clause as needed.
 423         my ($order_by, $class, $field);
 424         unless (
 425             ($order_by = $options->{"order_by"}->[0]) &&
 426             ($class = $order_by->{"class"}) =~ /^[\da-z_]+$/ &&
 427             ($field = $order_by->{"field"}) =~ /^[\da-z_]+$/
 428         ) {
 429             $e->disconnect;
 430             return new OpenILS::Event(
 431                 "BAD_PARAMS", "note" =>
 432 q/order_by clause must be of the long form, like:
 433 "order_by": [{"class": "foo", "field": "bar", "direction": "asc"}]/
 434             );
 435         } else {
 436             $select_clause->{$class} ||= [];
 437             push @{$select_clause->{$class}}, $field;
 438         }
 439     }
 440
 441     my $query = {
 442         select => $select_clause,
 443         order_by => ($options->{order_by} || {$hint => {id => {}}}),
 444         offset => ($options->{offset} || 0)
 445     };
 446
 447     $query->{"limit"} = $options->{"limit"} if $options->{"limit"};
 448
 449     my $graft_map = build_from_clause_and_joins(
 450         $query, $hint, $and_terms, $or_terms
 451     );
 452
 453     $and_terms = prepare_terms($and_terms, 1);
 454     $or_terms = prepare_terms($or_terms, 0);
 455
 456     my $offset = add_au_joins($graft_map, $hint, prepare_au_terms($and_terms));
 457     add_au_joins($graft_map, $hint, prepare_au_terms($or_terms, $offset));
 458
 459     if ($and_terms and $or_terms) {
 460         $query->{"where"} = {
 461             "-" . (lc $conj eq "or" ? "or" : "and") => [$and_terms, $or_terms]
 462         };
 463     } elsif ($and_terms) {
 464         $query->{"where"} = $and_terms;
 465     } elsif ($or_terms) {
 466         $query->{"where"} = $or_terms;
 467     } else {
 468         $e->disconnect;
 469         return new OpenILS::Event("BAD_PARAMS", "desc" => "No usable terms");
 470     }
 471
 472     my $results = $e->json_query($query) or return $e->die_event;
 473     my @id_list = map { $_->{"id"} } (grep { $_->{"id"} } @$results);
 474
 475     if ($options->{"id_list"}) {
 476         $conn->respond($_) foreach @id_list;
 477     } else {
 478         foreach(@id_list){
 479             my $resp = $retriever->($e, $_, $options);
 480             next if(ref($resp) ne "Fieldmapper::acq::$ret_type");
 481             $conn->respond($resp);
 482         }
 483     }
 484
 485     $e->disconnect;
 486     undef;
 487 }
 488
 489 __PACKAGE__->register_method(
 490     method    => "bib_search",
 491     api_name  => "open-ils.acq.biblio.wrapped_search",
 492     stream    => 1,
 493     signature => {
 494         desc   => q/Returns new lineitems for each matching bib record/,
 495         params => [
 496             {desc => "Authentication token", type => "string"},
 497             {desc => "search string", type => "string"},
 498             {desc => "search options", type => "object"}
 499         ],
 500         return => {desc => "A stream of LIs on success, Event on failure"}
 501     }
 502 );
 503
 504 __PACKAGE__->register_method(
 505     method    => "bib_search",
 506     api_name  => "open-ils.acq.biblio.create_by_id",
 507     stream    => 1,
 508     signature => {
 509         desc   => q/Returns new lineitems for each matching bib record/,
 510         params => [
 511             {desc => "Authentication token", type => "string"},
 512             {desc => "list of bib IDs", type => "array"},
 513             {desc => "options (for lineitem fleshing)", type => "object"}
 514         ],
 515         return => {desc => "A stream of LIs on success, Event on failure"}
 516     }
 517 );
 518
 519 # This is very similar to zsearch() in Order.pm
 520 sub bib_search {
 521     my ($self, $conn, $auth, $search, $opts) = @_;
 522
 523     my $e = new_editor("authtoken" => $auth, "xact" => 1);
 524     return $e->die_event unless $e->checkauth;
 525     return $e->die_event unless $e->allowed("CREATE_PICKLIST");
 526
 527     my $mgr = new OpenILS::Application::Acq::BatchManager(
 528         "editor" => $e, "conn" => $conn
 529     );
 530
 531     $opts ||= {};
 532
 533     my $picklist;
 534     my @li_ids = ();
 535     if ($self->api_name =~ /create_by_id/) {
 536         $search = [ sort @$search ]; # for consitency
 537         my $bibs = $e->search_biblio_record_entry(
 538             {"id" => $search}, {"order_by" => {"bre" => ["id"]}}
 539         ) or return $e->die_event;
 540
 541         if ($opts->{"reuse_picklist"}) {
 542             $picklist = $e->retrieve_acq_picklist($opts->{"reuse_picklist"}) or
 543                 return $e->die_event;
 544             return $e->die_event unless
 545                 $e->allowed("UPDATE_PICKLIST", $picklist->org_unit);
 546
 547             # If we're reusing an existing picklist, we don't need to
 548             # create new lineitems for any bib records for which we already
 549
 550             my $already_have = $e->search_acq_lineitem({
 551                 "picklist" => $picklist->id,
 552                 "eg_bib_id" => [ map { $_->id } @$bibs ]
 553             }) or return $e->die_event;
 554
 555             # So in that case we a) save the lineitem id's of the relevant
 556             # items that already exist so that we can return those items later,
 557             # and b) remove the bib id's in question from our list of bib
 558             # id's to lineitemize.
 559             if (@$already_have) {
 560                 push @li_ids, $_->id foreach (@$already_have);
 561                 my @new_bibs = ();
 562                 foreach my $bib (@$bibs) {
 563                     push @new_bibs, $bib unless
 564                         grep { $_->eg_bib_id == $bib->id } @$already_have;
 565                 }
 566                 $bibs = [ @new_bibs ];
 567             }
 568         } else {
 569             $picklist = OpenILS::Application::Acq::Order::zsearch_build_pl($mgr, undef)
 570                 or return $e->die_event;
 571         }
 572
 573         $conn->respond($picklist->id);
 574
 575         push @li_ids, map {
 576             OpenILS::Application::Acq::Order::create_lineitem(
 577                 $mgr,
 578                 "picklist" => $picklist->id,
 579                 "source_label" => "native-evergreen-catalog",
 580                 "marc" => $_->marc,
 581                 "eg_bib_id" => $_->id
 582             )->id;
 583         } (@$bibs);
 584     } else {
 585         $opts->{"limit"} ||= 10;
 586
 587         my $ses = create OpenSRF::AppSession("open-ils.search");
 588         my $req = $ses->request(
 589             "open-ils.search.biblio.multiclass.query.staff", $opts, $search
 590         );
 591
 592         my $count = 0;
 593         while (my $resp = $req->recv("timeout" => 60)) {
 594             $picklist = OpenILS::Application::Acq::Order::zsearch_build_pl(
 595                 $mgr, undef
 596             ) unless $count++;
 597
 598             my $result = $resp->content;
 599             next if not ref $result;
 600
 601             # The result object contains a whole heck of a lot more information
 602             # than just bib IDs, so maybe we could tell the client something
 603             # useful (progress meter at least) in the future...
 604             push @li_ids, map {
 605                 my $bib = $_->[0];
 606                 OpenILS::Application::Acq::Order::create_lineitem(
 607                     $mgr,
 608                     "picklist" => $picklist->id,
 609                     "source_label" => "native-evergreen-catalog",
 610                     "marc" => $e->retrieve_biblio_record_entry($bib)->marc,
 611                     "eg_bib_id" => $bib
 612                 )->id;
 613             } (@{$result->{"ids"}});
 614         }
 615         $ses->disconnect;
 616     }
 617
 618     $e->commit;
 619
 620     $logger->info("created @li_ids new lineitems for picklist $picklist");
 621
 622     # new editor, but still using transaction to ensure correct retrieval
 623     # in a replicated setup
 624     $e = new_editor("authtoken" => $auth, xact => 1) or return $e->die_event;
 625     return $e->die_event unless $e->checkauth;
 626     $conn->respond($RETRIEVERS{"lineitem"}->($e, $_, $opts)) foreach @li_ids;
 627     $e->rollback;
 628     $e->disconnect;
 629
 630     undef;
 631 }
 632
 633 1;