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