Open-ILS/src/perlmods/lib/OpenILS/WWW/AutoSuggest.pm

   1 package OpenILS::WWW::AutoSuggest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Apache2::Log;
   7 use Apache2::Const -compile => qw(
   8     OK HTTP_NOT_ACCEPTABLE HTTP_INTERNAL_SERVER_ERROR :log
   9 );
  10 use XML::LibXML;
  11 use Text::Glob;
  12 use CGI qw(:all -utf8);
  13
  14 use OpenSRF::Utils::JSON;
  15 use OpenILS::Utils::CStoreEditor qw/:funcs/;
  16
  17 # BEGIN package globals
  18
  19 # We'll probably never need this fanciness for autosuggest, but
  20 # you can add handlers for different requested content-types here, and
  21 # you can weight them to control what matches requests for things like
  22 # 'application/*'
  23
  24 my $_output_handler_dispatch = {
  25     "application/xml" => {
  26         "prio" => 0,
  27         "code" => sub {
  28             my ($r, $data) = @_;
  29             $r->content_type("application/xml; charset=utf-8");
  30             print suggestions_to_xml($data);
  31             return Apache2::Const::OK;
  32         }
  33     },
  34     "application/json" => {
  35         "prio" => 1,
  36         "code" => sub {
  37             my ($r, $data) = @_;
  38             $r->content_type("application/json; charset=utf-8");
  39             print suggestions_to_json($data);
  40             return Apache2::Const::OK;
  41         }
  42     }
  43 };
  44
  45 my @_output_handler_types = sort {
  46     $_output_handler_dispatch->{$a}->{prio} <=>
  47         $_output_handler_dispatch->{$b}->{prio}
  48 } keys %$_output_handler_dispatch;
  49
  50 # END package globals
  51
  52 # Given a string such as a user might type into a search box, prepare
  53 # it for to_tsquery(). See
  54 # http://www.postgresql.org/docs/9.0/static/textsearch-controls.html
  55 sub prepare_for_tsquery {
  56     my ($str) = shift;
  57
  58     $str =~ s/[^\w\s]/ /ig;
  59     $str .= ":*" unless $str =~ /\s$/;
  60
  61     return join(" & ", split(/\s+/, $str));
  62 }
  63
  64 # The third argument to our stored procedure, metabib.suggest_browse_entries(),
  65 # is passed through directly to ts_headline() as the 'options' arugment.
  66 sub prepare_headline_opts {
  67     my ($css_prefix, $highlight_min, $highlight_max, $short_word_length) = @_;
  68
  69     $css_prefix =~ s/[^\w]//g;
  70
  71     my @parts = (
  72         qq{StartSel="<span class='$css_prefix'>"},
  73         "StopSel=</span>"
  74     );
  75
  76     push @parts, "MinWords=$highlight_min" if $highlight_min > 0;
  77     push @parts, "MaxWords=$highlight_max" if $highlight_max > 0;
  78     push @parts, "ShortWord=$short_word_length" if defined $short_word_length;
  79
  80     return join(", ", @parts);
  81 }
  82
  83 # Get raw autosuggest data (rows returned from a stored procedure) from the DB.
  84 sub get_suggestions {
  85     my $editor = shift;
  86     my $query = shift;
  87     my $search_class = shift;
  88     my $org_unit = shift;
  89     my $css_prefix = shift || 'oils_AS';
  90     my $highlight_min = int(shift || 0);
  91     my $highlight_max = int(shift || 0);
  92     my $short_word_length = shift;
  93
  94     my $normalization = int(shift || 14);   # 14 is not totally arbitrary.
  95     # See http://www.postgresql.org/docs/9.0/static/textsearch-controls.html#TEXTSEARCH-RANKING
  96
  97     my $limit = int(shift || 10);
  98
  99     $limit = 10 unless $limit > 0;
 100
 101     my $headline_opts = prepare_headline_opts(
 102         $css_prefix, $highlight_min, $highlight_max,
 103         defined $short_word_length ? int($short_word_length) : undef
 104     );
 105
 106     return $editor->json_query({
 107         "from" => [
 108             "metabib.suggest_browse_entries",
 109             prepare_for_tsquery($query),
 110             $search_class,
 111             $headline_opts,
 112             $org_unit,
 113             $limit,
 114             $normalization
 115         ]
 116     });
 117 }
 118
 119 sub suggestions_to_xml {
 120     my ($suggestions) = @_;
 121
 122     my $dom = new XML::LibXML::Document("1.0", "UTF-8");
 123     my $as = $dom->createElement("as");
 124     $dom->setDocumentElement($as);
 125
 126     foreach (@$suggestions) {
 127         my $val = $dom->createElement("val");
 128         $val->setAttribute("term", $_->{value});
 129         $val->setAttribute("field", $_->{field});
 130         $val->appendText($_->{match});
 131         $as->addChild($val);
 132     }
 133
 134     # XML::LibXML::Document::toString() returns an encoded byte string, which
 135     # is why we don't need to binmode STDOUT, ':utf8'.
 136     return $dom->toString();
 137 }
 138
 139 sub suggestions_to_json {
 140     my ($suggestions) = @_;
 141
 142     return OpenSRF::Utils::JSON->perl2JSON({
 143         "val" => [
 144             map {
 145                 +{ term => $_->{value}, field => $_->{field},
 146                     match => $_->{match} }
 147             } @$suggestions
 148         ]
 149     });
 150 }
 151
 152 # Given data and the Apache request object, this sub picks a sub from a
 153 # dispatch table based on the list of content-type encodings that the client
 154 # has indicated it will accept, and calls that sub, which will deliver
 155 # a response of appropriately encoded data.
 156 sub output_handler {
 157     my ($r, $data) = @_;
 158
 159     foreach my $media_range (split /,/, $r->headers_in->{Accept}) {
 160         $media_range =~ s/;.+$//; # keep type, subtype. lose parameters.
 161
 162         my ($match) = grep {
 163             Text::Glob::match_glob($media_range, $_)
 164         } @_output_handler_types;
 165
 166         if ($match) {
 167             return $_output_handler_dispatch->{$match}{code}->($r, $data);
 168         }
 169     }
 170
 171     return Apache2::Const::HTTP_NOT_ACCEPTABLE;
 172 }
 173
 174 sub handler {
 175     my $r = shift;
 176     my $cgi = new CGI;
 177
 178     my $editor = new_editor;
 179     my $suggestions = get_suggestions(
 180         $editor,
 181         map { scalar($cgi->param($_)) } qw(
 182             query
 183             search_class
 184             org_unit
 185             css_prefix
 186             highlight_min
 187             highlight_max
 188             short_word_length
 189             normalization
 190             limit
 191         )
 192     );
 193
 194     if (not $suggestions) {
 195         $r->log->error(
 196             "get_suggestions() failed: " . $editor->die_event->{textcode}
 197         );
 198         return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
 199     }
 200
 201     $editor->disconnect;
 202
 203     return output_handler($r, $suggestions);
 204 }
 205
 206 1;